version 1.1, 2023/01/31 09:24:19
|
version 1.6, 2024/04/24 21:10:29
|
Line 1
|
Line 1
|
/* $Id$ |
/* $Id$ |
$State$ |
$State$ |
$Log$ |
$Log$ |
Revision 1.1 2023/01/31 09:24:19 brouard |
Revision 1.6 2024/04/24 21:10:29 brouard |
Summary: version s1 with praxis instead of Powell for large models with age and difficulties to converge |
Summary: First IMaCh version using Brent Praxis software based on Buckhardt and Gegenfürtner C codes |
|
|
|
Revision 1.5 2023/10/09 09:10:01 brouard |
|
Summary: trying to reconsider |
|
|
|
Revision 1.4 2023/06/22 12:50:51 brouard |
|
Summary: stil on going |
|
|
|
Revision 1.3 2023/06/22 11:28:07 brouard |
|
*** empty log message *** |
|
|
|
Revision 1.2 2023/06/22 11:22:40 brouard |
|
Summary: with svd but not working yet |
|
|
|
Revision 1.353 2023/05/08 18:48:22 brouard |
|
*** empty log message *** |
|
|
|
Revision 1.352 2023/04/29 10:46:21 brouard |
|
*** empty log message *** |
|
|
|
Revision 1.351 2023/04/29 10:43:47 brouard |
|
Summary: 099r45 |
|
|
|
Revision 1.350 2023/04/24 11:38:06 brouard |
|
*** empty log message *** |
|
|
|
Revision 1.349 2023/01/31 09:19:37 brouard |
|
Summary: Improvements in models with age*Vn*Vm |
|
|
Revision 1.347 2022/09/18 14:36:44 brouard |
Revision 1.347 2022/09/18 14:36:44 brouard |
Summary: version 0.99r42 |
Summary: version 0.99r42 |
Line 1266 Important routines
|
Line 1293 Important routines
|
/* #define POWELLORIGINAL /\* Don't use Directest to decide new direction but original Powell test *\/ */ |
/* #define POWELLORIGINAL /\* Don't use Directest to decide new direction but original Powell test *\/ */ |
/* #define MNBRAKORIGINAL /\* Don't use mnbrak fix *\/ */ |
/* #define MNBRAKORIGINAL /\* Don't use mnbrak fix *\/ */ |
/* #define FLATSUP *//* Suppresses directions where likelihood is flat */ |
/* #define FLATSUP *//* Suppresses directions where likelihood is flat */ |
|
/* #define POWELLORIGINCONJUGATE /\* Don't use conjugate but biggest decrease if valuable *\/ */ |
|
/* #define NOTMINFIT */ |
|
|
#include <math.h> |
#include <math.h> |
#include <stdio.h> |
#include <stdio.h> |
Line 1362 double gnuplotversion=GNUPLOTVERSION;
|
Line 1391 double gnuplotversion=GNUPLOTVERSION;
|
/* $State$ */ |
/* $State$ */ |
#include "version.h" |
#include "version.h" |
char version[]=__IMACH_VERSION__; |
char version[]=__IMACH_VERSION__; |
char copyright[]="January 2023,INED-EUROREVES-Institut de longevite-Japan Society for the Promotion of Science (Grant-in-Aid for Scientific Research 25293121), Intel Software 2015-2020, Nihon University 2021-202, INED 2000-2022"; |
char copyright[]="April 2023,INED-EUROREVES-Institut de longevite-Japan Society for the Promotion of Science (Grant-in-Aid for Scientific Research 25293121), Intel Software 2015-2020, Nihon University 2021-202, INED 2000-2022"; |
char fullversion[]="$Revision$ $Date$"; |
char fullversion[]="$Revision$ $Date$"; |
char strstart[80]; |
char strstart[80]; |
char optionfilext[10], optionfilefiname[FILENAMELENGTH]; |
char optionfilext[10], optionfilefiname[FILENAMELENGTH]; |
Line 1410 int *wav; /* Number of waves for this in
|
Line 1439 int *wav; /* Number of waves for this in
|
int maxwav=0; /* Maxim number of waves */ |
int maxwav=0; /* Maxim number of waves */ |
int jmin=0, jmax=0; /* min, max spacing between 2 waves */ |
int jmin=0, jmax=0; /* min, max spacing between 2 waves */ |
int ijmin=0, ijmax=0; /* Individuals having jmin and jmax */ |
int ijmin=0, ijmax=0; /* Individuals having jmin and jmax */ |
int gipmx=0, gsw=0; /* Global variables on the number of contributions |
int gipmx = 0; |
|
double gsw = 0; /* Global variables on the number of contributions |
to the likelihood and the sum of weights (done by funcone)*/ |
to the likelihood and the sum of weights (done by funcone)*/ |
int mle=1, weightopt=0; |
int mle=1, weightopt=0; |
int **mw; /* mw[mi][i] is number of the mi wave for this individual */ |
int **mw; /* mw[mi][i] is number of the mi wave for this individual */ |
Line 1474 extern time_t time();
|
Line 1504 extern time_t time();
|
|
|
struct tm start_time, end_time, curr_time, last_time, forecast_time; |
struct tm start_time, end_time, curr_time, last_time, forecast_time; |
time_t rstart_time, rend_time, rcurr_time, rlast_time, rforecast_time; /* raw time */ |
time_t rstart_time, rend_time, rcurr_time, rlast_time, rforecast_time; /* raw time */ |
|
time_t rlast_btime; /* raw time */ |
struct tm tm; |
struct tm tm; |
|
|
char strcurr[80], strfor[80]; |
char strcurr[80], strfor[80]; |
Line 1597 int **nbcode, *Tvar; /**< model=V2 => Tv
|
Line 1628 int **nbcode, *Tvar; /**< model=V2 => Tv
|
/* Tprod[i]=k 1 2 */ /* Position in model of the ith prod without age */ |
/* Tprod[i]=k 1 2 */ /* Position in model of the ith prod without age */ |
/* cptcovage 1 2 3 */ /* Counting cov*age in the model equation */ |
/* cptcovage 1 2 3 */ /* Counting cov*age in the model equation */ |
/* Tage[cptcovage]=k 5 8 10 */ /* Position in the model of ith cov*age */ |
/* Tage[cptcovage]=k 5 8 10 */ /* Position in the model of ith cov*age */ |
|
/* model="V2+V3+V4+V6+V7+V6*V2+V7*V2+V6*V3+V7*V3+V6*V4+V7*V4+age*V2+age*V3+age*V4+age*V6+age*V7+age*V6*V2+age*V6*V3+age*V7*V3+age*V6*V4+age*V7*V4\r"*/ |
|
/* p Tvard[1][1]@21 = {6, 2, 7, 2, 6, 3, 7, 3, 6, 4, 7, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0}*/ |
|
/* p Tvard[2][1]@21 = {7, 2, 6, 3, 7, 3, 6, 4, 7, 4, 0 <repeats 11 times>} */ |
|
/* p Tvardk[1][1]@24 = {0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 6, 2, 7, 2, 6, 3, 7, 3, 6, 4, 7, 4, 0, 0}*/ |
|
/* p Tvardk[1][1]@22 = {0, 0, 0, 0, 0, 0, 0, 0, 6, 2, 7, 2, 6, 3, 7, 3, 6, 4, 7, 4, 0, 0} */ |
/* Tvard[1][1]@4={4,3,1,2} V4*V3 V1*V2 */ /* Position in model of the ith prod without age */ |
/* Tvard[1][1]@4={4,3,1,2} V4*V3 V1*V2 */ /* Position in model of the ith prod without age */ |
/* Tvardk[4][1]=4;Tvardk[4][2]=3;Tvardk[7][1]=1;Tvardk[7][2]=2 */ /* Variables of a prod at position in the model equation*/ |
/* Tvardk[4][1]=4;Tvardk[4][2]=3;Tvardk[7][1]=1;Tvardk[7][2]=2 */ /* Variables of a prod at position in the model equation*/ |
/* TvarF TvarF[1]=Tvar[6]=2, TvarF[2]=Tvar[7]=7, TvarF[3]=Tvar[9]=1 ID of fixed covariates or product V2, V1*V2, V1 */ |
/* TvarF TvarF[1]=Tvar[6]=2, TvarF[2]=Tvar[7]=7, TvarF[3]=Tvar[9]=1 ID of fixed covariates or product V2, V1*V2, V1 */ |
Line 1795 char *trimbb(char *out, char *in)
|
Line 1831 char *trimbb(char *out, char *in)
|
return s; |
return s; |
} |
} |
|
|
|
char *trimbtab(char *out, char *in) |
|
{ /* Trim blanks or tabs in line but keeps first blanks if line starts with blanks */ |
|
char *s; |
|
s=out; |
|
while (*in != '\0'){ |
|
while( (*in == ' ' || *in == '\t')){ /* && *(in+1) != '\0'){*/ |
|
in++; |
|
} |
|
*out++ = *in++; |
|
} |
|
*out='\0'; |
|
return s; |
|
} |
|
|
/* char *substrchaine(char *out, char *in, char *chain) */ |
/* char *substrchaine(char *out, char *in, char *chain) */ |
/* { */ |
/* { */ |
/* /\* Substract chain 'chain' from 'in', return and output 'out' *\/ */ |
/* /\* Substract chain 'chain' from 'in', return and output 'out' *\/ */ |
Line 2577 void linmin(double p[], double xi[], int
|
Line 2627 void linmin(double p[], double xi[], int
|
free_vector(pcom,1,n); |
free_vector(pcom,1,n); |
} |
} |
|
|
/**** praxis ****/ |
/**** praxis gegen ****/ |
# include <float.h> |
|
/* # include <math.h> */ |
|
/* # include <stdio.h> */ |
|
/* # include <stdlib.h> */ |
|
/* # include <string.h> */ |
|
/* # include <time.h> */ |
|
|
|
# include "praxis.h" |
|
|
|
/******************************************************************************/ |
|
|
|
double flin ( int n, int jsearch, double l, double (*func) ( double [] ), |
|
double x[], int *nf, double v[], double q0[], double q1[], double *qd0, |
|
double *qd1, double *qa, double *qb, double *qc ) |
|
/* double flin ( int n, int jsearch, double l, double f ( double x[], int n ), */ |
|
/* double x[], int *nf, double v[], double q0[], double q1[], double *qd0, */ |
|
/* double *qd1, double *qa, double *qb, double *qc ) */ |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
FLIN is the function of one variable to be minimized by MINNY. |
|
|
|
Discussion: |
|
|
|
F(X) is a scalar function of a vector argument X. |
|
|
|
A minimizer of F(X) is sought along a line or parabola. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
/* This has been tested by Visual C from Microsoft and works */ |
|
/* meaning tha valgrind could be wrong */ |
|
/*********************************************************************/ |
|
/* f u n c t i o n p r a x i s */ |
|
/* */ |
|
/* praxis is a general purpose routine for the minimization of a */ |
|
/* function in several variables. the algorithm used is a modifi- */ |
|
/* cation of conjugate gradient search method by powell. the changes */ |
|
/* are due to r.p. brent, who gives an algol-w program, which served */ |
|
/* as a basis for this function. */ |
|
/* */ |
|
/* references: */ |
|
/* - powell, m.j.d., 1964. an efficient method for finding */ |
|
/* the minimum of a function in several variables without */ |
|
/* calculating derivatives, computer journal, 7, 155-162 */ |
|
/* - brent, r.p., 1973. algorithms for minimization without */ |
|
/* derivatives, prentice hall, englewood cliffs. */ |
|
/* */ |
|
/* problems, suggestions or improvements are always wellcome */ |
|
/* karl gegenfurtner 07/08/87 */ |
|
/* c - version */ |
|
/*********************************************************************/ |
|
/* */ |
|
/* usage: min = praxis(tol, macheps, h, n, prin, x, func) */ |
|
/* macheps has been suppressed because it is replaced by DBL_EPSILON */ |
|
/* and if it was an argument of praxis (as it is in original brent) */ |
|
/* it should be declared external */ |
|
/* usage: min = praxis(tol, h, n, prin, x, func) */ |
|
/* was min = praxis(fun, x, n); */ |
|
/* */ |
|
/* fun the function to be minimized. fun is called from */ |
|
/* praxis with x and n as arguments */ |
|
/* x a double array containing the initial guesses for */ |
|
/* the minimum, which will contain the solution on */ |
|
/* return */ |
|
/* n an integer specifying the number of unknown */ |
|
/* parameters */ |
|
/* min praxis returns the least calculated value of fun */ |
|
/* */ |
|
/* some additional global variables control some more aspects of */ |
|
/* the inner workings of praxis. setting them is optional, they */ |
|
/* are all set to some reasonable default values given below. */ |
|
/* */ |
|
/* prin controls the printed output from the routine. */ |
|
/* 0 -> no output */ |
|
/* 1 -> print only starting and final values */ |
|
/* 2 -> detailed map of the minimization process */ |
|
/* 3 -> print also eigenvalues and vectors of the */ |
|
/* search directions */ |
|
/* the default value is 1 */ |
|
/* tol is the tolerance allowed for the precision of the */ |
|
/* solution. praxis returns if the criterion */ |
|
/* 2 * ||x[k]-x[k-1]|| <= sqrt(macheps) * ||x[k]|| + tol */ |
|
/* is fulfilled more than ktm times. */ |
|
/* the default value depends on the machine precision */ |
|
/* ktm see just above. default is 1, and a value of 4 leads */ |
|
/* to a very(!) cautious stopping criterion. */ |
|
/* h0 or step is a steplength parameter and should be set equal */ |
|
/* to the expected distance from the solution. */ |
|
/* exceptionally small or large values of step lead to */ |
|
/* slower convergence on the first few iterations */ |
|
/* the default value for step is 1.0 */ |
|
/* scbd is a scaling parameter. 1.0 is the default and */ |
|
/* indicates no scaling. if the scales for the different */ |
|
/* parameters are very different, scbd should be set to */ |
|
/* a value of about 10.0. */ |
|
/* illc should be set to true (1) if the problem is known to */ |
|
/* be ill-conditioned. the default is false (0). this */ |
|
/* variable is automatically set, when praxis finds */ |
|
/* the problem to be ill-conditioned during iterations. */ |
|
/* maxfun is the maximum number of calls to fun allowed. praxis */ |
|
/* will return after maxfun calls to fun even when the */ |
|
/* minimum is not yet found. the default value of 0 */ |
|
/* indicates no limit on the number of calls. */ |
|
/* this return condition is only checked every n */ |
|
/* iterations. */ |
|
/* */ |
|
/*********************************************************************/ |
|
|
28 July 2016 |
#include <math.h> |
|
#include <stdio.h> |
Author: |
#include <stdlib.h> |
|
#include <float.h> /* for DBL_EPSILON */ |
Original FORTRAN77 version by Richard Brent. |
/* #include "machine.h" */ |
C version by John Burkardt. |
|
|
|
Reference: |
|
|
|
Richard Brent, |
|
Algorithms for Minimization with Derivatives, |
|
Prentice Hall, 1973, |
|
Reprinted by Dover, 2002. |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of variables. |
|
|
|
Input, int JSEARCH, indicates the kind of search. |
|
If JSEARCH is a legal column index, linear search along V(*,JSEARCH). |
|
If JSEARCH is -1, then the search is parabolic, based on X, Q0 and Q1. |
|
|
|
Input, double L, is the parameter determining the particular |
|
point at which F is to be evaluated. |
|
For a linear search, L is the step size. |
|
For a quadratic search, L is a parameter which specifies |
|
a point in the plane of X, Q0 and Q1. |
|
|
|
Input, double F ( double X[], int N ), the function to be minimized. |
|
|
|
Input, double X[N], the base point of the search. |
|
|
|
Input/output, int *NF, the function evaluation counter. |
|
|
|
Input, double V[N,N], a matrix whose columns constitute |
/* extern void minfit(int n, double eps, double tol, double **ab, double q[]); */ |
search directions. |
/* extern void minfit(int n, double eps, double tol, double ab[N][N], double q[]); */ |
|
/* control parameters */ |
|
/* control parameters */ |
|
#define SQREPSILON 1.0e-19 |
|
/* #define EPSILON 1.0e-8 */ /* in main */ |
|
|
|
double tol = SQREPSILON, |
|
scbd = 1.0, |
|
step = 1.0; |
|
int ktm = 1, |
|
/* prin = 2, */ |
|
maxfun = 0, |
|
illc = 0; |
|
|
|
/* some global variables */ |
|
static int i, j, k, k2, nl, nf, kl, kt; |
|
/* static double s; */ |
|
double sl, dn, dmin, |
|
fx, f1, lds, ldt, sf, df, |
|
qf1, qd0, qd1, qa, qb, qc, |
|
m2, m4, small_windows, vsmall, large, |
|
vlarge, ldfac, t2; |
|
/* static double d[N], y[N], z[N], */ |
|
/* q0[N], q1[N], v[N][N]; */ |
|
|
|
static double *d, *y, *z; |
|
static double *q0, *q1, **v; |
|
double *tflin; /* used in flin: return (*fun)(tflin, n); */ |
|
double *e; /* used in minfit, don't konw how to free memory and thus made global */ |
|
/* static double s, sl, dn, dmin, */ |
|
/* fx, f1, lds, ldt, sf, df, */ |
|
/* qf1, qd0, qd1, qa, qb, qc, */ |
|
/* m2, m4, small, vsmall, large, */ |
|
/* vlarge, ldfac, t2; */ |
|
/* static double d[N], y[N], z[N], */ |
|
/* q0[N], q1[N], v[N][N]; */ |
|
|
|
/* these will be set by praxis to point to it's arguments */ |
|
static int prin; /* added */ |
|
static int n; |
|
static double *x; |
|
static double (*fun)(); |
|
/* static double (*fun)(double *x, int n); */ |
|
|
|
/* these will be set by praxis to the global control parameters */ |
|
/* static double h, macheps, t; */ |
|
extern double macheps; |
|
static double h; |
|
static double t; |
|
|
Input, double Q0[N], Q1[N], two auxiliary points used to |
static double |
determine the plane when a quadratic search is performed. |
drandom() /* return random no between 0 and 1 */ |
|
{ |
|
return (double)(rand()%(8192*2))/(double)(8192*2); |
|
} |
|
|
Input, double *QD0, *QD1, values needed to compute the |
static void sort() /* d and v in descending order */ |
coefficients QA, QB, QC. |
{ |
|
int k, i, j; |
|
double s; |
|
|
Output, double *QA, *QB, *QC, coefficients used to combine |
for (i=1; i<=n-1; i++) { |
Q0, X, and A1 if a quadratic search is used. |
k = i; s = d[i]; |
|
for (j=i+1; j<=n; j++) { |
|
if (d[j] > s) { |
|
k = j; |
|
s = d[j]; |
|
} |
|
} |
|
if (k > i) { |
|
d[k] = d[i]; |
|
d[i] = s; |
|
for (j=1; j<=n; j++) { |
|
s = v[j][i]; |
|
v[j][i] = v[j][k]; |
|
v[j][k] = s; |
|
} |
|
} |
|
} |
|
} |
|
|
Output, double FLIN, the value of the function at the |
double randbrent ( int *naught ) |
minimizing point. |
{ |
*/ |
double ran1, ran3[127], half; |
|
int ran2, q, r, i, j; |
|
int init=0; /* false */ |
|
double rr; |
|
/* REAL*8 RAN1,RAN3(127),HALF */ |
|
|
|
/* INTEGER RAN2,Q,R */ |
|
/* LOGICAL INIT */ |
|
/* DATA INIT/.FALSE./ */ |
|
/* IF (INIT) GO TO 3 */ |
|
if(!init){ |
|
/* R = MOD(NAUGHT,8190) + 1 *//* 1804289383 rand () */ |
|
r = *naught % 8190 + 1;/* printf(" naught r %d %d",*naught,r); */ |
|
ran2=127; |
|
for(i=ran2; i>0; i--){ |
|
/* RAN2 = 128 */ |
|
/* DO 2 I=1,127 */ |
|
ran2 = ran2-1; |
|
/* RAN2 = RAN2 - 1 */ |
|
ran1 = -pow(2.0,55); |
|
/* RAN1 = -2.D0**55 */ |
|
/* DO 1 J=1,7 */ |
|
for(j=1; j<=7;j++){ |
|
/* R = MOD(1756*R,8191) */ |
|
r = (1756*r) % 8191;/* printf(" i=%d (1756*r)%8191=%d",j,r); */ |
|
q=r/32; |
|
/* Q = R/32 */ |
|
/* 1 RAN1 = (RAN1 + Q)*(1.0D0/256) */ |
|
ran1 =(ran1+q)*(1.0/256); |
|
} |
|
/* 2 RAN3(RAN2) = RAN1 */ |
|
ran3[ran2] = ran1; /* printf(" ran2=%d ran1=%.7g \n",ran2,ran1); */ |
|
} |
|
/* INIT = .TRUE. */ |
|
init=1; |
|
/* 3 IF (RAN2.EQ.1) RAN2 = 128 */ |
|
} |
|
if(ran2 == 0) ran2 = 126; |
|
else ran2 = ran2 -1; |
|
/* RAN2 = RAN2 - 1 */ |
|
/* RAN1 = RAN1 + RAN3(RAN2) */ |
|
ran1 = ran1 + ran3[ran2];/* printf("BIS ran2=%d ran1=%.7g \n",ran2,ran1); */ |
|
half= 0.5; |
|
/* HALF = .5D0 */ |
|
/* IF (RAN1.GE.0.D0) HALF = -HALF */ |
|
if(ran1 >= 0.) half =-half; |
|
ran1 = ran1 +half; |
|
ran3[ran2] = ran1; |
|
rr= ran1+0.5; |
|
/* RAN1 = RAN1 + HALF */ |
|
/* RAN3(RAN2) = RAN1 */ |
|
/* RANDOM = RAN1 + .5D0 */ |
|
/* r = ( ( double ) ( *seed ) ) * 4.656612875E-10; */ |
|
return rr; |
|
} |
|
static void matprint(char *s, double **v, int m, int n) |
|
/* char *s; */ |
|
/* double v[N][N]; */ |
{ |
{ |
|
#define INCX 8 |
int i; |
int i; |
double *t; |
|
double value; |
int i2hi; |
|
int ihi; |
t = ( double * ) malloc ( n * sizeof ( double ) ); |
int ilo; |
/* |
int i2lo; |
The search is linear. |
int jlo=1; |
*/ |
int j; |
if ( 0 <= jsearch ) |
int j2hi; |
|
int jhi; |
|
int j2lo; |
|
ilo=1; |
|
ihi=n; |
|
jlo=1; |
|
jhi=n; |
|
|
|
printf ("\n" ); |
|
printf ("%s\n", s ); |
|
for ( j2lo = jlo; j2lo <= jhi; j2lo = j2lo + INCX ) |
{ |
{ |
for ( i = 0; i < n; i++ ) |
j2hi = j2lo + INCX - 1; |
|
if ( n < j2hi ) |
{ |
{ |
t[i] = x[i] + l * v[i+jsearch*n]; |
j2hi = n; |
} |
} |
} |
if ( jhi < j2hi ) |
/* |
|
The search is along a parabolic space curve. |
|
*/ |
|
else |
|
{ |
|
*qa = l * ( l - *qd1 ) / ( *qd0 + *qd1 ) / *qd0; |
|
*qb = - ( l + *qd0 ) * ( l - *qd1 ) / *qd1 / *qd0; |
|
*qc = ( l + *qd0 ) * l / *qd1 / ( *qd0 + *qd1 ); |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
{ |
t[i] = *qa * q0[i] + *qb * x[i] + *qc * q1[i]; |
j2hi = jhi; |
} |
} |
} |
|
/* |
|
The function evaluation counter NF is incremented. |
|
*/ |
|
*nf = *nf + 1; |
|
/* |
|
Evaluate the function. |
|
*/ |
|
value = (*func) ( (t-1) );/* This for func which is computed from x[1] and not from x[0] xm1=(x-1)*/ |
|
/* value = f ( t, n ); */ |
|
|
|
free ( t ); |
|
|
|
return value; |
|
} |
|
/******************************************************************************/ |
|
|
|
void minfit ( int n, double tol, double a[], double q[] ) |
/* fprintf ( ficlog, "\n" ); */ |
|
printf ("\n" ); |
/******************************************************************************/ |
|
/* |
/* |
Purpose: |
For each column J in the current range... |
|
|
MINFIT computes the singular value decomposition of an N by N array. |
|
|
|
Discussion: |
|
|
|
This is an improved version of the EISPACK routine MINFIT |
|
restricted to the case M = N and P = 0. |
|
|
|
The singular values of the array A are returned in Q. A is |
|
overwritten with the orthogonal matrix V such that U * diag(Q) = A * V, |
|
where U is another orthogonal matrix. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
30 July 2016 |
|
|
|
Author: |
|
|
|
Original FORTRAN77 version by Richard Brent. |
|
C version by John Burkardt. |
|
|
|
Reference: |
|
|
|
Richard Brent, |
|
Algorithms for Minimization with Derivatives, |
|
Prentice Hall, 1973, |
|
Reprinted by Dover, 2002. |
|
|
|
James Wilkinson, Christian Reinsch, |
|
Handbook for Automatic Computation, |
|
Volume II, Linear Algebra, Part 2, |
|
Springer Verlag, 1971. |
|
|
|
Brian Smith, James Boyle, Jack Dongarra, Burton Garbow, Yasuhiko Ikebe, |
|
Virginia Klema, Cleve Moler, |
|
Matrix Eigensystem Routines, EISPACK Guide, |
|
Lecture Notes in Computer Science, Volume 6, |
|
Springer Verlag, 1976, |
|
ISBN13: 978-3540075462, |
|
LC: QA193.M37. |
|
|
|
Parameters: |
|
|
|
Input, int N, the order of the matrix A. |
|
|
|
Input, double TOL, a tolerance which determines when a vector |
|
(a column or part of a column of the matrix) may be considered |
|
"essentially" equal to zero. |
|
|
|
Input/output, double A[N,N]. On input, an N by N array whose |
|
singular value decomposition is desired. On output, the |
|
SVD orthogonal matrix factor V. |
|
|
|
Input/output, double Q[N], the singular values. |
Write the header. |
*/ |
*/ |
{ |
/* fprintf ( ficlog, " Col: "); */ |
double c; |
printf ("Col:"); |
double *e; |
for ( j = j2lo; j <= j2hi; j++ ) |
double eps; |
{ |
double f; |
/* fprintf ( ficlog, " %7d ", j - 1 ); */ |
double g; |
/* printf (" %9d ", j - 1 ); */ |
double h; |
printf (" %9d ", j ); |
int i; |
} |
int ii; |
/* fprintf ( ficlog, "\n" ); */ |
int j; |
/* fprintf ( ficlog, " Row\n" ); */ |
int jj; |
/* fprintf ( ficlog, "\n" ); */ |
int k; |
printf ("\n" ); |
int kt; |
printf (" Row\n" ); |
const int kt_max = 30; |
printf ("\n" ); |
int l; |
|
int l2; |
|
double s; |
|
int skip; |
|
double temp; |
|
double x; |
|
double y; |
|
double z; |
|
/* |
/* |
Householder's reduction to bidiagonal form. |
Determine the range of the rows in this strip. |
*/ |
*/ |
if ( n == 1 ) |
if ( 1 < ilo ){ |
{ |
i2lo = ilo; |
q[0] = a[0+0*n]; |
}else{ |
a[0+0*n] = 1.0; |
i2lo = 1; |
return; |
|
} |
|
|
|
e = ( double * ) malloc ( n * sizeof ( double ) ); |
|
|
|
eps = DBL_EPSILON; |
|
g = 0.0; |
|
x = 0.0; |
|
|
|
for ( i = 1; i <= n; i++ ) |
|
{ |
|
e[i-1] = g; |
|
l = i + 1; |
|
|
|
s = 0.0; |
|
for ( ii = i; ii <= n; ii++ ) |
|
{ |
|
s = s + a[ii-1+(i-1)*n] * a[ii-1+(i-1)*n]; |
|
} |
|
|
|
g = 0.0; |
|
|
|
if ( tol <= s ) |
|
{ |
|
f = a[i-1+(i-1)*n]; |
|
|
|
g = sqrt ( s ); |
|
|
|
if ( 0.0 <= f ) |
|
{ |
|
g = - g; |
|
} |
|
|
|
h = f * g - s; |
|
a[i-1+(i-1)*n] = f - g; |
|
|
|
for ( j = l; j <= n; j++ ) |
|
{ |
|
f = 0.0; |
|
for ( ii = i; ii <= n; ii++ ) |
|
{ |
|
f = f + a[ii-1+(i-1)*n] * a[ii-1+(j-1)*n]; |
|
} |
|
f = f / h; |
|
|
|
for ( ii = i; ii <= n; ii++ ) |
|
{ |
|
a[ii-1+(j-1)*n] = a[ii-1+(j-1)*n] + f * a[ii-1+(i-1)*n]; |
|
} |
|
} |
|
} |
} |
|
if ( m < ihi ){ |
q[i-1] = g; |
i2hi = m; |
|
}else{ |
s = 0.0; |
i2hi = ihi; |
for ( j = l; j <= n; j++ ) |
|
{ |
|
s = s + a[i-1+(j-1)*n] * a[i-1+(j-1)*n]; |
|
} |
} |
|
|
g = 0.0; |
for ( i = i2lo; i <= i2hi; i++ ){ |
|
/* |
if ( tol <= s ) |
Print out (up to) 5 entries in row I, that lie in the current strip. |
{ |
*/ |
if ( i < n ) |
/* fprintf ( ficlog, "%5d:", i - 1 ); */ |
{ |
/* printf ("%5d:", i - 1 ); */ |
f = a[i-1+i*n]; |
printf ("%5d:", i ); |
} |
for ( j = j2lo; j <= j2hi; j++ ) |
|
|
g = sqrt ( s ); |
|
|
|
if ( 0.0 <= f ) |
|
{ |
|
g = - g; |
|
} |
|
|
|
h = f * g - s; |
|
|
|
if ( i < n ) |
|
{ |
{ |
a[i-1+i*n] = f - g; |
/* fprintf ( ficlog, " %14g", a[i-1+(j-1)*m] ); */ |
for ( jj = l; jj <= n; jj++ ) |
/* printf ("%14.7g ", a[i-1+(j-1)*m] ); */ |
{ |
/* printf("%14.7f ", v[i-1][j-1]); */ |
e[jj-1] = a[i-1+(jj-1)*n] / h; |
printf("%14.7f ", v[i][j]); |
} |
/* fprintf ( stdout, " %14g", a[i-1+(j-1)*m] ); */ |
|
|
for ( j = l; j <= n; j++ ) |
|
{ |
|
s = 0.0; |
|
for ( jj = l; jj <= n; jj++ ) |
|
{ |
|
s = s + a[j-1+(jj-1)*n] * a[i-1+(jj-1)*n]; |
|
} |
|
for ( jj = l; jj <= n; jj++ ) |
|
{ |
|
a[j-1+(jj-1)*n] = a[j-1+(jj-1)*n] + s * e[jj-1]; |
|
} |
|
} |
|
} |
} |
|
/* fprintf ( ficlog, "\n" ); */ |
|
printf ("\n" ); |
} |
} |
|
|
y = fabs ( q[i-1] ) + fabs ( e[i-1] ); |
|
|
|
x = fmax ( x, y ); |
|
} |
} |
/* |
|
Accumulation of right-hand transformations. |
/* printf("%s\n", s); */ |
*/ |
/* for (k=0; k<n; k++) { */ |
a[n-1+(n-1)*n] = 1.0; |
/* for (i=0; i<n; i++) { */ |
g = e[n-1]; |
/* /\* printf("%20.10e ", v[k][i]); *\/ */ |
l = n; |
/* } */ |
|
/* printf("\n"); */ |
|
/* } */ |
|
#undef INCX |
|
} |
|
|
for ( i = n - 1; 1 <= i; i-- ) |
void vecprint(char *s, double *x, int n) |
{ |
/* char *s; */ |
if ( g != 0.0 ) |
/* double x[N]; */ |
{ |
{ |
h = a[i-1+i*n] * g; |
int i=0; |
|
|
|
printf(" %s", s); |
|
/* for (i=0; i<n; i++) */ |
|
for (i=1; i<=n; i++) |
|
printf (" %14.7g", x[i] ); |
|
/* printf(" %8d: %14g\n", i, x[i]); */ |
|
printf ("\n" ); |
|
} |
|
|
for ( ii = l; ii <= n; ii++ ) |
static void print() /* print a line of traces */ |
{ |
{ |
a[ii-1+(i-1)*n] = a[i-1+(ii-1)*n] / h; |
|
} |
|
|
|
for ( j = l; j <= n; j++ ) |
printf("\n"); |
{ |
/* printf("... chi square reduced to ... %20.10e\n", fx); */ |
s = 0.0; |
/* printf("... after %u function calls ...\n", nf); */ |
for ( jj = l; jj <= n; jj++ ) |
/* printf("... including %u linear searches ...\n", nl); */ |
{ |
printf("%10d %10d%14.7g",nl, nf, fx); |
s = s + a[i-1+(jj-1)*n] * a[jj-1+(j-1)*n]; |
vecprint("... current values of x ...", x, n); |
} |
} |
|
/* static void print2(int n, double *x, int prin, double fx, int nf, int nl) */ /* print a line of traces */ |
|
static void print2() /* print a line of traces */ |
|
{ |
|
int i; double fmin=0.; |
|
|
for ( ii = l; ii <= n; ii++ ) |
/* printf("\n"); */ |
{ |
/* printf("... chi square reduced to ... %20.10e\n", fx); */ |
a[ii-1+(j-1)*n] = a[ii-1+(j-1)*n] + s * a[ii-1+(i-1)*n]; |
/* printf("... after %u function calls ...\n", nf); */ |
} |
/* printf("... including %u linear searches ...\n", nl); */ |
} |
/* printf("%10d %10d%14.7g",nl, nf, fx); */ |
} |
printf ( "\n" ); |
|
printf ( " Linear searches %d", nl ); |
|
/* printf ( " Linear searches %d\n", nl ); */ |
|
/* printf ( " Function evaluations %d\n", nf ); */ |
|
/* printf ( " Function value FX = %g\n", fx ); */ |
|
printf ( " Function evaluations %d", nf ); |
|
printf ( " Function value FX = %.12lf\n", fx ); |
|
#ifdef DEBUGPRAX |
|
printf("n=%d prin=%d\n",n,prin); |
|
#endif |
|
if(fx <= fmin) printf(" UNDEFINED "); else printf("%14.7g",log(fx-fmin)); |
|
if ( n <= 4 || 2 < prin ) |
|
{ |
|
/* for(i=1;i<=n;i++)printf("%14.7g",x[i-1]); */ |
|
for(i=1;i<=n;i++)printf("%14.7g",x[i]); |
|
/* r8vec_print ( n, x, " X:" ); */ |
|
} |
|
printf("\n"); |
|
} |
|
|
for ( jj = l; jj <= n; jj++ ) |
|
{ |
|
a[i-1+(jj-1)*n] = 0.0; |
|
} |
|
|
|
for ( ii = l; ii <= n; ii++ ) |
/* #ifdef MSDOS */ |
{ |
/* static double tflin[N]; */ |
a[ii-1+(i-1)*n] = 0.0; |
/* #endif */ |
} |
|
|
|
a[i-1+(i-1)*n] = 1.0; |
static double flin(double l, int j) |
|
/* double l; */ |
|
{ |
|
int i; |
|
/* #ifndef MSDOS */ |
|
/* double tflin[N]; */ |
|
/* #endif */ |
|
/* double *tflin; */ /* Be careful to put tflin on a vector n */ |
|
|
|
/* j is used from 0 to n-1 and can be -1 for parabolic search */ |
|
|
|
/* if (j != -1) { /\* linear search *\/ */ |
|
if (j > 0) { /* linear search */ |
|
/* for (i=0; i<n; i++){ */ |
|
for (i=1; i<=n; i++){ |
|
tflin[i] = x[i] + l *v[i][j]; |
|
#ifdef DEBUGPRAX |
|
/* printf(" flin i=%14d t=%14.7f x=%14.7f l=%14.7f v[%d,%d]=%14.7f nf=%14d\n",i+1, tflin[i],x[i],l,i,j,v[i][j],nf); */ |
|
printf(" flin i=%14d t=%14.7f x=%14.7f l=%14.7f v[%d,%d]=%14.7f nf=%14d\n",i, tflin[i],x[i],l,i,j,v[i][j],nf); |
|
#endif |
|
} |
|
} |
|
else { /* search along parabolic space curve */ |
|
qa = l*(l-qd1)/(qd0*(qd0+qd1)); |
|
qb = (l+qd0)*(qd1-l)/(qd0*qd1); |
|
qc = l*(l+qd0)/(qd1*(qd0+qd1)); |
|
#ifdef DEBUGPRAX |
|
printf(" search along a parabolic space curve. j=%14d nf=%14d l=%14.7f qd0=%14.7f qd1=%14.7f\n",j,nf,l,qd0,qd1); |
|
#endif |
|
/* for (i=0; i<n; i++){ */ |
|
for (i=1; i<=n; i++){ |
|
tflin[i] = qa*q0[i]+qb*x[i]+qc*q1[i]; |
|
#ifdef DEBUGPRAX |
|
/* printf(" parabole i=%14d t(i)=%14.7f q0=%14.7f x=%14.7f q1=%14.7f\n",i+1,tflin[i],q0[i],x[i],q1[i]); */ |
|
printf(" parabole i=%14d t(i)=%14.7e q0=%14.7e x=%14.7e q1=%14.7e\n",i,tflin[i],q0[i],x[i],q1[i]); |
|
#endif |
|
} |
|
} |
|
nf++; |
|
|
g = e[i-1]; |
#ifdef NR_SHIFT |
|
return (*fun)((tflin-1), n); |
|
#else |
|
/* return (*fun)(tflin, n);*/ |
|
return (*fun)(tflin); |
|
#endif |
|
} |
|
|
l = i; |
void minny(int j, int nits, double *d2, double *x1, double f1, int fk) |
} |
/* double *d2, *x1, f1; */ |
|
{ |
|
/* here j is from 0 to n-1 and can be -1 for parabolic search */ |
|
/* MINIMIZES F FROM X IN THE DIRECTION V(*,J) */ |
|
/* UNLESS J<1, WHEN A QUADRATIC SEARCH IS DONE */ |
|
/* IN THE PLANE DEFINED BY Q0, Q1 AND X. */ |
|
/* D2 AN APPROXIMATION TO HALF F'' (OR ZERO), */ |
|
/* X1 AN ESTIMATE OF DISTANCE TO MINIMUM, */ |
|
/* RETURNED AS THE DISTANCE FOUND. */ |
|
/* IF FK = TRUE THEN F1 IS FLIN(X1), OTHERWISE */ |
|
/* X1 AND F1 ARE IGNORED ON ENTRY UNLESS FINAL */ |
|
/* FX > F1. NITS CONTROLS THE NUMBER OF TIMES */ |
|
/* AN ATTEMPT IS MADE TO HALVE THE INTERVAL. */ |
|
/* SIDE EFFECTS: USES AND ALTERS X, FX, NF, NL. */ |
|
/* IF J < 1 USES VARIABLES Q... . */ |
|
/* USES H, N, T, M2, M4, LDT, DMIN, MACHEPS; */ |
|
int k, i, dz; |
|
double x2, xm, f0, f2, fm, d1, t2, sf1, sx1; |
|
double s; |
|
double macheps; |
|
macheps=pow(16.0,-13.0); |
|
sf1 = f1; sx1 = *x1; |
|
k = 0; xm = 0.0; fm = f0 = fx; dz = *d2 < macheps; |
|
/* h=1.0;*/ /* To be revised */ |
|
#ifdef DEBUGPRAX |
|
/* printf("min macheps=%14g h=%14g step=%14g t=%14g fx=%14g\n",macheps,h, step,t, fx); */ |
|
/* Where is fx coming from */ |
|
printf(" min macheps=%14g h=%14g t=%14g fx=%.9lf dirj=%d\n",macheps, h, t, fx, j); |
|
matprint(" min vectors:",v,n,n); |
|
#endif |
|
/* find step size */ |
|
s = 0.; |
|
/* for (i=0; i<n; i++) s += x[i]*x[i]; */ |
|
for (i=1; i<=n; i++) s += x[i]*x[i]; |
|
s = sqrt(s); |
|
if (dz) |
|
t2 = m4*sqrt(fabs(fx)/dmin + s*ldt) + m2*ldt; |
|
else |
|
t2 = m4*sqrt(fabs(fx)/(*d2) + s*ldt) + m2*ldt; |
|
s = s*m4 + t; |
|
if (dz && t2 > s) t2 = s; |
|
if (t2 < small_windows) t2 = small_windows; |
|
if (t2 > 0.01*h) t2 = 0.01 * h; |
|
if (fk && f1 <= fm) { |
|
xm = *x1; |
|
fm = f1; |
|
} |
|
#ifdef DEBUGPRAX |
|
printf(" additional flin X1=%14.7f t2=%14.7f *f1=%14.7f fm=%14.7f fk=%d\n",*x1,t2,f1,fm,fk); |
|
#endif |
|
if (!fk || fabs(*x1) < t2) { |
|
*x1 = (*x1 >= 0 ? t2 : -t2); |
|
/* *x1 = (*x1 > 0 ? t2 : -t2); */ /* kind of error */ |
|
#ifdef DEBUGPRAX |
|
printf(" additional flin X1=%16.10e dirj=%d fk=%d\n",*x1, j, fk); |
|
#endif |
|
f1 = flin(*x1, j); |
|
#ifdef DEBUGPRAX |
|
printf(" after flin f1=%18.12e dirj=%d fk=%d\n",f1, j,fk); |
|
#endif |
|
} |
|
if (f1 <= fm) { |
|
xm = *x1; |
|
fm = f1; |
|
} |
|
L0: /*L0 loop or next */ |
/* |
/* |
Diagonalization of the bidiagonal form. |
Evaluate FLIN at another point and estimate the second derivative. |
*/ |
*/ |
eps = eps * x; |
if (dz) { |
|
x2 = (f0 < f1 ? -(*x1) : 2*(*x1)); |
|
#ifdef DEBUGPRAX |
|
printf(" additional second flin x2=%14.8e x1=%14.8e f0=%14.8e f1=%18.12e dirj=%d\n",x2,*x1,f0,f1,j); |
|
#endif |
|
f2 = flin(x2, j); |
|
#ifdef DEBUGPRAX |
|
printf(" additional second flin x2=%16.10e x1=%16.10e f1=%18.12e f0=%18.10e f2=%18.10e fm=%18.10e\n",x2, *x1, f1,f0,f2,fm); |
|
#endif |
|
if (f2 <= fm) { |
|
xm = x2; |
|
fm = f2; |
|
} |
|
/* d2 is the curvature or double difference f1 doesn't seem to be accurately computed */ |
|
*d2 = (x2*(f1-f0) - (*x1)*(f2-f0))/((*x1)*x2*((*x1)-x2)); |
|
#ifdef DEBUGPRAX |
|
double d11,d12; |
|
d11=(f1-f0)/(*x1);d12=(f2-f0)/x2; |
|
printf(" d11=%18.12e d12=%18.12e d11-d12=%18.12e x1-x2=%18.12e (d11-d12)/(x2-(*x1))=%18.12e\n", d11 ,d12, d11-d12, x2-(*x1), (d11-d12)/(x2-(*x1))); |
|
printf(" original computing f1=%18.12e *d2=%16.10e f0=%18.12e f1-f0=%16.10e f2-f0=%16.10e\n",f1,*d2,f0,f1-f0, f2-f0); |
|
double ff1=7.783920622852e+04; |
|
double f1mf0=9.0344736236e-05; |
|
*d2 = (f1mf0)/ (*x1)/((*x1)-x2) - (f2-f0)/x2/((*x1)-x2); |
|
/* *d2 = (ff1-f0)/ (*x1)/((*x1)-x2) - (f2-f0)/x2/((*x1)-x2); */ |
|
printf(" simpliff computing *d2=%16.10e f1mf0=%18.12e,f1=f0+f1mf0=%18.12e\n",*d2,f1mf0,f0+f1mf0); |
|
*d2 = ((f1-f0)/ (*x1) - (f2-f0)/x2)/((*x1)-x2); |
|
printf(" overlifi computing *d2=%16.10e\n",*d2); |
|
#endif |
|
*d2 = ((f1-f0)/ (*x1) - (f2-f0)/x2)/((*x1)-x2); |
|
} |
|
#ifdef DEBUGPRAX |
|
printf(" additional second flin xm=%14.8e fm=%14.8e *d2=%14.8e\n",xm, fm,*d2); |
|
#endif |
|
/* |
|
Estimate the first derivative at 0. |
|
*/ |
|
d1 = (f1-f0)/(*x1) - *x1**d2; dz = 1; |
|
/* |
|
Predict the minimum. |
|
*/ |
|
if (*d2 <= small_windows) { |
|
x2 = (d1 < 0 ? h : -h); |
|
} |
|
else { |
|
x2 = - 0.5*d1/(*d2); |
|
} |
|
#ifdef DEBUGPRAX |
|
printf(" AT d1=%14.8e d2=%14.8e small=%14.8e dz=%d x1=%14.8e x2=%14.8e\n",d1,*d2,small_windows,dz,*x1,x2); |
|
#endif |
|
if (fabs(x2) > h) |
|
x2 = (x2 > 0 ? h : -h); |
|
L1: /* L1 or try loop */ |
|
#ifdef DEBUGPRAX |
|
printf(" AT predicted minimum flin x2=%14.8e x1=%14.8e K=%14d NITS=%14d dirj=%d\n",x2,*x1,k,nits,j); |
|
#endif |
|
f2 = flin(x2, j); /* x[i]+x2*v[i][j] */ |
|
#ifdef DEBUGPRAX |
|
printf(" after flin f0=%14.8e f1=%14.8e f2=%14.8e fm=%14.8e\n",f0,f1,f2, fm); |
|
#endif |
|
if ((k < nits) && (f2 > f0)) { |
|
#ifdef DEBUGPRAX |
|
printf(" NO SUCCESS SO TRY AGAIN;\n"); |
|
#endif |
|
k++; |
|
if ((f0 < f1) && (*x1*x2 > 0.0)) |
|
goto L0; /* or next */ |
|
x2 *= 0.5; |
|
goto L1; |
|
} |
|
nl++; |
|
#ifdef DEBUGPRAX |
|
printf(" bebeBE end of min x1=%14.8e x2=%14.8e f1=%14.8e f2=%14.8e f0=%14.8e fm=%14.8e d2=%14.8e\n",*x1, x2, f1, f2, f0, fm, *d2); |
|
#endif |
|
if (f2 > fm) x2 = xm; else fm = f2; |
|
if (fabs(x2*(x2-*x1)) > small_windows) { |
|
*d2 = (x2*(f1-f0) - *x1*(fm-f0))/(*x1*x2*(*x1-x2)); |
|
} |
|
else { |
|
if (k > 0) *d2 = 0; |
|
} |
|
#ifdef DEBUGPRAX |
|
printf(" bebe end of min x1=%14.8e fx=%14.8e d2=%14.8e\n",*x1, fx, *d2); |
|
#endif |
|
if (*d2 <= small_windows) *d2 = small_windows; |
|
*x1 = x2; fx = fm; |
|
if (sf1 < fx) { |
|
fx = sf1; |
|
*x1 = sx1; |
|
} |
|
/* |
|
Update X for linear search. |
|
*/ |
|
#ifdef DEBUGPRAX |
|
printf(" end of min x1=%14.8e fx=%14.8e d2=%14.8e\n",*x1, fx, *d2); |
|
#endif |
|
|
|
/* if (j != -1) */ |
|
/* for (i=0; i<n; i++) */ |
|
/* x[i] += (*x1)*v[i][j]; */ |
|
if (j > 0) |
|
for (i=1; i<=n; i++) |
|
x[i] += (*x1)*v[i][j]; |
|
} |
|
|
for ( k = n; 1 <= k; k-- ) |
void quad() /* look for a minimum along the curve q0, q1, q2 */ |
{ |
{ |
kt = 0; |
int i; |
|
double l, s; |
|
|
for ( ; ; ) |
s = fx; fx = qf1; qf1 = s; qd1 = 0.0; |
{ |
/* for (i=0; i<n; i++) { */ |
kt = kt + 1; |
for (i=1; i<=n; i++) { |
|
s = x[i]; l = q1[i]; x[i] = l; q1[i] = s; |
|
qd1 = qd1 + (s-l)*(s-l); |
|
} |
|
s = 0.0; qd1 = sqrt(qd1); l = qd1; |
|
#ifdef DEBUGPRAX |
|
printf(" QUAD after sqrt qd1=%14.8e \n",qd1); |
|
#endif |
|
|
|
if (qd0>0.0 && qd1>0.0 &&nl>=3*n*n) { |
|
#ifdef DEBUGPRAX |
|
printf(" QUAD before min value=%14.8e \n",qf1); |
|
#endif |
|
/* min(-1, 2, &s, &l, qf1, 1); */ |
|
minny(0, 2, &s, &l, qf1, 1); |
|
qa = l*(l-qd1)/(qd0*(qd0+qd1)); |
|
qb = (l+qd0)*(qd1-l)/(qd0*qd1); |
|
qc = l*(l+qd0)/(qd1*(qd0+qd1)); |
|
} |
|
else { |
|
fx = qf1; qa = qb = 0.0; qc = 1.0; |
|
} |
|
#ifdef DEBUGPRAX |
|
printf("after eventual min qd0=%14.8e qd1=%14.8e nl=%d\n",qd0, qd1,nl); |
|
#endif |
|
qd0 = qd1; |
|
/* for (i=0; i<n; i++) { */ |
|
for (i=1; i<=n; i++) { |
|
s = q0[i]; q0[i] = x[i]; |
|
x[i] = qa*s + qb*x[i] + qc*q1[i]; |
|
} |
|
#ifdef DEBUGQUAD |
|
vecprint ( " X after QUAD:" , x, n ); |
|
#endif |
|
} |
|
|
if ( kt_max < kt ) |
/* void minfit(int n, double eps, double tol, double ab[N][N], double q[]) */ |
{ |
void minfit(int n, double eps, double tol, double **ab, double q[]) |
e[k-1] = 0.0; |
/* int n; */ |
fprintf ( stderr, "\n" ); |
/* double eps, tol, ab[N][N], q[N]; */ |
fprintf ( stderr, "MINFIT - Fatal error!\n" ); |
{ |
fprintf ( stderr, " The QR algorithm failed to converge.\n" ); |
int l, kt, l2, i, j, k; |
exit ( 1 ); |
double c, f, g, h, s, x, y, z; |
} |
/* double eps; */ |
|
/* #ifndef MSDOS */ |
|
/* double e[N]; /\* plenty of stack on a vax *\/ */ |
|
/* #endif */ |
|
/* double *e; */ |
|
/* e=vector(0,n-1); /\* should be freed somewhere but gotos *\/ */ |
|
|
|
/* householder's reduction to bidiagonal form */ |
|
|
skip = 0; |
if(n==1){ |
|
/* q[1-1]=ab[1-1][1-1]; */ |
for ( l2 = k; 1 <= l2; l2-- ) |
/* ab[1-1][1-1]=1.0; */ |
{ |
q[1]=ab[1][1]; |
l = l2; |
ab[1][1]=1.0; |
|
return; /* added from hardt */ |
if ( fabs ( e[l-1] ) <= eps ) |
} |
{ |
/* eps=macheps; */ /* added */ |
skip = 1; |
x = g = 0.0; |
break; |
#ifdef DEBUGPRAX |
} |
matprint (" HOUSE holder:", ab, n, n); |
|
#endif |
if ( 1 < l ) |
|
{ |
/* for (i=0; i<n; i++) { /\* FOR I := 1 UNTIL N DO *\/ */ |
if ( fabs ( q[l-2] ) <= eps ) |
for (i=1; i<=n; i++) { /* FOR I := 1 UNTIL N DO */ |
{ |
e[i] = g; s = 0.0; l = i+1; |
break; |
/* for (j=i; j<n; j++) /\* FOR J := I UNTIL N DO S := S*AB(J,I)**2; *\/ /\* not correct *\/ */ |
} |
for (j=i; j<=n; j++) /* FOR J := I UNTIL N DO S := S*AB(J,I)**2; */ /* not correct */ |
} |
s += ab[j][i] * ab[j][i]; |
} |
#ifdef DEBUGPRAXFIN |
/* |
printf("i=%d s=%d %.7g tol=%.7g",i,s,tol); |
Cancellation of E(L) if 1 < L. |
#endif |
*/ |
if (s < tol) { |
if ( ! skip ) |
g = 0.0; |
{ |
} |
c = 0.0; |
else { |
s = 1.0; |
/* f = ab[i][i]; */ |
|
f = ab[i][i]; |
for ( i = l; i <= k; i++ ) |
if (f < 0.0) |
{ |
g = sqrt(s); |
f = s * e[i-1]; |
else |
e[i-1] = c * e[i-1]; |
g = -sqrt(s); |
if ( fabs ( f ) <= eps ) |
/* h = f*g - s; ab[i][i] = f - g; */ |
{ |
h = f*g - s; ab[i][i] = f - g; |
break; |
/* for (j=l; j<n; j++) { */ /* FOR J := L UNTIL N DO */ /* wrong */ |
} |
for (j=l; j<=n; j++) { |
g = q[i-1]; |
f = 0.0; |
/* |
/* for (k=i; k<n; k++) /\* FOR K := I UNTIL N DO *\/ /\* wrong *\/ */ |
q(i) = h = sqrt(g*g + f*f). |
for (k=i; k<=n; k++) /* FOR K := I UNTIL N DO */ |
*/ |
/* f += ab[k][i] * ab[k][j]; */ |
h = r8_hypot ( f, g ); |
f += ab[k][i] * ab[k][j]; |
|
f /= h; |
q[i-1] = h; |
for (k=i; k<=n; k++) /* FOR K := I UNTIL N DO */ |
|
/* for (k=i; k<n; k++)/\* FOR K := I UNTIL N DO *\/ /\* wrong *\/ */ |
if ( h == 0.0 ) |
ab[k][j] += f * ab[k][i]; |
{ |
/* ab[k][j] += f * ab[k][i]; */ |
g = 1.0; |
#ifdef DEBUGPRAX |
h = 1.0; |
printf("Holder J=%d F=%.7g",j,f); |
} |
#endif |
|
} |
c = g / h; |
} /* end s */ |
s = - f / h; |
/* q[i] = g; s = 0.0; */ |
} |
q[i] = g; s = 0.0; |
} |
#ifdef DEBUGPRAX |
/* |
printf(" I Q=%d %.7g",i,q[i]); |
Test for convergence for this index K. |
#endif |
*/ |
|
z = q[k-1]; |
/* if (i < n) */ |
|
/* if (i <= n) /\* I is always lower or equal to n wasn't in golub reinsch*\/ */ |
if ( l == k ) |
/* for (j=l; j<n; j++) */ |
{ |
for (j=l; j<=n; j++) |
if ( z < 0.0 ) |
s += ab[i][j] * ab[i][j]; |
{ |
/* s += ab[i][j] * ab[i][j]; */ |
q[k-1] = - z; |
if (s < tol) { |
for ( i = 1; i <= n; i++ ) |
g = 0.0; |
{ |
} |
a[i-1+(k-1)*n] = - a[i-1+(k-1)*n]; |
else { |
} |
if(i<n) |
} |
/* f = ab[i][i+1]; */ /* Brent golub overflow */ |
break; |
f = ab[i][i+1]; |
} |
if (f < 0.0) |
/* |
g = sqrt(s); |
Shift from bottom 2*2 minor. |
else |
*/ |
g = - sqrt(s); |
x = q[l-1]; |
h = f*g - s; |
y = q[k-2]; |
/* h = f*g - s; ab[i][i+1] = f - g; */ /* Overflow for i=n Error in Golub too but not Burkardt*/ |
g = e[k-2]; |
/* for (j=l; j<n; j++) */ |
h = e[k-1]; |
/* e[j] = ab[i][j]/h; */ |
f = ( ( y - z ) * ( y + z ) + ( g - h ) * ( g + h ) ) / ( 2.0 * h * y ); |
if(i<n){ |
|
ab[i][i+1] = f - g; |
g = r8_hypot ( f, 1.0 ); |
for (j=l; j<=n; j++) |
|
e[j] = ab[i][j]/h; |
if ( f < 0.0 ) |
/* for (j=l; j<n; j++) { */ |
{ |
for (j=l; j<=n; j++) { |
temp = f - g; |
s = 0.0; |
} |
/* for (k=l; k<n; k++) s += ab[j][k]*ab[i][k]; */ |
else |
for (k=l; k<=n; k++) s += ab[j][k]*ab[i][k]; |
{ |
/* for (k=l; k<n; k++) ab[j][k] += s * e[k]; */ |
temp = f + g; |
for (k=l; k<=n; k++) ab[j][k] += s * e[k]; |
} |
} /* END J */ |
|
} /* END i <n */ |
f = ( ( x - z ) * ( x + z ) + h * ( y / temp - h ) ) / x; |
} /* end s */ |
/* |
/* y = fabs(q[i]) + fabs(e[i]); */ |
Next QR transformation. |
y = fabs(q[i]) + fabs(e[i]); |
*/ |
if (y > x) x = y; |
c = 1.0; |
#ifdef DEBUGPRAX |
s = 1.0; |
printf(" I Y=%d %.7g",i,y); |
|
#endif |
for ( i = l + 1; i <= k; i++ ) |
#ifdef DEBUGPRAX |
{ |
printf(" i=%d e(i) %.7g",i,e[i]); |
g = e[i-1]; |
#endif |
y = q[i-1]; |
} /* end i */ |
h = s * g; |
/* |
g = g * c; |
Accumulation of right hand transformations */ |
|
/* for (i=n-1; i >= 0; i--) { */ /* FOR I := N STEP -1 UNTIL 1 DO */ |
z = r8_hypot ( f, h ); |
/* We should avoid the overflow in Golub */ |
|
/* ab[n-1][n-1] = 1.0; */ |
e[i-2] = z; |
/* g = e[n-1]; */ |
|
ab[n][n] = 1.0; |
if ( z == 0.0 ) |
g = e[n]; |
{ |
l = n; |
f = 1.0; |
|
z = 1.0; |
/* for (i=n; i >= 1; i--) { */ |
} |
for (i=n-1; i >= 1; i--) { /* n-1 loops, different from brent and golub*/ |
|
if (g != 0.0) { |
c = f / z; |
/* h = ab[i-1][i]*g; */ |
s = h / z; |
h = ab[i][i+1]*g; |
f = x * c + g * s; |
for (j=l; j<=n; j++) ab[j][i] = ab[i][j] / h; |
g = - x * s + g * c; |
for (j=l; j<=n; j++) { |
h = y * s; |
/* h = ab[i][i+1]*g; */ |
y = y * c; |
/* for (j=l; j<n; j++) ab[j][i] = ab[i][j] / h; */ |
|
/* for (j=l; j<n; j++) { */ |
for ( j = 1; j <= n; j++ ) |
s = 0.0; |
{ |
/* for (k=l; k<n; k++) s += ab[i][k] * ab[k][j]; */ |
x = a[j-1+(i-2)*n]; |
/* for (k=l; k<n; k++) ab[k][j] += s * ab[k][i]; */ |
z = a[j-1+(i-1)*n]; |
for (k=l; k<=n; k++) s += ab[i][k] * ab[k][j]; |
a[j-1+(i-2)*n] = x * c + z * s; |
for (k=l; k<=n; k++) ab[k][j] += s * ab[k][i]; |
a[j-1+(i-1)*n] = - x * s + z * c; |
}/* END J */ |
} |
}/* END G */ |
|
/* for (j=l; j<n; j++) */ |
z = r8_hypot ( f, h ); |
/* ab[i][j] = ab[j][i] = 0.0; */ |
|
/* ab[i][i] = 1.0; g = e[i]; l = i; */ |
q[i-2] = z; |
for (j=l; j<=n; j++) |
|
ab[i][j] = ab[j][i] = 0.0; |
if ( z == 0.0 ) |
ab[i][i] = 1.0; g = e[i]; l = i; |
{ |
}/* END I */ |
f = 1.0; |
#ifdef DEBUGPRAX |
z = 1.0; |
matprint (" HOUSE accumulation:",ab,n, n ); |
} |
#endif |
|
|
c = f / z; |
/* diagonalization to bidiagonal form */ |
s = h / z; |
eps *= x; |
f = c * g + s * y; |
/* for (k=n-1; k>= 0; k--) { */ |
x = - s * g + c * y; |
for (k=n; k>= 1; k--) { |
} |
kt = 0; |
|
TestFsplitting: |
e[l-1] = 0.0; |
#ifdef DEBUGPRAX |
e[k-1] = f; |
printf(" TestFsplitting: k=%d kt=%d\n",k,kt); |
q[k-1] = x; |
/* for(i=1;i<=n;i++)printf(" e(%d)=%.14f",i,e[i]);printf("\n"); */ |
} |
#endif |
} |
kt = kt+1; |
|
/* TestFsplitting: */ |
free ( e ); |
/* if (++kt > 30) { */ |
|
if (kt > 30) { |
return; |
e[k] = 0.0; |
} |
fprintf(stderr, "\n+++ MINFIT - Fatal error\n"); |
/******************************************************************************/ |
fprintf ( stderr, " The QR algorithm failed to converge.\n" ); |
|
} |
void minny ( int n, int jsearch, int nits, double *d2, double *x1, double *f1, |
/* for (l2=k; l2>=0; l2--) { */ |
int fk, double (*func) ( double []), double x[], double t, double h, |
for (l2=k; l2>=1; l2--) { |
double v[], double q0[], double q1[], int *nl, int *nf, double dmin, |
l = l2; |
double ldt, double *fx, double *qa, double *qb, double *qc, double *qd0, |
#ifdef DEBUGPRAX |
double *qd1 ) |
printf(" l e(l)< eps %d %.7g %.7g ",l,e[l], eps); |
/* void minny ( int n, int jsearch, int nits, double *d2, double *x1, double *f1, */ |
#endif |
/* int fk, double f ( double x[], int n ), double x[], double t, double h, */ |
/* if (fabs(e[l]) <= eps) */ |
/* double v[], double q0[], double q1[], int *nl, int *nf, double dmin, */ |
if (fabs(e[l]) <= eps) |
/* double ldt, double *fx, double *qa, double *qb, double *qc, double *qd0, */ |
goto TestFconvergence; |
/* double *qd1 ) */ |
/* if (fabs(q[l-1]) <= eps)*/ /* missing if ( 1 < l ){ *//* printf(" q(l-1)< eps %d %.7g %.7g ",l-1,q[l-2], eps); */ |
|
if (fabs(q[l-1]) <= eps) |
/******************************************************************************/ |
break; /* goto Cancellation; */ |
/* |
} |
Purpose: |
Cancellation: |
|
#ifdef DEBUGPRAX |
MINNY minimizes a scalar function of N variables along a line. |
printf(" Cancellation:\n"); |
|
#endif |
Discussion: |
c = 0.0; s = 1.0; |
|
for (i=l; i<=k; i++) { |
MINNY minimizes F along the line from X in the direction V(*,JSEARCH) |
f = s * e[i]; e[i] *= c; |
or else using a quadratic search in the plane defined by Q0, Q1 and X. |
/* f = s * e[i]; e[i] *= c; */ |
|
if (fabs(f) <= eps) |
If FK = true, then F1 is FLIN(X1). Otherwise X1 and F1 are ignored |
goto TestFconvergence; |
on entry unless final FX is greater than F1. |
/* g = q[i]; */ |
|
g = q[i]; |
Licensing: |
if (fabs(f) < fabs(g)) { |
|
double fg = f/g; |
This code is distributed under the GNU LGPL license. |
h = fabs(g)*sqrt(1.0+fg*fg); |
|
} |
Modified: |
else { |
|
double gf = g/f; |
03 August 2016 |
h = (f!=0.0 ? fabs(f)*sqrt(1.0+gf*gf) : 0.0); |
|
} |
Author: |
/* COMMENT: THE ABOVE REPLACES Q(I):=H:=LONGSQRT(G*G+F*F) */ |
|
/* WHICH MAY GIVE INCORRECT RESULTS IF THE */ |
Original FORTRAN77 version by Richard Brent. |
/* SQUARES UNDERFLOW OR IF F = G = 0; */ |
C version by John Burkardt. |
|
|
/* q[i] = h; */ |
Reference: |
q[i] = h; |
|
if (h == 0.0) { h = 1.0; g = 1.0; } |
Richard Brent, |
c = g/h; s = -f/h; |
Algorithms for Minimization with Derivatives, |
} |
Prentice Hall, 1973, |
TestFconvergence: |
Reprinted by Dover, 2002. |
#ifdef DEBUGPRAX |
|
printf(" TestFconvergence: l=%d k=%d\n",l,k); |
Parameters: |
#endif |
|
/* z = q[k]; */ |
Input, int N, the number of variables. |
z = q[k]; |
|
if (l == k) |
Input, int JSEARCH, indicates the kind of search. |
goto Convergence; |
If J is a legal columnindex, linear search in the direction of V(*,JSEARCH). |
/* shift from bottom 2x2 minor */ |
Otherwise, the search is parabolic, based on X, Q0 and Q1. |
/* x = q[l]; y = q[k-l]; g = e[k-1]; h = e[k]; */ /* Error */ |
|
x = q[l]; y = q[k-1]; g = e[k-1]; h = e[k]; |
Input, int NITS, the maximum number of times the interval |
f = ((y-z)*(y+z) + (g-h)*(g+h)) / (2.0*h*y); |
may be halved to retry the calculation. |
g = sqrt(f*f+1.0); |
|
if (f <= 0.0) |
Input/output, double *D2, is either zero, or an approximation to |
f = ((x-z)*(x+z) + h*(y/(f-g)-h))/x; |
the value of (1/2) times the second derivative of F. |
else |
|
f = ((x-z)*(x+z) + h*(y/(f+g)-h))/x; |
Input/output, double *X1, on entry, an estimate of the |
/* next qr transformation */ |
distance from X to the minimum along V(*,JSEARCH), or a curve. |
s = c = 1.0; |
On output, the distance between X and the minimizer that was found. |
for (i=l+1; i<=k; i++) { |
|
#ifdef DEBUGPRAXQR |
Input/output, double *F1, ? |
printf(" Before Mid TestFconvergence: l+1=%d i=%d k=%d h=%.6e e(i)=%14.8f e(i-1)=%14.8f\n",l+1,i,k, h, e[i],e[i-1]); |
|
#endif |
Input, int FK; if FK is TRUE, then on input F1 contains |
/* g = e[i]; y = q[i]; h = s*g; g *= c; */ |
the value FLIN(X1). |
g = e[i]; y = q[i]; h = s*g; g *= c; |
|
if (fabs(f) < fabs(h)) { |
Input, double F ( double X[], int N ), is the name of the function to |
double fh = f/h; |
be minimized. |
z = fabs(h) * sqrt(1.0 + fh*fh); |
|
} |
Input/output, double X[N], ? |
else { |
|
double hf = h/f; |
Input, double T, ? |
z = (f!=0.0 ? fabs(f)*sqrt(1.0+hf*hf) : 0.0); |
|
} |
Input, double H, ? |
/* e[i-1] = z; */ |
|
e[i-1] = z; |
Input, double V[N,N], a matrix whose columns are direction |
#ifdef DEBUGPRAXQR |
vectors along which the function may be minimized. |
printf(" Mid TestFconvergence: l+1=%d i=%d k=%d h=%.6e e(i)=%14.8f e(i-1)=%14.8f\n",l+1,i,k, h, e[i],e[i-1]); |
|
#endif |
?, double Q0[N], ? |
if (z == 0.0) |
|
f = z = 1.0; |
?, double Q1[N], ? |
c = f/z; s = h/z; |
|
f = x*c + g*s; g = - x*s + g*c; h = y*s; |
Input/output, int *NL, the number of linear searches. |
y *= c; |
|
/* for (j=0; j<n; j++) { */ |
Input/output, int *NF, the number of function evaluations. |
/* x = ab[j][i-1]; z = ab[j][i]; */ |
|
/* ab[j][i-1] = x*c + z*s; */ |
Input, double DMIN, an estimate for the smallest eigenvalue. |
/* ab[j][i] = - x*s + z*c; */ |
|
/* } */ |
Input, double LDT, the length of the step. |
for (j=1; j<=n; j++) { |
|
x = ab[j][i-1]; z = ab[j][i]; |
Input/output, double *FX, the value of F(X,N). |
ab[j][i-1] = x*c + z*s; |
|
ab[j][i] = - x*s + z*c; |
Input/output, double *QA, *QB, *QC; |
} |
|
if (fabs(f) < fabs(h)) { |
Input/output, double *QD0, *QD1, ?. |
double fh = f/h; |
*/ |
z = fabs(h) * sqrt(1.0 + fh*fh); |
{ |
} |
double d1; |
else { |
int dz; |
double hf = h/f; |
double f0; |
z = (f!=0.0 ? fabs(f)*sqrt(1.0+hf*hf) : 0.0); |
double f2; |
} |
double fm; |
#ifdef DEBUGPRAXQR |
int i; |
printf(" qr transformation z f h=%.7g %.7g %.7g i=%d k=%d\n",z,f,h, i, k); |
int k; |
#endif |
double m2; |
q[i-1] = z; |
double m4; |
if (z == 0.0) |
double machep; |
z = f = 1.0; |
int ok; |
c = f/z; s = h/z; |
double s; |
f = c*g + s*y; /* f can be very small */ |
double sf1; |
x = - s*g + c*y; |
double small; |
} |
double sx1; |
/* e[l] = 0.0; e[k] = f; q[k] = x; */ |
double t2; |
e[l] = 0.0; e[k] = f; q[k] = x; |
double temp; |
#ifdef DEBUGPRAXQR |
double x2; |
printf(" aftermid loop l=%d k=%d e(l)=%7g e(k)=%.7g q(k)=%.7g x=%.7g\n",l,k,e[l],e[k],q[k],x); |
double xm; |
#endif |
|
goto TestFsplitting; |
machep = DBL_EPSILON; |
Convergence: |
small = machep * machep; |
#ifdef DEBUGPRAX |
m2 = sqrt ( machep ); |
printf(" Convergence:\n"); |
m4 = sqrt ( m2 ); |
#endif |
sf1 = *f1; |
if (z < 0.0) { |
sx1 = *x1; |
/* q[k] = - z; */ |
k = 0; |
/* for (j=0; j<n; j++) ab[j][k] = - ab[j][k]; */ |
xm = 0.0; |
q[k] = - z; |
fm = *fx; |
for (j=1; j<=n; j++) ab[j][k] = - ab[j][k]; |
f0 = *fx; |
}/* END Z */ |
dz = ( *d2 < machep ); |
}/* END K */ |
/* |
} /* END MINFIT */ |
Find the step size. |
|
*/ |
|
s = r8vec_norm ( n, x ); |
double praxis(double tol, double macheps, double h0, int _n, int _prin, double *_x, double (*_fun)(double *_x)) |
|
/* double praxis(double tol, double macheps, double h0, int _n, int _prin, double *_x, double (*_fun)(double *_x, int _n)) */ |
if ( dz ) |
/* double praxis(double (*_fun)(), double _x[], int _n) */ |
{ |
/* double (*_fun)(); */ |
temp = dmin; |
/* double _x[N]; */ |
} |
/* double (*_fun)(); */ |
else |
/* double _x[N]; */ |
{ |
|
temp = *d2; |
|
} |
|
|
|
t2 = m4 * sqrt ( fabs ( *fx ) / temp + s * ldt ) + m2 * ldt; |
|
s = m4 * s + t; |
|
if ( dz && s < t2 ) |
|
{ |
|
t2 = s; |
|
} |
|
|
|
t2 = fmax ( t2, small ); |
|
t2 = fmin ( t2, 0.01 * h ); |
|
|
|
if ( fk && *f1 <= fm ) |
|
{ |
|
xm = *x1; |
|
fm = *f1; |
|
} |
|
|
|
if ( ( ! fk ) || fabs ( *x1 ) < t2 ) |
|
{ |
|
if ( 0.0 <= *x1 ) |
|
{ |
|
temp = 1.0; |
|
} |
|
else |
|
{ |
|
temp = - 1.0; |
|
} |
|
|
|
*x1 = temp * t2; |
|
*f1 = flin ( n, jsearch, *x1, func, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc ); |
|
/* *f1 = flin ( n, jsearch, *x1, f, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc ); */ |
|
} |
|
|
|
if ( *f1 <= fm ) |
|
{ |
|
xm = *x1; |
|
fm = *f1; |
|
} |
|
/* |
|
Evaluate FLIN at another point and estimate the second derivative. |
|
*/ |
|
for ( ; ; ) |
|
{ |
|
if ( dz ) |
|
{ |
|
if ( *f1 <= f0 ) |
|
{ |
|
x2 = 2.0 * *x1; |
|
} |
|
else |
|
{ |
|
x2 = - *x1; |
|
} |
|
|
|
f2 = flin ( n, jsearch, x2, func, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc ); |
|
/* f2 = flin ( n, jsearch, x2, f, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc ); */ |
|
|
|
if ( f2 <= fm ) |
|
{ |
|
xm = x2; |
|
fm = f2; |
|
} |
|
|
|
*d2 = ( x2 * ( *f1 - f0 ) - *x1 * ( f2 - f0 ) ) |
|
/ ( ( *x1 * x2 ) * ( *x1 - x2 ) ); |
|
} |
|
/* |
|
Estimate the first derivative at 0. |
|
*/ |
|
d1 = ( *f1 - f0 ) / *x1 - *x1 * *d2; |
|
dz = 1; |
|
/* |
|
Predict the minimum. |
|
*/ |
|
if ( *d2 <= small ) |
|
{ |
|
if ( 0.0 <= d1 ) |
|
{ |
|
x2 = - h; |
|
} |
|
else |
|
{ |
|
x2 = h; |
|
} |
|
} |
|
else |
|
{ |
|
x2 = ( - 0.5 * d1 ) / *d2; |
|
} |
|
|
|
if ( h < fabs ( x2 ) ) |
|
{ |
|
if ( x2 <= 0.0 ) |
|
{ |
|
x2 = - h; |
|
} |
|
else |
|
{ |
|
x2 = h; |
|
} |
|
} |
|
/* |
|
Evaluate F at the predicted minimum. |
|
*/ |
|
ok = 1; |
|
|
|
for ( ; ; ) |
|
{ |
|
f2 = flin ( n, jsearch, x2, func, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc ); |
|
/* f2 = flin ( n, jsearch, x2, f, x, nf, v, q0, q1, qd0, qd1, qa, qb, qc ); */ |
|
|
|
if ( nits <= k || f2 <= f0 ) |
|
{ |
|
break; |
|
} |
|
|
|
k = k + 1; |
|
|
|
if ( f0 < *f1 && 0.0 < *x1 * x2 ) |
|
{ |
|
ok = 0; |
|
break; |
|
} |
|
x2 = 0.5 * x2; |
|
} |
|
|
|
if ( ok ) |
|
{ |
|
break; |
|
} |
|
} |
|
/* |
|
Increment the one-dimensional search counter. |
|
*/ |
|
*nl = *nl + 1; |
|
|
|
if ( fm < f2 ) |
|
{ |
|
x2 = xm; |
|
} |
|
else |
|
{ |
|
fm = f2; |
|
} |
|
/* |
|
Get a new estimate of the second derivative. |
|
*/ |
|
if ( small < fabs ( x2 * ( x2 - *x1 ) ) ) |
|
{ |
|
*d2 = ( x2 * ( *f1 - f0 ) - *x1 * ( fm - f0 ) ) |
|
/ ( ( *x1 * x2 ) * ( *x1 - x2 ) ); |
|
} |
|
else |
|
{ |
|
if ( 0 < k ) |
|
{ |
|
*d2 = 0.0; |
|
} |
|
} |
|
|
|
*d2 = fmax ( *d2, small ); |
|
|
|
*x1 = x2; |
|
*fx = fm; |
|
|
|
if ( sf1 < *fx ) |
|
{ |
|
*fx = sf1; |
|
*x1 = sx1; |
|
} |
|
/* |
|
Update X for linear search. |
|
*/ |
|
if ( 0 <= jsearch ) |
|
{ |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
x[i] = x[i] + *x1 * v[i+jsearch*n]; |
|
} |
|
} |
|
|
|
return; |
|
} |
|
/******************************************************************************/ |
|
|
|
/* double praxis ( double t0, double h0, int n, int prin, double x[], */ |
|
/* double f ( double x[], int n ) ) */ |
|
double praxis ( double t0, double h0, int n, int prin, double x[], |
|
double (*func) ( double [] )) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
PRAXIS seeks an N-dimensional minimizer X of a scalar function F(X). |
|
|
|
Discussion: |
|
|
|
PRAXIS returns the minimum of the function F(X,N) of N variables |
|
using the principal axis method. The gradient of the function is |
|
not required. |
|
|
|
The approximating quadratic form is |
|
|
|
Q(x") = F(x,n) + (1/2) * (x"-x)" * A * (x"-x) |
|
|
|
where X is the best estimate of the minimum and |
|
|
|
A = inverse(V") * D * inverse(V) |
|
|
|
V(*,*) is the matrix of search directions; |
|
D(*) is the array of second differences. |
|
|
|
If F(X) has continuous second derivatives near X0, then A will tend |
|
to the hessian of F at X0 as X approaches X0. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
03 August 2016 |
|
|
|
Author: |
|
|
|
Original FORTRAN77 version by Richard Brent. |
|
C version by John Burkardt. |
|
|
|
Reference: |
|
|
|
Richard Brent, |
|
Algorithms for Minimization with Derivatives, |
|
Prentice Hall, 1973, |
|
Reprinted by Dover, 2002. |
|
|
|
Parameters: |
|
|
|
Input, double T0, is a tolerance. PRAXIS attempts to return |
|
praxis = f(x) such that if X0 is the true local minimum near X, then |
|
norm ( x - x0 ) < T0 + sqrt ( EPSILON ) * norm ( X ), |
|
where EPSILON is the machine precision. |
|
|
|
Input, double H0, is the maximum step size. H0 should be |
|
set to about the maximum distance from the initial guess to the minimum. |
|
If H0 is set too large or too small, the initial rate of |
|
convergence may be slow. |
|
|
|
Input, int N, the number of variables. |
|
|
|
Input, int PRIN, controls printing intermediate results. |
|
0, nothing is printed. |
|
1, F is printed after every n+1 or n+2 linear minimizations. |
|
final X is printed, but intermediate X is printed only |
|
if N is at most 4. |
|
2, the scale factors and the principal values of the approximating |
|
quadratic form are also printed. |
|
3, X is also printed after every few linear minimizations. |
|
4, the principal vectors of the approximating quadratic form are |
|
also printed. |
|
|
|
Input/output, double X[N], is an array containing on entry a |
|
guess of the point of minimum, on return the estimated point of minimum. |
|
|
|
Input, double F ( double X[], int N ), is the name of the function to be |
|
minimized. |
|
|
|
Output, double PRAXIS, the function value at the minimizer. |
|
|
|
Local parameters: |
|
|
|
Local, double DMIN, an estimate for the smallest eigenvalue. |
|
|
|
Local, double FX, the value of F(X,N). |
|
|
|
Local, int ILLC, is TRUE if the system is ill-conditioned. |
|
|
|
Local, double LDT, the length of the step. |
|
|
|
Local, int NF, the number of function evaluations. |
|
|
|
Local, int NL, the number of linear searches. |
|
*/ |
|
{ |
|
int biter=0; /* Added to count the loops */ |
|
double *d; |
|
double d2; |
|
double df; |
|
double dmin; |
|
double dn; |
|
double dni; |
|
double f1; |
|
int fk; |
|
double fx; |
|
double h; |
|
int i; |
|
int illc; |
|
int j; |
|
int jsearch; |
|
int k; |
|
int k2; |
|
int kl; |
|
int kt; |
|
int ktm; |
|
double large; |
|
double ldfac; |
|
double lds; |
|
double ldt; |
|
double m2; |
|
double m4; |
|
double machep; |
|
int nits; |
|
int nl; |
|
int nf; |
|
double *q0; |
|
double *q1; |
|
double qa; |
|
double qb; |
|
double qc; |
|
double qd0; |
|
double qd1; |
|
double qf1; |
|
double r; |
|
double s; |
|
double scbd; |
|
int seed; |
|
double sf; |
|
double sl; |
|
double small; |
|
double t; |
|
double temp; |
|
double t2; |
|
double *v; |
|
double value; |
|
double vlarge; |
|
double vsmall; |
|
double *y; |
|
double *z; |
|
/* |
|
Allocation. |
|
*/ |
|
d = ( double * ) malloc ( n * sizeof ( double ) ); |
|
q0 = ( double * ) malloc ( n * sizeof ( double ) ); |
|
q1 = ( double * ) malloc ( n * sizeof ( double ) ); |
|
v = ( double * ) malloc ( n * n * sizeof ( double ) ); |
|
y = ( double * ) malloc ( n * sizeof ( double ) ); |
|
z = ( double * ) malloc ( n * sizeof ( double ) ); |
|
/* |
|
Initialization. |
|
*/ |
|
machep = DBL_EPSILON; |
|
small = machep * machep; |
|
vsmall = small * small; |
|
large = 1.0 / small; |
|
vlarge = 1.0 / vsmall; |
|
m2 = sqrt ( machep ); |
|
m4 = sqrt ( m2 ); |
|
seed = 123456789; |
|
/* |
|
Heuristic numbers: |
|
|
|
If the axes may be badly scaled (which is to be avoided if |
|
possible), then set SCBD = 10. Otherwise set SCBD = 1. |
|
|
|
If the problem is known to be ill-conditioned, initialize ILLC = true. |
|
|
|
KTM is the number of iterations without improvement before the |
|
algorithm terminates. KTM = 4 is very cautious; usually KTM = 1 |
|
is satisfactory. |
|
*/ |
|
scbd = 1.0; |
|
illc = 0; |
|
ktm = 1; |
|
|
|
if ( illc ) |
|
{ |
|
ldfac = 0.1; |
|
} |
|
else |
|
{ |
|
ldfac = 0.01; |
|
} |
|
|
|
kt = 0; |
|
nl = 0; |
|
nf = 1; |
|
/* fx = f ( x, n ); */ |
|
fx = (*func) ( (x-1) );/* This for func which is computed from x[1] and not from x[0] xm1=(x-1)*/ |
|
qf1 = fx; |
|
t = small + fabs ( t0 ); |
|
t2 = t; |
|
dmin = small; |
|
h = h0; |
|
h = fmax ( h, 100.0 * t ); |
|
ldt = h; |
|
/* |
|
The initial set of search directions V is the identity matrix. |
|
*/ |
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
v[i+j*n] = 0.0; |
|
} |
|
v[j+j*n] = 1.0; |
|
} |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
d[i] = 0.0; |
|
} |
|
qa = 0.0; |
|
qb = 0.0; |
|
qc = 0.0; |
|
qd0 = 0.0; |
|
qd1 = 0.0; |
|
r8vec_copy ( n, x, q0 ); |
|
r8vec_copy ( n, x, q1 ); |
|
|
|
if ( 0 < prin ) |
|
{ |
|
print2 ( n, x, prin, fx, nf, nl ); |
|
} |
|
/* |
|
The main loop starts here. |
|
*/ |
|
for ( ; ; ) |
|
{ |
|
biter++; /* Added to count the loops */ |
|
printf("\n Big iteration %d \n",biter); |
|
sf = d[0]; |
|
d[0] = 0.0; |
|
/* |
|
Minimize along the first direction V(*,1). |
|
*/ |
|
jsearch = 0; |
|
nits = 2; |
|
d2 = d[0]; |
|
s = 0.0; |
|
value = fx; |
|
fk = 0; |
|
|
|
minny ( n, jsearch, nits, &d2, &s, &value, fk, func, x, t, |
|
h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); |
|
/* minny ( n, jsearch, nits, &d2, &s, &value, fk, func, x, t, */ |
|
/* h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); */ |
|
|
|
d[0] = d2; |
|
|
|
if ( s <= 0.0 ) |
|
{ |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
v[i+0*n] = - v[i+0*n]; |
|
} |
|
} |
|
|
|
if ( sf <= 0.9 * d[0] || d[0] <= 0.9 * sf ) |
|
{ |
|
for ( i = 1; i < n; i++ ) |
|
{ |
|
d[i] = 0.0; |
|
} |
|
} |
|
/* |
|
The inner loop starts here. |
|
*/ |
|
for ( k = 2; k <= n; k++ ) |
|
{ |
|
r8vec_copy ( n, x, y ); |
|
|
|
sf = fx; |
|
|
|
if ( 0 < kt ) |
|
{ |
|
illc = 1; |
|
} |
|
|
|
for ( ; ; ) |
|
{ |
|
kl = k; |
|
df = 0.0; |
|
/* |
|
A random step follows, to avoid resolution valleys. |
|
*/ |
|
if ( illc ) |
|
{ |
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
r = r8_uniform_01 ( &seed ); |
|
s = ( 0.1 * ldt + t2 * pow ( 10.0, kt ) ) * ( r - 0.5 ); |
|
z[j] = s; |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
x[i] = x[i] + s * v[i+j*n]; |
|
} |
|
} |
|
|
|
fx = (*func) ( (x-1) );/* This for func which is computed from x[1] and not from x[0] xm1=(x-1)*/ |
|
/* fx = f ( x, n ); */ |
|
nf = nf + 1; |
|
} |
|
/* |
|
Minimize along the "non-conjugate" directions V(*,K),...,V(*,N). |
|
*/ |
|
for ( k2 = k; k2 <= n; k2++ ) |
|
{ |
|
sl = fx; |
|
|
|
jsearch = k2 - 1; |
|
nits = 2; |
|
d2 = d[k2-1]; |
|
s = 0.0; |
|
value = fx; |
|
fk = 0; |
|
|
|
minny ( n, jsearch, nits, &d2, &s, &value, fk, func, x, t, |
|
h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); |
|
/* minny ( n, jsearch, nits, &d2, &s, &value, fk, f, x, t, */ |
|
/* h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); */ |
|
|
|
d[k2-1] = d2; |
|
|
|
if ( illc ) |
|
{ |
|
s = d[k2-1] * pow ( s + z[k2-1], 2 ); |
|
} |
|
else |
|
{ |
|
s = sl - fx; |
|
} |
|
|
|
if ( df <= s ) |
|
{ |
|
df = s; |
|
kl = k2; |
|
} |
|
} |
|
/* |
|
If there was not much improvement on the first try, set |
|
ILLC = true and start the inner loop again. |
|
*/ |
|
if ( illc ) |
|
{ |
|
break; |
|
} |
|
printf("\n fabs( 100.0 * machep(=%.12lf) * fx(=%.12lf) ) <=? df(=%.12lf)\n", machep, fx, df); |
|
if ( fabs ( 100.0 * machep * fx ) <= df ) |
|
{ |
|
break; |
|
} |
|
illc = 1; |
|
} |
|
|
|
if ( k == 2 && 1 < prin ) |
|
{ |
|
r8vec_print ( n, d, " The second difference array:" ); |
|
} |
|
/* |
|
Minimize along the "conjugate" directions V(*,1),...,V(*,K-1). |
|
*/ |
|
for ( k2 = 1; k2 < k; k2++ ) |
|
{ |
|
jsearch = k2 - 1; |
|
nits = 2; |
|
d2 = d[k2-1]; |
|
s = 0.0; |
|
value = fx; |
|
fk = 0; |
|
|
|
minny ( n, jsearch, nits, &d2, &s, &value, fk, func, x, t, |
|
h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); |
|
/* minny ( n, jsearch, nits, &d2, &s, &value, fk, f, x, t, */ |
|
/* h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); */ |
|
|
|
d[k2-1] = d2; |
|
} |
|
|
|
f1 = fx; |
|
fx = sf; |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
temp = x[i]; |
|
x[i] = y[i]; |
|
y[i] = temp - y[i]; |
|
} |
|
|
|
lds = r8vec_norm ( n, y ); |
|
/* |
|
Discard direction V(*,kl). |
|
|
|
If no random step was taken, V(*,KL) is the "non-conjugate" |
|
direction along which the greatest improvement was made. |
|
*/ |
|
if ( small < lds ) |
|
{ |
|
for ( j = kl - 1; k <= j; j-- ) |
|
{ |
|
for ( i = 1; i <= n; i++ ) |
|
{ |
|
v[i-1+j*n] = v[i-1+(j-1)*n]; |
|
} |
|
d[j] = d[j-1]; |
|
} |
|
|
|
d[k-1] = 0.0; |
|
|
|
for ( i = 1; i <= n; i++ ) |
|
{ |
|
v[i-1+(k-1)*n] = y[i-1] / lds; |
|
} |
|
/* |
|
Minimize along the new "conjugate" direction V(*,k), which is |
|
the normalized vector: (new x) - (old x). |
|
*/ |
|
jsearch = k - 1; |
|
nits = 4; |
|
d2 = d[k-1]; |
|
value = f1; |
|
fk = 1; |
|
|
|
minny ( n, jsearch, nits, &d2, &lds, &value, fk, func, x, t, |
|
h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); |
|
/* minny ( n, jsearch, nits, &d2, &lds, &value, fk, f, x, t, */ |
|
/* h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qa, &qb, &qc, &qd0, &qd1 ); */ |
|
|
|
d[k-1] = d2; |
|
|
|
if ( lds <= 0.0 ) |
|
{ |
|
lds = - lds; |
|
for ( i = 1; i <= n; i++ ) |
|
{ |
|
v[i-1+(k-1)*n] = - v[i-1+(k-1)*n]; |
|
} |
|
} |
|
} |
|
|
|
ldt = ldfac * ldt; |
|
ldt = fmax ( ldt, lds ); |
|
|
|
if ( 0 < prin ) |
|
{ |
|
printf(" k=%d",k); |
|
print2 ( n, x, prin, fx, nf, nl ); |
|
} |
|
|
|
t2 = r8vec_norm ( n, x ); |
|
|
|
t2 = m2 * t2 + t; |
|
/* |
|
See whether the length of the step taken since starting the |
|
inner loop exceeds half the tolerance. |
|
*/ |
|
if ( 0.5 * t2 < ldt ) |
|
{ |
|
kt = - 1; |
|
} |
|
|
|
kt = kt + 1; |
|
|
|
if ( ktm < kt ) |
|
{ |
|
if ( 0 < prin ) |
|
{ |
|
r8vec_print ( n, x, " X:" ); |
|
} |
|
|
|
free ( d ); |
|
free ( q0 ); |
|
free ( q1 ); |
|
free ( v ); |
|
free ( y ); |
|
free ( z ); |
|
|
|
return fx; |
|
} |
|
} |
|
/* |
|
The inner loop ends here. |
|
|
|
Try quadratic extrapolation in case we are in a curved valley. |
|
*/ |
|
quad ( n, func, x, t, h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qf1, |
|
&qa, &qb, &qc, &qd0, &qd1 ); |
|
/* quad ( n, f, x, t, h, v, q0, q1, &nl, &nf, dmin, ldt, &fx, &qf1, */ |
|
/* &qa, &qb, &qc, &qd0, &qd1 ); */ |
|
|
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
d[j] = 1.0 / sqrt ( d[j] ); |
|
} |
|
|
|
dn = r8vec_max ( n, d ); |
|
|
|
if ( 3 < prin ) |
|
{ |
|
r8mat_print ( n, n, v, " The new direction vectors:" ); |
|
} |
|
|
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
v[i+j*n] = ( d[j] / dn ) * v[i+j*n]; |
|
} |
|
} |
|
/* |
|
Scale the axes to try to reduce the condition number. |
|
*/ |
|
if ( 1.0 < scbd ) |
|
{ |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
s = 0.0; |
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
s = s + v[i+j*n] * v[i+j*n]; |
|
} |
|
s = sqrt ( s ); |
|
z[i] = fmax ( m4, s ); |
|
} |
|
|
|
s = r8vec_min ( n, z ); |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
sl = s / z[i]; |
|
z[i] = 1.0 / sl; |
|
|
|
if ( scbd < z[i] ) |
|
{ |
|
sl = 1.0 / scbd; |
|
z[i] = scbd; |
|
} |
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
v[i+j*n] = sl * v[i+j*n]; |
|
} |
|
} |
|
} |
|
/* |
|
Calculate a new set of orthogonal directions before repeating |
|
the main loop. |
|
|
|
Transpose V for MINFIT: |
|
*/ |
|
printf(" Calculate a new set of orthogonal directions before repeating the main loop.\n Transpose V for MINFIT:...\n"); |
|
r8mat_transpose_in_place ( n, v ); |
|
/* |
|
MINFIT finds the singular value decomposition of V. |
|
|
|
This gives the principal values and principal directions of the |
|
approximating quadratic form without squaring the condition number. |
|
*/ |
|
printf(" MINFIT finds the singular value decomposition of V. \n This gives the principal values and principal directions of the\n approximating quadratic form without squaring the condition number...\n"); |
|
minfit ( n, vsmall, v, d ); |
|
/* |
|
Unscale the axes. |
|
*/ |
|
printf(" Unscale the axes.\n"); |
|
if ( 1.0 < scbd ) |
|
{ |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
v[i+j*n] = z[i] * v[i+j*n]; |
|
} |
|
} |
|
|
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
s = 0.0; |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
s = s + v[i+j*n] * v[i+j*n]; |
|
} |
|
s = sqrt ( s ); |
|
|
|
d[j] = s * d[j]; |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
v[i+j*n] = v[i+j*n] / s; |
|
} |
|
} |
|
} |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
dni = dn * d[i]; |
|
|
|
if ( large < dni ) |
|
{ |
|
d[i] = vsmall; |
|
} |
|
else if ( dni < small ) |
|
{ |
|
d[i] = vlarge; |
|
} |
|
else |
|
{ |
|
d[i] = 1.0 / dni / dni; |
|
} |
|
} |
|
/* |
|
Sort the eigenvalues and eigenvectors. |
|
*/ |
|
printf(" Sort the eigenvalues and eigenvectors....\n"); |
|
svsort ( n, d, v ); |
|
/* |
|
Determine the smallest eigenvalue. |
|
*/ |
|
printf(" Determine the smallest eigenvalue.\n"); |
|
dmin = fmax ( d[n-1], small ); |
|
/* |
|
The ratio of the smallest to largest eigenvalue determines whether |
|
the system is ill conditioned. |
|
*/ |
|
|
|
if ( dmin < m2 * d[0] ) |
|
{ |
|
illc = 1; |
|
} |
|
else |
|
{ |
|
illc = 0; |
|
} |
|
printf(" The ratio of the smallest to largest eigenvalue determines whether\n the system is ill conditioned=%d . dmin=%.12lf < m2=%.12lf * d[0]=%.12lf \n",illc, dmin,m2, d[0]); |
|
|
|
if ( 1 < prin ) |
|
{ |
|
if ( 1.0 < scbd ) |
|
{ |
|
r8vec_print ( n, z, " The scale factors:" ); |
|
} |
|
r8vec_print ( n, d, " Principal values of the quadratic form:" ); |
|
} |
|
|
|
if ( 3 < prin ) |
|
{ |
|
r8mat_print ( n, n, v, " The principal axes:" ); |
|
} |
|
/* |
|
The main loop ends here. |
|
*/ |
|
} |
|
|
|
if ( 0 < prin ) |
|
{ |
|
r8vec_print ( n, x, " X:" ); |
|
} |
|
/* |
|
Free memory. |
|
*/ |
|
free ( d ); |
|
free ( q0 ); |
|
free ( q1 ); |
|
free ( v ); |
|
free ( y ); |
|
free ( z ); |
|
|
|
return fx; |
|
} |
|
/******************************************************************************/ |
|
|
|
void print2 ( int n, double x[], int prin, double fx, int nf, int nl ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
PRINT2 prints certain data about the progress of the iteration. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
28 July 2016 |
|
|
|
Author: |
|
|
|
Original FORTRAN77 version by Richard Brent. |
|
C version by John Burkardt. |
|
|
|
Reference: |
|
|
|
Richard Brent, |
|
Algorithms for Minimization with Derivatives, |
|
Prentice Hall, 1973, |
|
Reprinted by Dover, 2002. |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of variables. |
|
|
|
Input, double X[N], the current estimate of the minimizer. |
|
|
|
Input, int PRIN, the user-specifed print level. |
|
0, nothing is printed. |
|
1, F is printed after every n+1 or n+2 linear minimizations. |
|
final X is printed, but intermediate X is printed only |
|
if N is at most 4. |
|
2, the scale factors and the principal values of the approximating |
|
quadratic form are also printed. |
|
3, X is also printed after every few linear minimizations. |
|
4, the principal vectors of the approximating quadratic form are |
|
also printed. |
|
|
|
Input, double FX, the smallest value of F(X) found so far. |
|
|
|
Input, int NF, the number of function evaluations. |
|
|
|
Input, int NL, the number of linear searches. |
|
*/ |
|
{ |
|
printf ( "\n" ); |
|
printf ( " Linear searches %d", nl ); |
|
/* printf ( " Linear searches %d\n", nl ); */ |
|
/* printf ( " Function evaluations %d\n", nf ); */ |
|
/* printf ( " Function value FX = %g\n", fx ); */ |
|
printf ( " Function evaluations %d", nf ); |
|
printf ( " Function value FX = %.12lf\n", fx ); |
|
|
|
if ( n <= 4 || 2 < prin ) |
|
{ |
|
r8vec_print ( n, x, " X:" ); |
|
} |
|
|
|
return; |
|
} |
|
/******************************************************************************/ |
|
|
|
void quad ( int n, double (*func) ( double [] ), double x[], double t, |
|
double h, double v[], double q0[], double q1[], int *nl, int *nf, double dmin, |
|
double ldt, double *fx, double *qf1, double *qa, double *qb, double *qc, |
|
double *qd0, double *qd1 ) |
|
/* void quad ( int n, double f ( double x[], int n ), double x[], double t, */ |
|
/* double h, double v[], double q0[], double q1[], int *nl, int *nf, double dmin, */ |
|
/* double ldt, double *fx, double *qf1, double *qa, double *qb, double *qc, */ |
|
/* double *qd0, double *qd1 ) */ |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
QUAD seeks to minimize the scalar function F along a particular curve. |
|
|
|
Discussion: |
|
|
|
The minimizer to be sought is required to lie on a curve defined |
|
by Q0, Q1 and X. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
30 July 2016 |
|
|
|
Author: |
|
|
|
Original FORTRAN77 version by Richard Brent. |
|
C version by John Burkardt. |
|
|
|
Reference: |
|
|
|
Richard Brent, |
|
Algorithms for Minimization with Derivatives, |
|
Prentice Hall, 1973, |
|
Reprinted by Dover, 2002. |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of variables. |
|
|
|
Input, double F ( double X[], int N ), the name of the function to |
|
be minimized. |
|
|
|
Input/output, double X[N], ? |
|
|
|
Input, double T, ? |
|
|
|
Input, double H, ? |
|
|
|
Input, double V[N,N], the matrix of search directions. |
|
|
|
Input/output, double Q0[N], Q1[N], two auxiliary points used to define |
|
a curve through X. |
|
|
|
Input/output, int *NL, the number of linear searches. |
|
|
|
Input/output, int *NF, the number of function evaluations. |
|
|
|
Input, double DMIN, an estimate for the smallest eigenvalue. |
|
|
|
Input, double LDT, the length of the step. |
|
|
|
Input/output, double *FX, the value of F(X,N). |
|
|
|
Input/output, double *QF1, *QA, *QB, *QC, *QD0, *QD1 ? |
|
*/ |
|
{ |
|
int fk; |
|
int i; |
|
int jsearch; |
|
double l; |
|
int nits; |
|
double s; |
|
double temp; |
|
double value; |
|
|
|
temp = *fx; |
|
*fx = *qf1; |
|
*qf1 = temp; |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
temp = x[i]; |
|
x[i] = q1[i]; |
|
q1[i] = temp; |
|
} |
|
|
|
*qd1 = 0.0; |
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
*qd1 = *qd1 + ( x[i] - q1[i] ) * ( x[i] - q1[i] ); |
|
} |
|
*qd1 = sqrt ( *qd1 ); |
|
|
|
if ( *qd0 <= 0.0 || *qd1 <= 0.0 || *nl < 3 * n * n ) |
|
{ |
|
*fx = *qf1; |
|
*qa = 0.0; |
|
*qb = 0.0; |
|
*qc = 1.0; |
|
s = 0.0; |
|
} |
|
else |
|
{ |
|
jsearch = - 1; |
|
nits = 2; |
|
s = 0.0; |
|
l = *qd1; |
|
value = *qf1; |
|
fk = 1; |
|
|
|
minny ( n, jsearch, nits, &s, &l, &value, fk, func, x, t, |
|
h, v, q0, q1, nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 ); |
|
/* minny ( n, jsearch, nits, &s, &l, &value, fk, f, x, t, */ |
|
/* h, v, q0, q1, nl, nf, dmin, ldt, fx, qa, qb, qc, qd0, qd1 ); */ |
|
|
|
*qa = l * ( l - *qd1 ) / ( *qd0 + *qd1 ) / *qd0; |
|
*qb = - ( l + *qd0 ) * ( l - *qd1 ) / *qd1 / *qd0; |
|
*qc = ( l + *qd0 ) * l / *qd1 / ( *qd0 + *qd1 ); |
|
} |
|
|
|
*qd0 = *qd1; |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
s = q0[i]; |
|
q0[i] = x[i]; |
|
x[i] = *qa * s + *qb * x[i] + *qc * q1[i]; |
|
} |
|
|
|
return; |
|
} |
|
/******************************************************************************/ |
|
|
|
double r8_hypot ( double x, double y ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8_HYPOT returns the value of sqrt ( X^2 + Y^2 ). |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
26 March 2012 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, double X, Y, the arguments. |
|
|
|
Output, double R8_HYPOT, the value of sqrt ( X^2 + Y^2 ). |
|
*/ |
|
{ |
|
double a; |
|
double b; |
|
double value; |
|
|
|
if ( fabs ( x ) < fabs ( y ) ) |
|
{ |
|
a = fabs ( y ); |
|
b = fabs ( x ); |
|
} |
|
else |
|
{ |
|
a = fabs ( x ); |
|
b = fabs ( y ); |
|
} |
|
/* |
|
A contains the larger value. |
|
*/ |
|
if ( a == 0.0 ) |
|
{ |
|
value = 0.0; |
|
} |
|
else |
|
{ |
|
value = a * sqrt ( 1.0 + ( b / a ) * ( b / a ) ); |
|
} |
|
|
|
return value; |
|
} |
|
/******************************************************************************/ |
|
|
|
double r8_uniform_01 ( int *seed ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8_UNIFORM_01 returns a pseudorandom R8 scaled to [0,1]. |
|
|
|
Discussion: |
|
|
|
This routine implements the recursion |
|
|
|
seed = 16807 * seed mod ( 2^31 - 1 ) |
|
r8_uniform_01 = seed / ( 2^31 - 1 ) |
|
|
|
The integer arithmetic never requires more than 32 bits, |
|
including a sign bit. |
|
|
|
If the initial seed is 12345, then the first three computations are |
|
|
|
Input Output R8_UNIFORM_01 |
|
SEED SEED |
|
|
|
12345 207482415 0.096616 |
|
207482415 1790989824 0.833995 |
|
1790989824 2035175616 0.947702 |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
11 August 2004 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Reference: |
|
|
|
Paul Bratley, Bennett Fox, Linus Schrage, |
|
A Guide to Simulation, |
|
Springer Verlag, pages 201-202, 1983. |
|
|
|
Pierre L'Ecuyer, |
|
Random Number Generation, |
|
in Handbook of Simulation |
|
edited by Jerry Banks, |
|
Wiley Interscience, page 95, 1998. |
|
|
|
Bennett Fox, |
|
Algorithm 647: |
|
Implementation and Relative Efficiency of Quasirandom |
|
Sequence Generators, |
|
ACM Transactions on Mathematical Software, |
|
Volume 12, Number 4, pages 362-376, 1986. |
|
|
|
P A Lewis, A S Goodman, J M Miller, |
|
A Pseudo-Random Number Generator for the System/360, |
|
IBM Systems Journal, |
|
Volume 8, pages 136-143, 1969. |
|
|
|
Parameters: |
|
|
|
Input/output, int *SEED, the "seed" value. Normally, this |
|
value should not be 0. On output, SEED has been updated. |
|
|
|
Output, double R8_UNIFORM_01, a new pseudorandom variate, strictly between |
|
0 and 1. |
|
*/ |
|
{ |
|
const int i4_huge = 2147483647; |
|
int k; |
|
double r; |
|
|
|
if ( *seed == 0 ) |
|
{ |
|
fprintf ( stderr, "\n" ); |
|
fprintf ( stderr, "R8_UNIFORM_01 - Fatal error!\n" ); |
|
fprintf ( stderr, " Input value of SEED = 0\n" ); |
|
exit ( 1 ); |
|
} |
|
|
|
k = *seed / 127773; |
|
|
|
*seed = 16807 * ( *seed - k * 127773 ) - k * 2836; |
|
|
|
if ( *seed < 0 ) |
|
{ |
|
*seed = *seed + i4_huge; |
|
} |
|
|
|
r = ( ( double ) ( *seed ) ) * 4.656612875E-10; |
|
|
|
return r; |
|
} |
|
/******************************************************************************/ |
|
|
|
void r8mat_print ( int m, int n, double a[], char *title ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8MAT_PRINT prints an R8MAT. |
|
|
|
Discussion: |
|
|
|
An R8MAT is a doubly dimensioned array of R8 values, stored as a vector |
|
in column-major order. |
|
|
|
Entry A(I,J) is stored as A[I+J*M] |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
28 May 2008 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int M, the number of rows in A. |
|
|
|
Input, int N, the number of columns in A. |
|
|
|
Input, double A[M*N], the M by N matrix. |
|
|
|
Input, char *TITLE, a title. |
|
*/ |
|
{ |
|
r8mat_print_some ( m, n, a, 1, 1, m, n, title ); |
|
|
|
return; |
|
} |
|
/******************************************************************************/ |
|
|
|
void r8mat_print_some ( int m, int n, double a[], int ilo, int jlo, int ihi, |
|
int jhi, char *title ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8MAT_PRINT_SOME prints some of an R8MAT. |
|
|
|
Discussion: |
|
|
|
An R8MAT is a doubly dimensioned array of R8 values, stored as a vector |
|
in column-major order. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
26 June 2013 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int M, the number of rows of the matrix. |
|
M must be positive. |
|
|
|
Input, int N, the number of columns of the matrix. |
|
N must be positive. |
|
|
|
Input, double A[M*N], the matrix. |
|
|
|
Input, int ILO, JLO, IHI, JHI, designate the first row and |
|
column, and the last row and column to be printed. |
|
|
|
Input, char *TITLE, a title. |
|
*/ |
|
{ |
|
# define INCX 5 |
|
|
|
int i; |
|
int i2hi; |
|
int i2lo; |
|
int j; |
|
int j2hi; |
|
int j2lo; |
|
|
|
fprintf ( stdout, "\n" ); |
|
fprintf ( stdout, "%s\n", title ); |
|
|
|
if ( m <= 0 || n <= 0 ) |
|
{ |
|
fprintf ( stdout, "\n" ); |
|
fprintf ( stdout, " (None)\n" ); |
|
return; |
|
} |
|
/* |
|
Print the columns of the matrix, in strips of 5. |
|
*/ |
|
for ( j2lo = jlo; j2lo <= jhi; j2lo = j2lo + INCX ) |
|
{ |
|
j2hi = j2lo + INCX - 1; |
|
if ( n < j2hi ) |
|
{ |
|
j2hi = n; |
|
} |
|
if ( jhi < j2hi ) |
|
{ |
|
j2hi = jhi; |
|
} |
|
|
|
fprintf ( stdout, "\n" ); |
|
/* |
|
For each column J in the current range... |
|
|
|
Write the header. |
|
*/ |
|
fprintf ( stdout, " Col: "); |
|
for ( j = j2lo; j <= j2hi; j++ ) |
|
{ |
|
fprintf ( stdout, " %7d ", j - 1 ); |
|
} |
|
fprintf ( stdout, "\n" ); |
|
fprintf ( stdout, " Row\n" ); |
|
fprintf ( stdout, "\n" ); |
|
/* |
|
Determine the range of the rows in this strip. |
|
*/ |
|
if ( 1 < ilo ) |
|
{ |
|
i2lo = ilo; |
|
} |
|
else |
|
{ |
|
i2lo = 1; |
|
} |
|
if ( m < ihi ) |
|
{ |
|
i2hi = m; |
|
} |
|
else |
|
{ |
|
i2hi = ihi; |
|
} |
|
|
|
for ( i = i2lo; i <= i2hi; i++ ) |
|
{ |
|
/* |
|
Print out (up to) 5 entries in row I, that lie in the current strip. |
|
*/ |
|
fprintf ( stdout, "%5d:", i - 1 ); |
|
for ( j = j2lo; j <= j2hi; j++ ) |
|
{ |
|
fprintf ( stdout, " %14g", a[i-1+(j-1)*m] ); |
|
} |
|
fprintf ( stdout, "\n" ); |
|
} |
|
} |
|
|
|
return; |
|
# undef INCX |
|
} |
|
/******************************************************************************/ |
|
|
|
void r8mat_transpose_in_place ( int n, double a[] ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8MAT_TRANSPOSE_IN_PLACE transposes a square matrix in place. |
|
|
|
Discussion: |
|
|
|
An R8MAT is a doubly dimensioned array of R8 values, stored as a vector |
|
in column-major order. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
26 June 2008 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of rows and columns of the matrix A. |
|
|
|
Input/output, double A[N*N], the matrix to be transposed. |
|
*/ |
|
{ |
|
int i; |
|
int j; |
|
double t; |
|
|
|
for ( j = 0; j < n; j++ ) |
|
{ |
|
for ( i = 0; i < j; i++ ) |
|
{ |
|
t = a[i+j*n]; |
|
a[i+j*n] = a[j+i*n]; |
|
a[j+i*n] = t; |
|
} |
|
} |
|
return; |
|
} |
|
/******************************************************************************/ |
|
|
|
void r8vec_copy ( int n, double a1[], double a2[] ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8VEC_COPY copies an R8VEC. |
|
|
|
Discussion: |
|
|
|
An R8VEC is a vector of R8's. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
03 July 2005 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of entries in the vectors. |
|
|
|
Input, double A1[N], the vector to be copied. |
|
|
|
Input, double A2[N], the copy of A1. |
|
*/ |
|
{ |
|
int i; |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
a2[i] = a1[i]; |
|
} |
|
return; |
|
} |
|
/******************************************************************************/ |
|
|
|
double r8vec_max ( int n, double r8vec[] ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8VEC_MAX returns the value of the maximum element in a R8VEC. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
05 May 2006 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of entries in the array. |
|
|
|
Input, double R8VEC[N], a pointer to the first entry of the array. |
|
|
|
Output, double R8VEC_MAX, the value of the maximum element. This |
|
is set to 0.0 if N <= 0. |
|
*/ |
|
{ |
|
int i; |
|
double value; |
|
|
|
if ( n <= 0 ) |
|
{ |
|
value = 0.0; |
|
return value; |
|
} |
|
|
|
value = r8vec[0]; |
|
|
|
for ( i = 1; i < n; i++ ) |
|
{ |
|
if ( value < r8vec[i] ) |
|
{ |
|
value = r8vec[i]; |
|
} |
|
} |
|
return value; |
|
} |
|
/******************************************************************************/ |
|
|
|
double r8vec_min ( int n, double r8vec[] ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8VEC_MIN returns the value of the minimum element in a R8VEC. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
05 May 2006 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of entries in the array. |
|
|
|
Input, double R8VEC[N], the array to be checked. |
|
|
|
Output, double R8VEC_MIN, the value of the minimum element. |
|
*/ |
|
{ |
|
int i; |
|
double value; |
|
|
|
value = r8vec[0]; |
|
|
|
for ( i = 1; i < n; i++ ) |
|
{ |
|
if ( r8vec[i] < value ) |
|
{ |
|
value = r8vec[i]; |
|
} |
|
} |
|
return value; |
|
} |
|
/******************************************************************************/ |
|
|
|
double r8vec_norm ( int n, double a[] ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8VEC_NORM returns the L2 norm of an R8VEC. |
|
|
|
Discussion: |
|
|
|
The vector L2 norm is defined as: |
|
|
|
R8VEC_NORM = sqrt ( sum ( 1 <= I <= N ) A(I)^2 ). |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
01 March 2003 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of entries in A. |
|
|
|
Input, double A[N], the vector whose L2 norm is desired. |
|
|
|
Output, double R8VEC_NORM, the L2 norm of A. |
|
*/ |
|
{ |
|
int i; |
|
double v; |
|
|
|
v = 0.0; |
|
|
|
for ( i = 0; i < n; i++ ) |
|
{ |
|
v = v + a[i] * a[i]; |
|
} |
|
v = sqrt ( v ); |
|
|
|
return v; |
|
} |
|
/******************************************************************************/ |
|
|
|
void r8vec_print ( int n, double a[], char *title ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
R8VEC_PRINT prints an R8VEC. |
|
|
|
Discussion: |
|
|
|
An R8VEC is a vector of R8's. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
08 April 2009 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
Input, int N, the number of components of the vector. |
|
|
|
Input, double A[N], the vector to be printed. |
|
|
|
Input, char *TITLE, a title. |
|
*/ |
|
{ |
{ |
int i,j, jk, k; |
/* init global extern variables and parameters */ |
|
/* double *d, *y, *z, */ |
|
/* *q0, *q1, **v; */ |
|
/* double *tflin; /\* used in flin: return (*fun)(tflin, n); *\/ */ |
|
/* double *e; /\* used in minfit, don't konw how to free memory and thus made global *\/ */ |
|
|
double *p; |
|
|
int seed; /* added */ |
|
int biter=0; |
|
double r; |
|
double randbrent( int (*)); |
|
double s, sf; |
|
|
|
h = h0; /* step; */ |
|
t = tol; |
|
scbd = 1.0; |
|
illc = 0; |
|
ktm = 1; |
|
|
|
macheps = DBL_EPSILON; |
|
/* prin=4; */ |
|
#ifdef DEBUGPRAX |
|
printf("Praxis macheps=%14g h=%14g step=%14g tol=%14g\n",macheps,h, h0,tol); |
|
#endif |
|
n = _n; |
|
x = _x; |
|
prin = _prin; |
|
fun = _fun; |
|
d=vector(1, n); |
|
y=vector(1, n); |
|
z=vector(1, n); |
|
q0=vector(1, n); |
|
q1=vector(1, n); |
|
e=vector(1, n); |
|
tflin=vector(1, n); |
|
v=matrix(1, n, 1, n); |
|
for(i=1;i<=n;i++){d[i]=y[i]=z[i]=q0[0]=e[i]=tflin[i]=0.;} |
|
small_windows = (macheps) * (macheps); vsmall = small_windows*small_windows; |
|
large = 1.0/small_windows; vlarge = 1.0/vsmall; |
|
m2 = sqrt(macheps); m4 = sqrt(m2); |
|
seed = 123456789; /* added */ |
|
ldfac = (illc ? 0.1 : 0.01); |
|
for(i=1;i<=n;i++) z[i]=0.; /* Was missing in Gegenfurtner as well as Brent's algol or fortran */ |
|
nl = kt = 0; nf = 1; |
|
#ifdef NR_SHIFT |
|
fx = (*fun)((x-1), n); |
|
#else |
|
fx = (*fun)(x); |
|
#endif |
|
qf1 = fx; |
|
t2 = small_windows + fabs(t); t = t2; dmin = small_windows; |
|
#ifdef DEBUGPRAX |
|
printf("praxis2 macheps=%14g h=%14g step=%14g small=%14g t=%14g\n",macheps,h, h0,small_windows, t); |
|
#endif |
|
if (h < 100.0*t) h = 100.0*t; |
|
#ifdef DEBUGPRAX |
|
printf("praxis3 macheps=%14g h=%14g step=%14g small=%14g t=%14g\n",macheps,h, h0,small_windows, t); |
|
#endif |
|
ldt = h; |
|
/* for (i=0; i<n; i++) for (j=0; j<n; j++) */ |
|
for (i=1; i<=n; i++) for (j=1; j<=n; j++) |
|
v[i][j] = (i == j ? 1.0 : 0.0); |
|
d[1] = 0.0; qd0 = 0.0; |
|
/* for (i=0; i<n; i++) q1[i] = x[i]; */ |
|
for (i=1; i<=n; i++) q1[i] = x[i]; |
|
if (prin > 1) { |
|
printf("\n------------- enter function praxis -----------\n"); |
|
printf("... current parameter settings ...\n"); |
|
printf("... scaling ... %20.10e\n", scbd); |
|
printf("... tol ... %20.10e\n", t); |
|
printf("... maxstep ... %20.10e\n", h); |
|
printf("... illc ... %20u\n", illc); |
|
printf("... ktm ... %20u\n", ktm); |
|
printf("... maxfun ... %20u\n", maxfun); |
|
} |
|
if (prin) print2(); |
|
|
p=(a-1); /* So that a[0]=p[1] */ |
mloop: |
/* for (i=1;i<=n;i++) { */ |
biter++; /* Added to count the loops */ |
/* fprintf(ficrespow," %.12lf", p[i]); */ |
/* sf = d[0]; */ |
/* } */ |
/* s = d[0] = 0.0; */ |
/* fprintf(ficrespow,"\n");fflush(ficrespow); */ |
printf("\n Big iteration %d \n",biter); |
printf("\n#model= 1 + age "); |
fprintf(ficlog,"\n Big iteration %d \n",biter); |
fprintf(ficlog,"\n#model= 1 + age "); |
sf = d[1]; |
if(nagesqr==1){ |
s = d[1] = 0.0; |
printf(" + age*age "); |
|
fprintf(ficlog," + age*age "); |
/* minimize along first direction V(*,1) */ |
} |
#ifdef DEBUGPRAX |
for(j=1;j <=ncovmodel-2;j++){ |
printf(" Minimize along the first direction V(*,1). illc=%d\n",illc); |
if(Typevar[j]==0) { |
/* fprintf(ficlog," Minimize along the first direction V(*,1).\n"); */ |
printf(" + V%d ",Tvar[j]); |
#endif |
fprintf(ficlog," + V%d ",Tvar[j]); |
#ifdef DEBUGPRAX2 |
}else if(Typevar[j]==1) { |
printf("praxis4 macheps=%14g h=%14g step=%14g small=%14g t=%14g\n",macheps,h, h0,small_windows, t); |
printf(" + V%d*age ",Tvar[j]); |
#endif |
fprintf(ficlog," + V%d*age ",Tvar[j]); |
/* min(0, 2, &d[0], &s, fx, 0); /\* mac heps not global *\/ */ |
}else if(Typevar[j]==2) { |
minny(1, 2, &d[1], &s, fx, 0); /* mac heps not global */ |
printf(" + V%d*V%d ",Tvard[Tposprod[j]][1],Tvard[Tposprod[j]][2]); |
#ifdef DEBUGPRAX |
fprintf(ficlog," + V%d*V%d ",Tvard[Tposprod[j]][1],Tvard[Tposprod[j]][2]); |
printf("praxis5 macheps=%14g h=%14g looks at sign of s=%14g fx=%14g\n",macheps,h, s,fx); |
}else if(Typevar[j]==3) { |
#endif |
printf(" + V%d*V%d*age ",Tvard[Tposprod[j]][1],Tvard[Tposprod[j]][2]); |
if (s <= 0.0) |
fprintf(ficlog," + V%d*V%d*age ",Tvard[Tposprod[j]][1],Tvard[Tposprod[j]][2]); |
/* for (i=0; i < n; i++) */ |
} |
for (i=1; i <= n; i++) |
} |
v[i][1] = -v[i][1]; |
printf("\n"); |
/* if ((sf <= (0.9 * d[0])) || ((0.9 * sf) >= d[0])) */ |
/* printf("12 47.0114589 0.0154322 33.2424412 0.3279905 2.3731903 */ |
if ((sf <= (0.9 * d[1])) || ((0.9 * sf) >= d[1])) |
/* 13 -21.5392400 0.1118147 1.2680506 1.2973408 -1.0663662 */ |
/* for (i=1; i<n; i++) */ |
fprintf(ficlog,"\n"); |
for (i=2; i<=n; i++) |
for(i=1,jk=1; i <=nlstate; i++){ |
d[i] = 0.0; |
for(k=1; k <=(nlstate+ndeath); k++){ |
/* for (k=1; k<n; k++) { */ |
if (k != i) { |
for (k=2; k<=n; k++) { |
printf("%d%d ",i,k); |
/* |
fprintf(ficlog,"%d%d ",i,k); |
The inner loop starts here. |
for(j=1; j <=ncovmodel; j++){ |
*/ |
printf("%12.7f ",p[jk]); |
#ifdef DEBUGPRAX |
fprintf(ficlog,"%12.7f ",p[jk]); |
printf(" The inner loop here from k=%d to n=%d.\n",k,n); |
jk++; |
/* fprintf(ficlog," The inner loop here from k=%d to n=%d.\n",k,n); */ |
} |
#endif |
printf("\n"); |
/* for (i=0; i<n; i++) */ |
fprintf(ficlog,"\n"); |
for (i=1; i<=n; i++) |
|
y[i] = x[i]; |
|
sf = fx; |
|
#ifdef DEBUGPRAX |
|
printf(" illc=%d and kt=%d and ktm=%d\n", illc, kt, ktm); |
|
#endif |
|
illc = illc || (kt > 0); |
|
next: |
|
kl = k; |
|
df = 0.0; |
|
if (illc) { /* random step to get off resolution valley */ |
|
#ifdef DEBUGPRAX |
|
printf(" A random step follows, to avoid resolution valleys.\n"); |
|
matprint(" before rand, vectors:",v,n,n); |
|
#endif |
|
for (i=1; i<=n; i++) { |
|
#ifdef NOBRENTRAND |
|
r = drandom(); |
|
#else |
|
seed=i; |
|
/* seed=i+1; */ |
|
#ifdef DEBUGRAND |
|
printf(" Random seed=%d, brent i=%d",seed,i); /* YYYY i=5 j=1 vji= -0.0001170073 */ |
|
#endif |
|
r = randbrent ( &seed ); |
|
#endif |
|
#ifdef DEBUGRAND |
|
printf(" Random r=%.7g \n",r); |
|
#endif |
|
z[i] = (0.1 * ldt + t2 * pow(10.0,(double)kt)) * (r - 0.5); |
|
/* z[i] = (0.1 * ldt + t2 * pow(10.0,(double)kt)) * (drandom() - 0.5); */ |
|
|
|
s = z[i]; |
|
for (j=1; j <= n; j++) |
|
x[j] += s * v[j][i]; |
|
} |
|
#ifdef DEBUGRAND |
|
matprint(" after rand, vectors:",v,n,n); |
|
#endif |
|
#ifdef NR_SHIFT |
|
fx = (*fun)((x-1), n); |
|
#else |
|
fx = (*fun)(x, n); |
|
#endif |
|
/* fx = (*func) ( (x-1) ); *//* This for func which is computed from x[1] and not from x[0] xm1=(x-1)*/ |
|
nf++; |
|
} |
|
/* minimize along non-conjugate directions */ |
|
#ifdef DEBUGPRAX |
|
printf(" Minimize along the 'non-conjugate' directions (dots printed) V(*,%d),...,V(*,%d).\n",k,n); |
|
/* fprintf(ficlog," Minimize along the 'non-conjugate' directions (dots printed) V(*,%d),...,V(*,%d).\n",k,n); */ |
|
#endif |
|
/* for (k2=k; k2<n; k2++) { /\* Be careful here k2 <=n ? *\/ */ |
|
for (k2=k; k2<=n; k2++) { /* Be careful here k2 <=n ? */ |
|
sl = fx; |
|
s = 0.0; |
|
#ifdef DEBUGPRAX |
|
printf(" Minimize along the 'NON-CONJUGATE' true direction k2=%14d fx=%14.7f\n",k2, fx); |
|
matprint(" before min vectors:",v,n,n); |
|
#endif |
|
/* min(k2, 2, &d[k2], &s, fx, 0); */ |
|
/* jsearch=k2-1; */ |
|
/* min(jsearch, 2, &d[jsearch], &s, fx, 0); */ |
|
minny(k2, 2, &d[k2], &s, fx, 0); |
|
#ifdef DEBUGPRAX |
|
printf(" . D(%d)=%14.7f d[k2]=%14.7f z[k2]=%14.7f illc=%14d fx=%14.7f\n",k2,d[k2],d[k2],z[k2],illc,fx); |
|
#endif |
|
if (illc) { |
|
/* double szk = s + z[k2]; */ |
|
/* s = d[k2] * szk*szk; */ |
|
double szk = s + z[k2]; |
|
s = d[k2] * szk*szk; |
|
} |
|
else |
|
s = sl - fx; |
|
/* if (df < s) { */ |
|
if (df <= s) { |
|
df = s; |
|
kl = k2; |
|
#ifdef DEBUGPRAX |
|
printf(" df=%.7g and choose kl=%d \n",df,kl); /* UUUU */ |
|
#endif |
|
} |
|
} /* end loop k2 */ |
|
/* |
|
If there was not much improvement on the first try, set |
|
ILLC = true and start the inner loop again. |
|
*/ |
|
#ifdef DEBUGPRAX |
|
printf(" If there was not much improvement on the first try, set ILLC = true and start the inner loop again. illc=%d\n",illc); |
|
/* fprintf(ficlog," If there was not much improvement on the first try, set ILLC = true and start the inner loop again.\n"); */ |
|
#endif |
|
if (!illc && (df < fabs(100.0 * (macheps) * fx))) { |
|
#ifdef DEBUGPRAX |
|
printf("\n NO SUCCESS because DF is small, starts inner loop with same K(=%d), fabs( 100.0 * machep(=%.10e) * fx(=%.9e) )=%.9e > df(=%.9e) break illc=%d\n", k, macheps, fx, fabs ( 100.0 * macheps * fx ), df, illc); |
|
#endif |
|
illc = 1; |
|
goto next; |
} |
} |
|
#ifdef DEBUGPRAX |
|
printf("\n SUCCESS, BREAKS inner loop K(=%d) because DF is big, fabs( 100.0 * machep(=%.10e) * fx(=%.9e) )=%.9e <= df(=%.9e) break illc=%d\n", k, macheps, fx, fabs ( 100.0 * macheps * fx ), df, illc); |
|
#endif |
|
|
|
/* if ((k == 1) && (prin > 1)){ /\* be careful k=2 *\/ */ |
|
if ((k == 2) && (prin > 1)){ /* be careful k=2 */ |
|
#ifdef DEBUGPRAX |
|
printf(" NEW D The second difference array d:\n" ); |
|
/* fprintf(ficlog, " NEW D The second difference array d:\n" ); */ |
|
#endif |
|
vecprint(" NEW D The second difference array d:",d,n); |
|
} |
|
/* minimize along conjugate directions */ |
|
/* |
|
Minimize along the "conjugate" directions V(*,1),...,V(*,K-1). |
|
*/ |
|
#ifdef DEBUGPRAX |
|
printf("Minimize along the 'conjugate' directions V(*,1),...,V(*,K-1=%d).\n",k-1); |
|
/* fprintf(ficlog,"Minimize along the 'conjugate' directions V(*,1),...,V(*,K-1=%d).\n",k-1); */ |
|
#endif |
|
/* for (k2=0; k2<=k-1; k2++) { */ |
|
for (k2=1; k2<=k-1; k2++) { |
|
s = 0.0; |
|
/* min(k2-1, 2, &d[k2-1], &s, fx, 0); */ |
|
minny(k2, 2, &d[k2], &s, fx, 0); |
|
} |
|
f1 = fx; |
|
fx = sf; |
|
lds = 0.0; |
|
/* for (i=0; i<n; i++) { */ |
|
for (i=1; i<=n; i++) { |
|
sl = x[i]; |
|
x[i] = y[i]; |
|
y[i] = sl - y[i]; |
|
sl = y[i]; |
|
lds = lds + sl*sl; |
|
} |
|
lds = sqrt(lds); |
|
#ifdef DEBUGPRAX |
|
printf("Minimization done 'conjugate', shifted all points, computed lds=%.8f\n",lds); |
|
#endif |
|
/* |
|
Discard direction V(*,kl). |
|
|
|
If no random step was taken, V(*,KL) is the "non-conjugate" |
|
direction along which the greatest improvement was made. |
|
*/ |
|
if (lds > small_windows) { |
|
#ifdef DEBUGPRAX |
|
printf("lds big enough to throw direction V(*,kl=%d). If no random step was taken, V(*,KL) is the 'non-conjugate' direction along which the greatest improvement was made.\n",kl); |
|
matprint(" before shift new conjugate vectors:",v,n,n); |
|
#endif |
|
for (i=kl-1; i>=k; i--) { |
|
/* for (j=0; j < n; j++) */ |
|
for (j=1; j <= n; j++) |
|
/* v[j][i+1] = v[j][i]; */ /* This is v[j][i+1]=v[j][i] i=kl-1 to k */ |
|
v[j][i+1] = v[j][i]; /* This is v[j][i+1]=v[j][i] i=kl-1 to k */ |
|
/* v[j][i+1] = v[j][i]; */ |
|
/* d[i+1] = d[i];*/ /* last is d[k+1]= d[k] */ |
|
d[i+1] = d[i]; /* last is d[k]= d[k-1] */ |
|
} |
|
#ifdef DEBUGPRAX |
|
matprint(" after shift new conjugate vectors:",v,n,n); |
|
#endif /* d[k] = 0.0; */ |
|
d[k] = 0.0; |
|
for (i=1; i <= n; i++) |
|
v[i][k] = y[i] / lds; |
|
/* v[i][k] = y[i] / lds; */ |
|
#ifdef DEBUGPRAX |
|
printf("Minimize along the new 'conjugate' direction V(*,k=%d), which is the normalized vector: (new x) - (old x). d2=%14.7g lds=%.10f\n",k,d[k],lds); |
|
/* fprintf(ficlog,"Minimize along the new 'conjugate' direction V(*,k=%d), which is the normalized vector: (new x) - (old x).\n",k); */ |
|
matprint(" before min new conjugate vectors:",v,n,n); |
|
#endif |
|
/* min(k-1, 4, &d[k-1], &lds, f1, 1); */ |
|
minny(k, 4, &d[k], &lds, f1, 1); |
|
#ifdef DEBUGPRAX |
|
printf(" after min d(k)=%d %.7g lds=%14f\n",k,d[k],lds); |
|
matprint(" after min vectors:",v,n,n); |
|
#endif |
|
if (lds <= 0.0) { |
|
lds = -lds; |
|
#ifdef DEBUGPRAX |
|
printf(" lds changed sign lds=%.14f k=%d\n",lds,k); |
|
#endif |
|
/* for (i=0; i<n; i++) */ |
|
/* v[i][k] = -v[i][k]; */ |
|
for (i=1; i<=n; i++) |
|
v[i][k] = -v[i][k]; |
|
} |
|
} |
|
ldt = ldfac * ldt; |
|
if (ldt < lds) |
|
ldt = lds; |
|
if (prin > 0){ |
|
#ifdef DEBUGPRAX |
|
printf(" k=%d",k); |
|
/* fprintf(ficlog," k=%d",k); */ |
|
#endif |
|
print2();/* n, x, prin, fx, nf, nl ); */ |
|
} |
|
t2 = 0.0; |
|
/* for (i=0; i<n; i++) */ |
|
for (i=1; i<=n; i++) |
|
t2 += x[i]*x[i]; |
|
t2 = m2 * sqrt(t2) + t; |
|
/* |
|
See whether the length of the step taken since starting the |
|
inner loop exceeds half the tolerance. |
|
*/ |
|
#ifdef DEBUGPRAX |
|
printf("See if step length exceeds half the tolerance.\n"); /* ZZZZZ */ |
|
/* fprintf(ficlog,"See if step length exceeds half the tolerance.\n"); */ |
|
#endif |
|
if (ldt > (0.5 * t2)) |
|
kt = 0; |
|
else |
|
kt++; |
|
#ifdef DEBUGPRAX |
|
printf("if kt=%d >? ktm=%d gotoL2 loop\n",kt,ktm); |
|
#endif |
|
if (kt > ktm){ |
|
if ( 0 < prin ){ |
|
/* printf("\nr8vec_print\n X:\n"); */ |
|
/* fprintf(ficlog,"\nr8vec_print\n X:\n"); */ |
|
vecprint ("END X:", x, n ); |
|
} |
|
goto fret; |
|
} |
|
#ifdef DEBUGPRAX |
|
matprint(" end of L2 loop vectors:",v,n,n); |
|
#endif |
|
|
|
} |
|
/* printf("The inner loop ends here.\n"); */ |
|
/* fprintf(ficlog,"The inner loop ends here.\n"); */ |
|
/* |
|
The inner loop ends here. |
|
|
|
Try quadratic extrapolation in case we are in a curved valley. |
|
*/ |
|
#ifdef DEBUGPRAX |
|
printf("Try QUAD ratic extrapolation in case we are in a curved valley.\n"); |
|
#endif |
|
/* try quadratic extrapolation in case */ |
|
/* we are stuck in a curved valley */ |
|
quad(); |
|
dn = 0.0; |
|
/* for (i=0; i<n; i++) { */ |
|
for (i=1; i<=n; i++) { |
|
d[i] = 1.0 / sqrt(d[i]); |
|
if (dn < d[i]) |
|
dn = d[i]; |
|
} |
|
if (prin > 2) |
|
matprint(" NEW DIRECTIONS vectors:",v,n,n); |
|
/* for (j=0; j<n; j++) { */ |
|
for (j=1; j<=n; j++) { |
|
s = d[j] / dn; |
|
/* for (i=0; i < n; i++) */ |
|
for (i=1; i <= n; i++) |
|
v[i][j] *= s; |
|
} |
|
|
|
if (scbd > 1.0) { /* scale axis to reduce condition number */ |
|
#ifdef DEBUGPRAX |
|
printf("Scale the axes to try to reduce the condition number.\n"); |
|
#endif |
|
/* fprintf(ficlog,"Scale the axes to try to reduce the condition number.\n"); */ |
|
s = vlarge; |
|
/* for (i=0; i<n; i++) { */ |
|
for (i=1; i<=n; i++) { |
|
sl = 0.0; |
|
/* for (j=0; j < n; j++) */ |
|
for (j=1; j <= n; j++) |
|
sl += v[i][j]*v[i][j]; |
|
z[i] = sqrt(sl); |
|
if (z[i] < m4) |
|
z[i] = m4; |
|
if (s > z[i]) |
|
s = z[i]; |
|
} |
|
/* for (i=0; i<n; i++) { */ |
|
for (i=1; i<=n; i++) { |
|
sl = s / z[i]; |
|
z[i] = 1.0 / sl; |
|
if (z[i] > scbd) { |
|
sl = 1.0 / scbd; |
|
z[i] = scbd; |
|
} |
} |
} |
} |
} |
/* fprintf ( stdout, "\n" ); */ |
for (i=1; i<=n; i++) |
/* fprintf ( stdout, " %s\n", title ); */ |
/* for (j=0; j<=i-1; j++) { */ |
fprintf ( stdout, " %s", title ); |
/* for (j=1; j<=i; j++) { */ |
/* fprintf ( stdout, "\n" ); */ |
for (j=1; j<=i-1; j++) { |
for ( i = 0; i < n; i++ ) |
s = v[i][j]; |
{ |
v[i][j] = v[j][i]; |
/* fprintf ( stdout, " %8d: %14g", i+1, a[i] ); */ |
v[j][i] = s; |
fprintf ( stdout, " %.12lf", a[i] ); |
} |
} |
#ifdef DEBUGPRAX |
fprintf ( stdout, "\n" ); |
printf(" Calculate a new set of orthogonal directions before repeating the main loop.\n Transpose V for MINFIT:...\n"); |
/* for ( i = 0; i < n; i++ ) */ |
#endif |
/* { */ |
/* |
/* fprintf ( stdout, " %8d: %14g\n", i, a[i] ); */ |
MINFIT finds the singular value decomposition of V. |
/* } */ |
|
|
|
return; |
|
} |
|
/******************************************************************************/ |
|
|
|
void svsort ( int n, double d[], double v[] ) |
|
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
SVSORT descending sorts D and adjusts the corresponding columns of V. |
|
|
|
Discussion: |
|
|
|
A simple bubble sort is used on D. |
|
|
|
In our application, D contains singular values, and the columns of V are |
|
the corresponding right singular vectors. |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
28 July 2016 |
|
|
|
Author: |
|
|
|
Original FORTRAN77 version by Richard Brent. |
|
C version by John Burkardt. |
|
|
|
Reference: |
|
|
|
Richard Brent, |
|
Algorithms for Minimization with Derivatives, |
|
Prentice Hall, 1973, |
|
Reprinted by Dover, 2002. |
|
|
|
Parameters: |
|
|
|
Input, int N, the length of D, and the order of V. |
|
|
|
Input/output, double D[N], the vector to be sorted. |
|
On output, the entries of D are in descending order. |
|
|
|
Input/output, double V[N,N], an N by N array to be adjusted |
This gives the principal values and principal directions of the |
as D is sorted. In particular, if the value that was in D(I) on input is |
approximating quadratic form without squaring the condition number. |
moved to D(J) on output, then the input column V(*,I) is moved to |
*/ |
the output column V(*,J). |
#ifdef DEBUGPRAX |
*/ |
printf(" MINFIT finds the singular value decomposition of V. \n This gives the principal values and principal directions of the\n approximating quadratic form without squaring the condition number...\n"); |
{ |
#endif |
int i; |
|
int j1; |
|
int j2; |
|
int j3; |
|
double t; |
|
|
|
for ( j1 = 0; j1 < n - 1; j1++ ) |
minfit(n, macheps, vsmall, v, d); |
{ |
/* for(i=0; i<n;i++)printf(" %14.7g",d[i]); */ |
/* |
/* v is overwritten with R. */ |
Find J3, the index of the largest entry in D[J1:N-1]. |
/* |
MAXLOC apparently requires its output to be an array. |
Unscale the axes. |
*/ |
*/ |
j3 = j1; |
if (scbd > 1.0) { |
for ( j2 = j1 + 1; j2 < n; j2++ ) |
#ifdef DEBUGPRAX |
{ |
printf(" Unscale the axes.\n"); |
if ( d[j3] < d[j2] ) |
#endif |
{ |
/* for (i=0; i<n; i++) { */ |
j3 = j2; |
for (i=1; i<=n; i++) { |
|
s = z[i]; |
|
/* for (j=0; j<n; j++) */ |
|
for (j=1; j<=n; j++) |
|
v[i][j] *= s; |
} |
} |
} |
/* for (i=0; i<n; i++) { */ |
/* |
for (i=1; i<=n; i++) { |
If J1 != J3, swap D[J1] and D[J3], and columns J1 and J3 of V. |
s = 0.0; |
*/ |
/* for (j=0; j<n; j++) */ |
if ( j1 != j3 ) |
for (j=1; j<=n; j++) |
{ |
s += v[j][i]*v[j][i]; |
t = d[j1]; |
s = sqrt(s); |
d[j1] = d[j3]; |
d[i] *= s; |
d[j3] = t; |
s = 1.0 / s; |
for ( i = 0; i < n; i++ ) |
/* for (j=0; j<n; j++) */ |
{ |
for (j=1; j<=n; j++) |
t = v[i+j1*n]; |
v[j][i] *= s; |
v[i+j1*n] = v[i+j3*n]; |
|
v[i+j3*n] = t; |
|
} |
} |
} |
} |
} |
/* for (i=0; i<n; i++) { */ |
|
double dni; /* added for compatibility with buckhardt but not brent */ |
|
for (i=1; i<=n; i++) { |
|
dni=dn*d[i]; /* added for compatibility with buckhardt but not brent */ |
|
if ((dn * d[i]) > large) |
|
d[i] = vsmall; |
|
else if ((dn * d[i]) < small_windows) |
|
d[i] = vlarge; |
|
else |
|
d[i] = 1.0 / dni / dni; /* added for compatibility with buckhardt but not brent */ |
|
/* d[i] = pow(dn * d[i],-2.0); */ |
|
} |
|
#ifdef DEBUGPRAX |
|
vecprint ("\n Before sort Eigenvalues of a:",d,n ); |
|
#endif |
|
|
|
sort(); /* the new eigenvalues and eigenvectors */ |
|
#ifdef DEBUGPRAX |
|
vecprint( " After sort the eigenvalues ....\n", d, n); |
|
matprint( " After sort the eigenvectors....\n", v, n,n); |
|
#endif |
|
#ifdef DEBUGPRAX |
|
printf(" Determine the smallest eigenvalue.\n"); |
|
#endif |
|
/* dmin = d[n-1]; */ |
|
dmin = d[n]; |
|
if (dmin < small_windows) |
|
dmin = small_windows; |
|
/* |
|
The ratio of the smallest to largest eigenvalue determines whether |
|
the system is ill conditioned. |
|
*/ |
|
|
|
/* illc = (m2 * d[0]) > dmin; */ |
|
illc = (m2 * d[1]) > dmin; |
|
#ifdef DEBUGPRAX |
|
printf(" The ratio of the smallest to largest eigenvalue determines whether\n the system is ill conditioned=%d . dmin=%.10lf < m2=%.10lf * d[1]=%.10lf \n",illc, dmin,m2, d[1]); |
|
#endif |
|
|
|
if ((prin > 2) && (scbd > 1.0)) |
|
vecprint("\n The scale factors:",z,n); |
|
if (prin > 2) |
|
vecprint(" Principal values (EIGEN VALUES OF A) of the quadratic form:",d,n); |
|
if (prin > 2) |
|
matprint(" The principal axes (EIGEN VECTORS OF A:",v,n, n); |
|
|
|
if ((maxfun > 0) && (nf > maxfun)) { |
|
if (prin) |
|
printf("\n... maximum number of function calls reached ...\n"); |
|
goto fret; |
|
} |
|
#ifdef DEBUGPRAX |
|
printf("Goto main loop\n"); |
|
#endif |
|
goto mloop; /* back to main loop */ |
|
|
return; |
fret: |
|
if (prin > 0) { |
|
vecprint("\n X:", x, n); |
|
/* printf("\n... ChiSq reduced to %20.10e ...\n", fx); */ |
|
/* printf("... after %20u function calls.\n", nf); */ |
|
} |
|
free_vector(d, 1, n); |
|
free_vector(y, 1, n); |
|
free_vector(z, 1, n); |
|
free_vector(q0, 1, n); |
|
free_vector(q1, 1, n); |
|
free_matrix(v, 1, n, 1, n); |
|
/* double *d, *y, *z, */ |
|
/* *q0, *q1, **v; */ |
|
free_vector(tflin, 1, n); |
|
/* double *tflin; /\* used in flin: return (*fun)(tflin, n); *\/ */ |
|
free_vector(e, 1, n); |
|
/* double *e; /\* used in minfit, don't konw how to free memory and thus made global *\/ */ |
|
|
|
return(fx); |
} |
} |
/******************************************************************************/ |
|
|
|
void timestamp ( ) |
/* end praxis gegen */ |
|
|
/******************************************************************************/ |
|
/* |
|
Purpose: |
|
|
|
TIMESTAMP prints the current YMDHMS date as a time stamp. |
|
|
|
Example: |
|
|
|
31 May 2001 09:45:54 AM |
|
|
|
Licensing: |
|
|
|
This code is distributed under the GNU LGPL license. |
|
|
|
Modified: |
|
|
|
24 September 2003 |
|
|
|
Author: |
|
|
|
John Burkardt |
|
|
|
Parameters: |
|
|
|
None |
|
*/ |
|
{ |
|
# define TIME_SIZE 40 |
|
|
|
static char time_buffer[TIME_SIZE]; |
|
const struct tm *tm; |
|
time_t now; |
|
|
|
now = time ( NULL ); |
|
tm = localtime ( &now ); |
|
|
|
strftime ( time_buffer, TIME_SIZE, "%d %B %Y %I:%M:%S %p", tm ); |
|
|
|
fprintf ( stdout, "%s\n", time_buffer ); |
|
|
|
return; |
|
# undef TIME_SIZE |
|
} |
|
/* end praxis */ |
|
|
|
/*************** powell ************************/ |
/*************** powell ************************/ |
/* |
/* |
Line 5187 void powell(double p[], double **xi, int
|
Line 4164 void powell(double p[], double **xi, int
|
double fp,fptt; |
double fp,fptt; |
double *xits; |
double *xits; |
int niterf, itmp; |
int niterf, itmp; |
|
int Bigter=0, nBigterf=1; |
|
|
pt=vector(1,n); |
pt=vector(1,n); |
ptt=vector(1,n); |
ptt=vector(1,n); |
xit=vector(1,n); |
xit=vector(1,n); |
Line 5200 void powell(double p[], double **xi, int
|
Line 4178 void powell(double p[], double **xi, int
|
ibig=0; |
ibig=0; |
del=0.0; |
del=0.0; |
rlast_time=rcurr_time; |
rlast_time=rcurr_time; |
|
rlast_btime=rcurr_time; |
/* (void) gettimeofday(&curr_time,&tzp); */ |
/* (void) gettimeofday(&curr_time,&tzp); */ |
rcurr_time = time(NULL); |
rcurr_time = time(NULL); |
curr_time = *localtime(&rcurr_time); |
curr_time = *localtime(&rcurr_time); |
/* printf("\nPowell iter=%d -2*LL=%.12f gain=%.12f=%.3g %ld sec. %ld sec.",*iter,*fret, fp-*fret,fp-*fret, rcurr_time-rlast_time, rcurr_time-rstart_time);fflush(stdout); */ |
/* printf("\nPowell iter=%d -2*LL=%.12f gain=%.12f=%.3g %ld sec. %ld sec.",*iter,*fret, fp-*fret,fp-*fret, rcurr_time-rlast_time, rcurr_time-rstart_time);fflush(stdout); */ |
/* fprintf(ficlog,"\nPowell iter=%d -2*LL=%.12f gain=%.12f=%.3g %ld sec. %ld sec.",*iter,*fret, fp-*fret,fp-*fret,rcurr_time-rlast_time, rcurr_time-rstart_time); fflush(ficlog); */ |
/* fprintf(ficlog,"\nPowell iter=%d -2*LL=%.12f gain=%.12f=%.3g %ld sec. %ld sec.",*iter,*fret, fp-*fret,fp-*fret,rcurr_time-rlast_time, rcurr_time-rstart_time); fflush(ficlog); */ |
printf("\nPowell iter=%d -2*LL=%.12f gain=%.3lg %ld sec. %ld sec.",*iter,*fret,fp-*fret, rcurr_time-rlast_time, rcurr_time-rstart_time);fflush(stdout); |
/* Bigter=(*iter - *iter % ncovmodel)/ncovmodel +1; /\* Big iteration, i.e on ncovmodel cycle *\/ */ |
fprintf(ficlog,"\nPowell iter=%d -2*LL=%.12f gain=%.3lg %ld sec. %ld sec.",*iter,*fret,fp-*fret,rcurr_time-rlast_time, rcurr_time-rstart_time); fflush(ficlog); |
Bigter=(*iter - (*iter-1) % n)/n +1; /* Big iteration, i.e on ncovmodel cycle */ |
/* fprintf(ficrespow,"%d %.12f %ld",*iter,*fret,curr_time.tm_sec-start_time.tm_sec); */ |
printf("\nPowell iter=%d Big Iter=%d -2*LL=%.12f gain=%.3lg %ld sec. %ld sec.",*iter,Bigter,*fret,fp-*fret, rcurr_time-rlast_time, rcurr_time-rstart_time);fflush(stdout); |
|
fprintf(ficlog,"\nPowell iter=%d Big Iter=%d -2*LL=%.12f gain=%.3lg %ld sec. %ld sec.",*iter,Bigter,*fret,fp-*fret,rcurr_time-rlast_time, rcurr_time-rstart_time); fflush(ficlog); |
|
fprintf(ficrespow,"%d %d %.12f %d",*iter,Bigter, *fret,curr_time.tm_sec-start_time.tm_sec); |
fp=(*fret); /* From former iteration or initial value */ |
fp=(*fret); /* From former iteration or initial value */ |
for (i=1;i<=n;i++) { |
for (i=1;i<=n;i++) { |
fprintf(ficrespow," %.12lf", p[i]); |
fprintf(ficrespow," %.12lf", p[i]); |
Line 5262 void powell(double p[], double **xi, int
|
Line 4243 void powell(double p[], double **xi, int
|
strcurr[itmp-1]='\0'; |
strcurr[itmp-1]='\0'; |
printf("\nConsidering the time needed for the last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time); |
printf("\nConsidering the time needed for the last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time); |
fprintf(ficlog,"\nConsidering the time needed for this last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time); |
fprintf(ficlog,"\nConsidering the time needed for this last iteration #%d: %ld seconds,\n",*iter,rcurr_time-rlast_time); |
for(niterf=10;niterf<=30;niterf+=10){ |
for(nBigterf=1;nBigterf<=31;nBigterf+=10){ |
|
niterf=nBigterf*ncovmodel; |
|
/* rforecast_time=rcurr_time+(niterf-*iter)*(rcurr_time-rlast_time); */ |
rforecast_time=rcurr_time+(niterf-*iter)*(rcurr_time-rlast_time); |
rforecast_time=rcurr_time+(niterf-*iter)*(rcurr_time-rlast_time); |
forecast_time = *localtime(&rforecast_time); |
forecast_time = *localtime(&rforecast_time); |
strcpy(strfor,asctime(&forecast_time)); |
strcpy(strfor,asctime(&forecast_time)); |
itmp = strlen(strfor); |
itmp = strlen(strfor); |
if(strfor[itmp-1]=='\n') |
if(strfor[itmp-1]=='\n') |
strfor[itmp-1]='\0'; |
strfor[itmp-1]='\0'; |
printf(" - if your program needs %d iterations to converge, convergence will be \n reached in %s i.e.\n on %s (current time is %s);\n",niterf, asc_diff_time(rforecast_time-rcurr_time,tmpout),strfor,strcurr); |
printf(" - if your program needs %d BIG iterations (%d iterations) to converge, convergence will be \n reached in %s i.e.\n on %s (current time is %s);\n",nBigterf, niterf, asc_diff_time(rforecast_time-rcurr_time,tmpout),strfor,strcurr); |
fprintf(ficlog," - if your program needs %d iterations to converge, convergence will be \n reached in %s i.e.\n on %s (current time is %s);\n",niterf, asc_diff_time(rforecast_time-rcurr_time,tmpout),strfor,strcurr); |
fprintf(ficlog," - if your program needs %d BIG iterations (%d iterations) to converge, convergence will be \n reached in %s i.e.\n on %s (current time is %s);\n",nBigterf, niterf, asc_diff_time(rforecast_time-rcurr_time,tmpout),strfor,strcurr); |
} |
} |
} |
} |
for (i=1;i<=n;i++) { /* For each direction i */ |
for (i=1;i<=n;i++) { /* For each direction i, maximisation after loading directions */ |
for (j=1;j<=n;j++) xit[j]=xi[j][i]; /* Directions stored from previous iteration with previous scales */ |
for (j=1;j<=n;j++) xit[j]=xi[j][i]; /* Directions stored from previous iteration with previous scales. xi is not changed but one dim xit */ |
fptt=(*fret); |
|
|
fptt=(*fret); /* Computes likelihood for parameters xit */ |
#ifdef DEBUG |
#ifdef DEBUG |
printf("fret=%lf, %lf, %lf \n", *fret, *fret, *fret); |
printf("fret=%lf, %lf, %lf \n", *fret, *fret, *fret); |
fprintf(ficlog, "fret=%lf, %lf, %lf \n", *fret, *fret, *fret); |
fprintf(ficlog, "fret=%lf, %lf, %lf \n", *fret, *fret, *fret); |
Line 5283 void powell(double p[], double **xi, int
|
Line 4267 void powell(double p[], double **xi, int
|
printf("%d",i);fflush(stdout); /* print direction (parameter) i */ |
printf("%d",i);fflush(stdout); /* print direction (parameter) i */ |
fprintf(ficlog,"%d",i);fflush(ficlog); |
fprintf(ficlog,"%d",i);fflush(ficlog); |
#ifdef LINMINORIGINAL |
#ifdef LINMINORIGINAL |
linmin(p,xit,n,fret,func); /* Point p[n]. xit[n] has been loaded for direction i as input.*/ |
linmin(p,xit,n,fret,func); /* New point i minimizing in direction xit, i has coordinates p[j].*/ |
|
/* xit[j] gives the n coordinates of direction i as input.*/ |
|
/* *fret gives the maximum value on direction xit */ |
#else |
#else |
linmin(p,xit,n,fret,func,&flat); /* Point p[n]. xit[n] has been loaded for direction i as input.*/ |
linmin(p,xit,n,fret,func,&flat); /* Point p[n]. xit[n] has been loaded for direction i as input.*/ |
flatdir[i]=flat; /* Function is vanishing in that direction i */ |
flatdir[i]=flat; /* Function is vanishing in that direction i */ |
#endif |
#endif |
/* Outputs are fret(new point p) p is updated and xit rescaled */ |
/* Outputs are fret(new point p) p is updated and xit rescaled */ |
if (fabs(fptt-(*fret)) > del) { /* We are keeping the max gain on each of the n directions */ |
if (fabs(fptt-(*fret)) > del) { /* We are keeping the max gain on each of the n directions */ |
/* because that direction will be replaced unless the gain del is small */ |
/* because that direction will be replaced unless the gain del is small */ |
/* in comparison with the 'probable' gain, mu^2, with the last average direction. */ |
/* in comparison with the 'probable' gain, mu^2, with the last average direction. */ |
/* Unless the n directions are conjugate some gain in the determinant may be obtained */ |
/* Unless the n directions are conjugate some gain in the determinant may be obtained */ |
/* with the new direction. */ |
/* with the new direction. */ |
del=fabs(fptt-(*fret)); |
del=fabs(fptt-(*fret)); |
ibig=i; |
ibig=i; |
} |
} |
#ifdef DEBUG |
#ifdef DEBUG |
printf("%d %.12e",i,(*fret)); |
printf("%d %.12e",i,(*fret)); |
fprintf(ficlog,"%d %.12e",i,(*fret)); |
fprintf(ficlog,"%d %.12e",i,(*fret)); |
for (j=1;j<=n;j++) { |
for (j=1;j<=n;j++) { |
xits[j]=FMAX(fabs(p[j]-pt[j]),1.e-5); |
xits[j]=FMAX(fabs(p[j]-pt[j]),1.e-5); |
printf(" x(%d)=%.12e",j,xit[j]); |
printf(" x(%d)=%.12e",j,xit[j]); |
fprintf(ficlog," x(%d)=%.12e",j,xit[j]); |
fprintf(ficlog," x(%d)=%.12e",j,xit[j]); |
} |
} |
for(j=1;j<=n;j++) { |
for(j=1;j<=n;j++) { |
printf(" p(%d)=%.12e",j,p[j]); |
printf(" p(%d)=%.12e",j,p[j]); |
fprintf(ficlog," p(%d)=%.12e",j,p[j]); |
fprintf(ficlog," p(%d)=%.12e",j,p[j]); |
} |
} |
printf("\n"); |
printf("\n"); |
fprintf(ficlog,"\n"); |
fprintf(ficlog,"\n"); |
#endif |
#endif |
} /* end loop on each direction i */ |
} /* end loop on each direction i */ |
/* Convergence test will use last linmin estimation (fret) and compare former iteration (fp) */ |
/* Convergence test will use last linmin estimation (fret) and compare to former iteration (fp) */ |
/* But p and xit have been updated at the end of linmin, *fret corresponds to new p, xit */ |
/* But p and xit have been updated at the end of linmin, *fret corresponds to new p, xit */ |
/* New value of last point Pn is not computed, P(n-1) */ |
/* New value of last point Pn is not computed, P(n-1) */ |
for(j=1;j<=n;j++) { |
for(j=1;j<=n;j++) { |
Line 5368 void powell(double p[], double **xi, int
|
Line 4354 void powell(double p[], double **xi, int
|
return; |
return; |
} /* enough precision */ |
} /* enough precision */ |
if (*iter == ITMAX*n) nrerror("powell exceeding maximum iterations."); |
if (*iter == ITMAX*n) nrerror("powell exceeding maximum iterations."); |
for (j=1;j<=n;j++) { /* Computes the extrapolated point P_0 + 2 (P_n-P_0) */ |
for (j=1;j<=n;j++) { /* Computes the extrapolated point and value f3, P_0 + 2 (P_n-P_0)=2Pn-P0 and xit is direction Pn-P0 */ |
ptt[j]=2.0*p[j]-pt[j]; |
ptt[j]=2.0*p[j]-pt[j]; |
xit[j]=p[j]-pt[j]; |
xit[j]=p[j]-pt[j]; /* Coordinate j of last direction xi_n=P_n-P_0 */ |
pt[j]=p[j]; |
#ifdef DEBUG |
} |
printf("\n %d xit=%12.7g p=%12.7g pt=%12.7g ",j,xit[j],p[j],pt[j]); |
|
#endif |
|
pt[j]=p[j]; /* New P0 is Pn */ |
|
} |
|
#ifdef DEBUG |
|
printf("\n"); |
|
#endif |
fptt=(*func)(ptt); /* f_3 */ |
fptt=(*func)(ptt); /* f_3 */ |
#ifdef NODIRECTIONCHANGEDUNTILNITER /* No change in drections until some iterations are done */ |
#ifdef NODIRECTIONCHANGEDUNTILNITER /* No change in directions until some iterations are done */ |
if (*iter <=4) { |
if (*iter <=4) { |
#else |
#else |
#endif |
#endif |
Line 5393 void powell(double p[], double **xi, int
|
Line 4385 void powell(double p[], double **xi, int
|
/* t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)-del*SQR(fp-fptt); */ |
/* t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)-del*SQR(fp-fptt); */ |
/* Even if f3 <f1, directest can be negative and t >0 */ |
/* Even if f3 <f1, directest can be negative and t >0 */ |
/* mu² and del² are equal when f3=f1 */ |
/* mu² and del² are equal when f3=f1 */ |
/* f3 < f1 : mu² < del <= lambda^2 both test are equivalent */ |
/* f3 < f1 : mu² < del <= lambda^2 both test are equivalent */ |
/* f3 < f1 : mu² < lambda^2 < del then directtest is negative and powell t is positive */ |
/* f3 < f1 : mu² < lambda^2 < del then directtest is negative and powell t is positive */ |
/* f3 > f1 : lambda² < mu^2 < del then t is negative and directest >0 */ |
/* f3 > f1 : lambda² < mu^2 < del then t is negative and directest >0 */ |
/* f3 > f1 : lambda² < del < mu^2 then t is positive and directest >0 */ |
/* f3 > f1 : lambda² < del < mu^2 then t is positive and directest >0 */ |
#ifdef NRCORIGINAL |
#ifdef NRCORIGINAL |
t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)- del*SQR(fp-fptt); /* Original Numerical Recipes in C*/ |
t=2.0*(fp-2.0*(*fret)+fptt)*SQR(fp-(*fret)-del)- del*SQR(fp-fptt); /* Original Numerical Recipes in C*/ |
#else |
#else |
Line 5418 void powell(double p[], double **xi, int
|
Line 4410 void powell(double p[], double **xi, int
|
if (t < 0.0) { /* Then we use it for new direction */ |
if (t < 0.0) { /* Then we use it for new direction */ |
#else |
#else |
if (directest*t < 0.0) { /* Contradiction between both tests */ |
if (directest*t < 0.0) { /* Contradiction between both tests */ |
printf("directest= %.12lf (if <0 we include P0 Pn as new direction), t= %.12lf, f1= %.12lf,f2= %.12lf,f3= %.12lf, del= %.12lf\n",directest, t, fp,(*fret),fptt,del); |
printf("directest= %.12lf (if <0 we include P0 Pn as new direction), t= %.12lf, f1= %.12lf,f2= %.12lf,f3= %.12lf, del= %.12lf\n",directest, t, fp,(*fret),fptt,del); |
printf("f1-2f2+f3= %.12lf, f1-f2-del= %.12lf, f1-f3= %.12lf\n",fp-2.0*(*fret)+fptt, fp -(*fret) -del, fp-fptt); |
printf("f1-2f2+f3= %.12lf, f1-f2-del= %.12lf, f1-f3= %.12lf\n",fp-2.0*(*fret)+fptt, fp -(*fret) -del, fp-fptt); |
fprintf(ficlog,"directest= %.12lf (if directest<0 or t<0 we include P0 Pn as new direction), t= %.12lf, f1= %.12lf,f2= %.12lf,f3= %.12lf, del= %.12lf\n",directest, t, fp,(*fret),fptt, del); |
fprintf(ficlog,"directest= %.12lf (if directest<0 or t<0 we include P0 Pn as new direction), t= %.12lf, f1= %.12lf,f2= %.12lf,f3= %.12lf, del= %.12lf\n",directest, t, fp,(*fret),fptt, del); |
fprintf(ficlog,"f1-2f2+f3= %.12lf, f1-f2-del= %.12lf, f1-f3= %.12lf\n",fp-2.0*(*fret)+fptt, fp -(*fret) -del, fp-fptt); |
fprintf(ficlog,"f1-2f2+f3= %.12lf, f1-f2-del= %.12lf, f1-f3= %.12lf\n",fp-2.0*(*fret)+fptt, fp -(*fret) -del, fp-fptt); |
Line 5497 void powell(double p[], double **xi, int
|
Line 4489 void powell(double p[], double **xi, int
|
fprintf(ficlog,"\n"); |
fprintf(ficlog,"\n"); |
#endif |
#endif |
} /* end of t or directest negative */ |
} /* end of t or directest negative */ |
|
printf(" Directest is positive, P_n-P_0 does not increase the conjugacy. n=%d\n",n); |
|
fprintf(ficlog," Directest is positive, P_n-P_0 does not increase the conjugacy. n=%d\n",n); |
#ifdef POWELLNOF3INFF1TEST |
#ifdef POWELLNOF3INFF1TEST |
#else |
#else |
} /* end if (fptt < fp) */ |
} /* end if (fptt < fp) */ |
Line 5705 void powell(double p[], double **xi, int
|
Line 4699 void powell(double p[], double **xi, int
|
first++; |
first++; |
} |
} |
|
|
/* Try to lower 'ftol', for example from 1.e-8 to 6.e-9.\n", ftolpl, (int)age, (int)delaymax, (int)agefin, ncvloop, (int)age-(int)agefin); */ |
/* Try to lower 'ftol', for example from 1.e-8 to 6.e-9.\n", ftolpl, |
|
* (int)age, (int)delaymax, (int)agefin, ncvloop, |
|
* (int)age-(int)agefin); */ |
free_vector(min,1,nlstate); |
free_vector(min,1,nlstate); |
free_vector(max,1,nlstate); |
free_vector(max,1,nlstate); |
free_vector(meandiff,1,nlstate); |
free_vector(meandiff,1,nlstate); |
Line 5740 void powell(double p[], double **xi, int
|
Line 4736 void powell(double p[], double **xi, int
|
/* 0.51326036147820708, 0.48673963852179264} */ |
/* 0.51326036147820708, 0.48673963852179264} */ |
/* If we start from prlim again, prlim tends to a constant matrix */ |
/* If we start from prlim again, prlim tends to a constant matrix */ |
|
|
int i, ii,j,k, k1; |
int i, ii,j, k1; |
int first=0; |
int first=0; |
double *min, *max, *meandiff, maxmax,sumnew=0.; |
double *min, *max, *meandiff, maxmax,sumnew=0.; |
/* double **matprod2(); */ /* test */ |
/* double **matprod2(); */ /* test */ |
Line 6007 double **pmij(double **ps, double *cov,
|
Line 5003 double **pmij(double **ps, double *cov,
|
/* Computes the backward probability at age agefin, cov[2], and covariate combination 'ij'. In fact cov is already filled and x too. |
/* Computes the backward probability at age agefin, cov[2], and covariate combination 'ij'. In fact cov is already filled and x too. |
* Call to pmij(cov and x), call to cross prevalence, sums and inverses, left multiply, and returns in **ps as well as **bmij. |
* Call to pmij(cov and x), call to cross prevalence, sums and inverses, left multiply, and returns in **ps as well as **bmij. |
*/ |
*/ |
int i, ii, j,k; |
int ii, j; |
|
|
double **out, **pmij(); |
double **pmij(); |
double sumnew=0.; |
double sumnew=0.; |
double agefin; |
double agefin; |
double k3=0.; /* constant of the w_x diagonal matrix (in order for B to sum to 1 even for death state) */ |
double k3=0.; /* constant of the w_x diagonal matrix (in order for B to sum to 1 even for death state) */ |
Line 6222 double ***hpxij(double ***po, int nhstep
|
Line 5218 double ***hpxij(double ***po, int nhstep
|
|
|
*/ |
*/ |
|
|
int i, j, d, h, k, k1; |
int i, j, d, h, k1; |
double **out, cov[NCOVMAX+1]; |
double **out, cov[NCOVMAX+1]; |
double **newm; |
double **newm; |
double agexact; |
double agexact; |
double agebegin, ageend; |
/*double agebegin, ageend;*/ |
|
|
/* Hstepm could be zero and should return the unit matrix */ |
/* Hstepm could be zero and should return the unit matrix */ |
for (i=1;i<=nlstate+ndeath;i++) |
for (i=1;i<=nlstate+ndeath;i++) |
Line 6403 double ***hbxij(double ***po, int nhstep
|
Line 5399 double ***hbxij(double ***po, int nhstep
|
The addresss of po (p3mat allocated to the dimension of nhstepm) should be stored for output |
The addresss of po (p3mat allocated to the dimension of nhstepm) should be stored for output |
*/ |
*/ |
|
|
int i, j, d, h, k, k1; |
int i, j, d, h, k1; |
double **out, cov[NCOVMAX+1], **bmij(); |
double **out, cov[NCOVMAX+1], **bmij(); |
double **newm, ***newmm; |
double **newm, ***newmm; |
double agexact; |
double agexact; |
double agebegin, ageend; |
/*double agebegin, ageend;*/ |
double **oldm, **savm; |
double **oldm, **savm; |
|
|
newmm=po; /* To be saved */ |
newmm=po; /* To be saved */ |
Line 6568 double func( double *x)
|
Line 5564 double func( double *x)
|
|
|
for(k=1; k<=nlstate; k++) ll[k]=0.; |
for(k=1; k<=nlstate; k++) ll[k]=0.; |
ioffset=0; |
ioffset=0; |
for (i=1,ipmx=0, sw=0.; i<=imx; i++){ |
if(mle==1){ |
/* Computes the values of the ncovmodel covariates of the model |
for (i=1,ipmx=0, sw=0.; i<=imx; i++){ |
depending if the covariates are fixed or varying (age dependent) and stores them in cov[] |
/* Computes the values of the ncovmodel covariates of the model |
Then computes with function pmij which return a matrix p[i][j] giving the elementary probability |
depending if the covariates are fixed or varying (age dependent) and stores them in cov[] |
to be observed in j being in i according to the model. |
Then computes with function pmij which return a matrix p[i][j] giving the elementary probability |
*/ |
to be observed in j being in i according to the model. |
ioffset=2+nagesqr ; |
*/ |
/* Fixed */ |
ioffset=2+nagesqr ; |
for (kf=1; kf<=ncovf;kf++){ /* For each fixed covariate dummy or quant or prod */ |
/* Fixed */ |
/* # V1=sex, V2=raedyrs Quant Fixed, State=livarnb4..livarnb11, V3=iadl4..iald11, V4=adlw4..adlw11, V5=r4bmi..r11bmi */ |
for (kf=1; kf<=ncovf;kf++){ /* For each fixed covariate dummy or quant or prod */ |
/* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1 */ |
/* # V1=sex, V2=raedyrs Quant Fixed, State=livarnb4..livarnb11, V3=iadl4..iald11, V4=adlw4..adlw11, V5=r4bmi..r11bmi */ |
/* TvarF[1]=Tvar[6]=2, TvarF[2]=Tvar[7]=7, TvarF[3]=Tvar[9]=1 ID of fixed covariates or product V2, V1*V2, V1 */ |
/* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1 */ |
/* TvarFind; TvarFind[1]=6, TvarFind[2]=7, TvarFind[3]=9 *//* Inverse V2(6) is first fixed (single or prod) */ |
/* TvarF[1]=Tvar[6]=2, TvarF[2]=Tvar[7]=7, TvarF[3]=Tvar[9]=1 ID of fixed covariates or product V2, V1*V2, V1 */ |
cov[ioffset+TvarFind[kf]]=covar[Tvar[TvarFind[kf]]][i];/* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1, only V1 is fixed (TvarFind[1]=6)*/ |
/* TvarFind; TvarFind[1]=6, TvarFind[2]=7, TvarFind[3]=9 *//* Inverse V2(6) is first fixed (single or prod) */ |
/* V1*V2 (7) TvarFind[2]=7, TvarFind[3]=9 */ |
cov[ioffset+TvarFind[kf]]=covar[Tvar[TvarFind[kf]]][i];/* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1, only V1 is fixed (TvarFind[1]=6)*/ |
} |
/* V1*V2 (7) TvarFind[2]=7, TvarFind[3]=9 */ |
/* In model V2+V1*V4+age*V3+V3*V2 Tvar[1] is V2, Tvar[2=V1*V4] |
} |
is 5, Tvar[3=age*V3] should not be computed because of age Tvar[4=V3*V2]=6 |
/* In model V2+V1*V4+age*V3+V3*V2 Tvar[1] is V2, Tvar[2=V1*V4] |
has been calculated etc */ |
is 5, Tvar[3=age*V3] should not be computed because of age Tvar[4=V3*V2]=6 |
/* For an individual i, wav[i] gives the number of effective waves */ |
has been calculated etc */ |
/* We compute the contribution to Likelihood of each effective transition |
/* For an individual i, wav[i] gives the number of effective waves */ |
mw[mi][i] is real wave of the mi th effectve wave */ |
/* We compute the contribution to Likelihood of each effective transition |
/* Then statuses are computed at each begin and end of an effective wave s1=s[ mw[mi][i] ][i]; |
mw[mi][i] is real wave of the mi th effectve wave */ |
s2=s[mw[mi+1][i]][i]; |
/* Then statuses are computed at each begin and end of an effective wave s1=s[ mw[mi][i] ][i]; |
And the iv th varying covariate is the cotvar[mw[mi+1][i]][iv][i] because now is moved after nvocol+nqv |
s2=s[mw[mi+1][i]][i]; |
But if the variable is not in the model TTvar[iv] is the real variable effective in the model: |
And the iv th varying covariate is the cotvar[mw[mi+1][i]][iv][i] because now is moved after nvocol+nqv |
meaning that decodemodel should be used cotvar[mw[mi+1][i]][TTvar[iv]][i] |
But if the variable is not in the model TTvar[iv] is the real variable effective in the model: |
*/ |
meaning that decodemodel should be used cotvar[mw[mi+1][i]][TTvar[iv]][i] |
for(mi=1; mi<= wav[i]-1; mi++){ /* Varying with waves */ |
*/ |
|
for(mi=1; mi<= wav[i]-1; mi++){ /* Varying with waves */ |
/* Wave varying (but not age varying) */ |
/* Wave varying (but not age varying) */ |
/* for(k=1; k <= ncovv ; k++){ /\* Varying covariates in the model (single and product but no age )"V5+V4+V3+V4*V3+V5*age+V1*age+V1" +TvarVind 1,2,3,4(V4*V3) Tvar[1]@7{5, 4, 3, 6, 5, 1, 1 ; 6 because the created covar is after V5 and is 6, minus 1+1, 3,2,1,4 positions in cotvar*\/ */ |
/* for(k=1; k <= ncovv ; k++){ /\* Varying covariates in the model (single and product but no age )"V5+V4+V3+V4*V3+V5*age+V1*age+V1" +TvarVind 1,2,3,4(V4*V3) Tvar[1]@7{5, 4, 3, 6, 5, 1, 1 ; 6 because the created covar is after V5 and is 6, minus 1+1, 3,2,1,4 positions in cotvar*\/ */ |
/* /\* cov[ioffset+TvarVind[k]]=cotvar[mw[mi][i]][Tvar[TvarVind[k]]][i]; but where is the crossproduct? *\/ */ |
/* /\* cov[ioffset+TvarVind[k]]=cotvar[mw[mi][i]][Tvar[TvarVind[k]]][i]; but where is the crossproduct? *\/ */ |
/* cov[ioffset+TvarVind[k]]=cotvar[mw[mi][i]][Tvar[TvarVind[k]]-ncovcol-nqv][i]; */ |
/* cov[ioffset+TvarVind[k]]=cotvar[mw[mi][i]][Tvar[TvarVind[k]]-ncovcol-nqv][i]; */ |
/* } */ |
/* } */ |
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ /* Varying covariates (single and product but no age )*/ |
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ /* Varying covariates (single and product but no age )*/ |
itv=TvarVV[ncovv]; /* TvarVV={3, 1, 3} gives the name of each varying covariate */ |
itv=TvarVV[ncovv]; /* TvarVV={3, 1, 3} gives the name of each varying covariate */ |
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
if(FixedV[itv]!=0){ /* Not a fixed covariate */ |
if(FixedV[itv]!=0){ /* Not a fixed covariate */ |
cotvarv=cotvar[mw[mi][i]][TvarVV[ncovv]][i]; /* cotvar[wav][ncovcol+nqv+iv][i] */ |
cotvarv=cotvar[mw[mi][i]][TvarVV[ncovv]][i]; /* cotvar[wav][ncovcol+nqv+iv][i] */ |
}else{ /* fixed covariate */ |
|
cotvarv=covar[itv][i]; /* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model */ |
|
} |
|
if(ipos!=iposold){ /* Not a product or first of a product */ |
|
cotvarvold=cotvarv; |
|
}else{ /* A second product */ |
|
cotvarv=cotvarv*cotvarvold; |
|
} |
|
iposold=ipos; |
|
cov[ioffset+ipos]=cotvarv; |
|
} |
|
/* for(itv=1; itv <= ntveff; itv++){ /\* Varying dummy covariates (single??)*\/ */ |
|
/* iv= Tvar[Tmodelind[ioffset-2-nagesqr-cptcovage+itv]]-ncovcol-nqv; /\* Counting the # varying covariate from 1 to ntveff *\/ */ |
|
/* cov[ioffset+iv]=cotvar[mw[mi][i]][iv][i]; */ |
|
/* k=ioffset-2-nagesqr-cptcovage+itv; /\* position in simple model *\/ */ |
|
/* cov[ioffset+itv]=cotvar[mw[mi][i]][TmodelInvind[itv]][i]; */ |
|
/* printf(" i=%d,mi=%d,itv=%d,TmodelInvind[itv]=%d,cotvar[mw[mi][i]][TmodelInvind[itv]][i]=%f\n", i, mi, itv, TmodelInvind[itv],cotvar[mw[mi][i]][TmodelInvind[itv]][i]); */ |
|
/* } */ |
|
/* for(iqtv=1; iqtv <= nqtveff; iqtv++){ /\* Varying quantitatives covariates *\/ */ |
|
/* iv=TmodelInvQind[iqtv]; /\* Counting the # varying covariate from 1 to ntveff *\/ */ |
|
/* /\* printf(" i=%d,mi=%d,iqtv=%d,TmodelInvQind[iqtv]=%d,cotqvar[mw[mi][i]][TmodelInvQind[iqtv]][i]=%f\n", i, mi, iqtv, TmodelInvQind[iqtv],cotqvar[mw[mi][i]][TmodelInvQind[iqtv]][i]); *\/ */ |
|
/* cov[ioffset+ntveff+iqtv]=cotqvar[mw[mi][i]][TmodelInvQind[iqtv]][i]; */ |
|
/* } */ |
|
/* for products of time varying to be done */ |
|
for (ii=1;ii<=nlstate+ndeath;ii++) |
|
for (j=1;j<=nlstate+ndeath;j++){ |
|
oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
savm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
} |
|
|
|
agebegin=agev[mw[mi][i]][i]; /* Age at beginning of effective wave */ |
|
ageend=agev[mw[mi][i]][i] + (dh[mi][i])*stepm/YEARM; /* Age at end of effective wave and at the end of transition */ |
|
for(d=0; d<dh[mi][i]; d++){ |
|
newm=savm; |
|
agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; |
|
cov[2]=agexact; |
|
if(nagesqr==1) |
|
cov[3]= agexact*agexact; /* Should be changed here */ |
|
for (kk=1; kk<=cptcovprodage;kk++) {/* + age*V3*V2 +age*V2 +age*V3 +age*V4 For age product with simple covariates or product of fixed covariates */ |
|
/* if(!FixedV[Tvar[Tage[kk]]]) */ |
|
cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; /* Tage[kk] gives the data-covariate associated with age */ |
|
/* else*/ |
|
/*cov[Tage[kk]+2+nagesqr]=cotvar[mw[mi][i]][Tvar[Tage[kk]]][i]*agexact; *//* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) */ |
|
} |
|
for(ncovva=1, iposold=0; ncovva <= ncovvta ; ncovva++){ /* Time varying covariates with age including individual from products, product is computed dynamically */ |
|
itv=TvarVVA[ncovva]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, exploding product Vn*Vm into Vn and then Vm */ |
|
ipos=TvarVVAind[ncovva]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
|
if(FixedV[itv]!=0){ /* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv */ |
|
cotvarv=cotvar[mw[mi][i]][TvarVVA[ncovva]][i]; /* because cotvar starts now at first ncovcol+nqv+ntv+nqtv (1 to nqtv) */ |
|
}else{ /* fixed covariate */ |
}else{ /* fixed covariate */ |
cotvarv=covar[itv][i]; /* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model */ |
cotvarv=covar[itv][i]; /* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model */ |
} |
} |
Line 6665 double func( double *x)
|
Line 5613 double func( double *x)
|
cotvarv=cotvarv*cotvarvold; |
cotvarv=cotvarv*cotvarvold; |
} |
} |
iposold=ipos; |
iposold=ipos; |
cov[ioffset+ipos]=cotvarv*agexact; |
cov[ioffset+ipos]=cotvarv; |
/* For products */ |
|
} |
} |
|
/* for products of time varying to be done */ |
|
for (ii=1;ii<=nlstate+ndeath;ii++) |
|
for (j=1;j<=nlstate+ndeath;j++){ |
|
oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
savm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
} |
|
|
|
agebegin=agev[mw[mi][i]][i]; /* Age at beginning of effective wave */ |
|
ageend=agev[mw[mi][i]][i] + (dh[mi][i])*stepm/YEARM; /* Age at end of effective wave and at the end of transition */ |
|
for(d=0; d<dh[mi][i]; d++){ |
|
newm=savm; |
|
agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; |
|
cov[2]=agexact; |
|
if(nagesqr==1) |
|
cov[3]= agexact*agexact; /* Should be changed here */ |
|
/* for (kk=1; kk<=cptcovage;kk++) { */ |
|
/* if(!FixedV[Tvar[Tage[kk]]]) */ |
|
/* cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; /\* Tage[kk] gives the data-covariate associated with age *\/ */ |
|
/* else */ |
|
/* cov[Tage[kk]+2+nagesqr]=cotvar[mw[mi][i]][Tvar[Tage[kk]]][i]*agexact; /\* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) *\/ */ |
|
/* } */ |
|
for(ncovva=1, iposold=0; ncovva <= ncovta ; ncovva++){ /* Time varying covariates with age including individual from products, product is computed dynamically */ |
|
itv=TvarAVVA[ncovva]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, exploding product Vn*Vm into Vn and then Vm */ |
|
ipos=TvarAVVAind[ncovva]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
|
if(FixedV[itv]!=0){ /* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv */ |
|
cotvarv=cotvar[mw[mi][i]][TvarAVVA[ncovva]][i]; /* because cotvar starts now at first ncovcol+nqv+ntv+nqtv (1 to nqtv) */ |
|
}else{ /* fixed covariate */ |
|
cotvarv=covar[itv][i]; /* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model */ |
|
} |
|
if(ipos!=iposold){ /* Not a product or first of a product */ |
|
cotvarvold=cotvarv; |
|
}else{ /* A second product */ |
|
cotvarv=cotvarv*cotvarvold; |
|
} |
|
iposold=ipos; |
|
cov[ioffset+ipos]=cotvarv*agexact; |
|
/* For products */ |
|
} |
|
|
|
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
|
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
|
savm=oldm; |
|
oldm=newm; |
|
} /* end mult */ |
|
|
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
|
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
|
savm=oldm; |
|
oldm=newm; |
|
} /* end mult */ |
|
|
|
/*lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]);*/ /* Original formula */ |
/*lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]);*/ /* Original formula */ |
/* But now since version 0.9 we anticipate for bias at large stepm. |
/* But now since version 0.9 we anticipate for bias at large stepm. |
* If stepm is larger than one month (smallest stepm) and if the exact delay |
* If stepm is larger than one month (smallest stepm) and if the exact delay |
* (in months) between two waves is not a multiple of stepm, we rounded to |
* (in months) between two waves is not a multiple of stepm, we rounded to |
* the nearest (and in case of equal distance, to the lowest) interval but now |
* the nearest (and in case of equal distance, to the lowest) interval but now |
* we keep into memory the bias bh[mi][i] and also the previous matrix product |
* we keep into memory the bias bh[mi][i] and also the previous matrix product |
* (i.e to dh[mi][i]-1) saved in 'savm'. Then we inter(extra)polate the |
* (i.e to dh[mi][i]-1) saved in 'savm'. Then we inter(extra)polate the |
* probability in order to take into account the bias as a fraction of the way |
* probability in order to take into account the bias as a fraction of the way |
* from savm to out if bh is negative or even beyond if bh is positive. bh varies |
* from savm to out if bh is negative or even beyond if bh is positive. bh varies |
* -stepm/2 to stepm/2 . |
* -stepm/2 to stepm/2 . |
* For stepm=1 the results are the same as for previous versions of Imach. |
* For stepm=1 the results are the same as for previous versions of Imach. |
* For stepm > 1 the results are less biased than in previous versions. |
* For stepm > 1 the results are less biased than in previous versions. |
*/ |
*/ |
s1=s[mw[mi][i]][i]; |
s1=s[mw[mi][i]][i]; |
s2=s[mw[mi+1][i]][i]; |
s2=s[mw[mi+1][i]][i]; |
bbh=(double)bh[mi][i]/(double)stepm; |
bbh=(double)bh[mi][i]/(double)stepm; |
/* bias bh is positive if real duration |
/* bias bh is positive if real duration |
* is higher than the multiple of stepm and negative otherwise. |
* is higher than the multiple of stepm and negative otherwise. |
*/ |
*/ |
/* lli= (savm[s1][s2]>1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2]));*/ |
/* lli= (savm[s1][s2]>1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2]));*/ |
if( s2 > nlstate){ |
if( s2 > nlstate){ |
/* i.e. if s2 is a death state and if the date of death is known |
/* i.e. if s2 is a death state and if the date of death is known |
then the contribution to the likelihood is the probability to |
then the contribution to the likelihood is the probability to |
die between last step unit time and current step unit time, |
die between last step unit time and current step unit time, |
which is also equal to probability to die before dh |
which is also equal to probability to die before dh |
minus probability to die before dh-stepm . |
minus probability to die before dh-stepm . |
In version up to 0.92 likelihood was computed |
In version up to 0.92 likelihood was computed |
as if date of death was unknown. Death was treated as any other |
as if date of death was unknown. Death was treated as any other |
health state: the date of the interview describes the actual state |
health state: the date of the interview describes the actual state |
and not the date of a change in health state. The former idea was |
and not the date of a change in health state. The former idea was |
to consider that at each interview the state was recorded |
to consider that at each interview the state was recorded |
(healthy, disable or death) and IMaCh was corrected; but when we |
(healthy, disable or death) and IMaCh was corrected; but when we |
introduced the exact date of death then we should have modified |
introduced the exact date of death then we should have modified |
the contribution of an exact death to the likelihood. This new |
the contribution of an exact death to the likelihood. This new |
contribution is smaller and very dependent of the step unit |
contribution is smaller and very dependent of the step unit |
stepm. It is no more the probability to die between last interview |
stepm. It is no more the probability to die between last interview |
and month of death but the probability to survive from last |
and month of death but the probability to survive from last |
interview up to one month before death multiplied by the |
interview up to one month before death multiplied by the |
probability to die within a month. Thanks to Chris |
probability to die within a month. Thanks to Chris |
Jackson for correcting this bug. Former versions increased |
Jackson for correcting this bug. Former versions increased |
mortality artificially. The bad side is that we add another loop |
mortality artificially. The bad side is that we add another loop |
which slows down the processing. The difference can be up to 10% |
which slows down the processing. The difference can be up to 10% |
lower mortality. |
lower mortality. |
*/ |
*/ |
/* If, at the beginning of the maximization mostly, the |
/* If, at the beginning of the maximization mostly, the |
cumulative probability or probability to be dead is |
cumulative probability or probability to be dead is |
constant (ie = 1) over time d, the difference is equal to |
constant (ie = 1) over time d, the difference is equal to |
0. out[s1][3] = savm[s1][3]: probability, being at state |
0. out[s1][3] = savm[s1][3]: probability, being at state |
s1 at precedent wave, to be dead a month before current |
s1 at precedent wave, to be dead a month before current |
wave is equal to probability, being at state s1 at |
wave is equal to probability, being at state s1 at |
precedent wave, to be dead at mont of the current |
precedent wave, to be dead at mont of the current |
wave. Then the observed probability (that this person died) |
wave. Then the observed probability (that this person died) |
is null according to current estimated parameter. In fact, |
is null according to current estimated parameter. In fact, |
it should be very low but not zero otherwise the log go to |
it should be very low but not zero otherwise the log go to |
infinity. |
infinity. |
*/ |
*/ |
/* #ifdef INFINITYORIGINAL */ |
/* #ifdef INFINITYORIGINAL */ |
/* lli=log(out[s1][s2] - savm[s1][s2]); */ |
/* lli=log(out[s1][s2] - savm[s1][s2]); */ |
/* #else */ |
/* #else */ |
Line 6739 double func( double *x)
|
Line 5724 double func( double *x)
|
/* else */ |
/* else */ |
/* lli=log(out[s1][s2] - savm[s1][s2]); */ |
/* lli=log(out[s1][s2] - savm[s1][s2]); */ |
/* #endif */ |
/* #endif */ |
lli=log(out[s1][s2] - savm[s1][s2]); |
lli=log(out[s1][s2] - savm[s1][s2]); |
|
|
|
} else if ( s2==-1 ) { /* alive */ |
|
for (j=1,survp=0. ; j<=nlstate; j++) |
|
survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; |
|
/*survp += out[s1][j]; */ |
|
lli= log(survp); |
|
} |
|
/* else if (s2==-4) { */ |
|
/* for (j=3,survp=0. ; j<=nlstate; j++) */ |
|
/* survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; */ |
|
/* lli= log(survp); */ |
|
/* } */ |
|
/* else if (s2==-5) { */ |
|
/* for (j=1,survp=0. ; j<=2; j++) */ |
|
/* survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; */ |
|
/* lli= log(survp); */ |
|
/* } */ |
|
else{ |
|
lli= log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]); /* linear interpolation */ |
|
/* lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*(savm[s1][s2])):log((1.+bbh)*out[s1][s2]));*/ /* linear interpolation */ |
|
} |
|
/*lli=(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]);*/ |
|
/*if(lli ==000.0)*/ |
|
/* printf("num[i], i=%d, bbh= %f lli=%f savm=%f out=%f %d\n",bbh,lli,savm[s1][s2], out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]],i); */ |
|
ipmx +=1; |
|
sw += weight[i]; |
|
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; |
|
/* if (lli < log(mytinydouble)){ */ |
|
/* printf("Close to inf lli = %.10lf < %.10lf i= %d mi= %d, s[%d][i]=%d s1=%d s2=%d\n", lli,log(mytinydouble), i, mi,mw[mi][i], s[mw[mi][i]][i], s1,s2); */ |
|
/* fprintf(ficlog,"Close to inf lli = %.10lf i= %d mi= %d, s[mw[mi][i]][i]=%d\n", lli, i, mi,s[mw[mi][i]][i]); */ |
|
/* } */ |
|
} /* end of wave */ |
|
} /* end of individual */ |
|
} else if(mle==2){ |
|
for (i=1,ipmx=0, sw=0.; i<=imx; i++){ |
|
ioffset=2+nagesqr ; |
|
for (k=1; k<=ncovf;k++) |
|
cov[ioffset+TvarFind[k]]=covar[Tvar[TvarFind[k]]][i]; |
|
for(mi=1; mi<= wav[i]-1; mi++){ |
|
for(k=1; k <= ncovv ; k++){ |
|
cov[ioffset+TvarVind[k]]=cotvar[mw[mi][i]][Tvar[TvarVind[k]]][i]; /* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) */ |
|
} |
|
for (ii=1;ii<=nlstate+ndeath;ii++) |
|
for (j=1;j<=nlstate+ndeath;j++){ |
|
oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
savm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
} |
|
for(d=0; d<=dh[mi][i]; d++){ |
|
newm=savm; |
|
agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; |
|
cov[2]=agexact; |
|
if(nagesqr==1) |
|
cov[3]= agexact*agexact; |
|
for (kk=1; kk<=cptcovage;kk++) { |
|
cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; |
|
} |
|
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
|
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
|
savm=oldm; |
|
oldm=newm; |
|
} /* end mult */ |
|
|
|
s1=s[mw[mi][i]][i]; |
|
s2=s[mw[mi+1][i]][i]; |
|
bbh=(double)bh[mi][i]/(double)stepm; |
|
lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*(savm[s1][s2])):log((1.+bbh)*out[s1][s2])); /* linear interpolation */ |
|
ipmx +=1; |
|
sw += weight[i]; |
|
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; |
|
} /* end of wave */ |
|
} /* end of individual */ |
|
} else if(mle==3){ /* exponential inter-extrapolation */ |
|
for (i=1,ipmx=0, sw=0.; i<=imx; i++){ |
|
for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; |
|
for(mi=1; mi<= wav[i]-1; mi++){ |
|
for (ii=1;ii<=nlstate+ndeath;ii++) |
|
for (j=1;j<=nlstate+ndeath;j++){ |
|
oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
savm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
} |
|
for(d=0; d<dh[mi][i]; d++){ |
|
newm=savm; |
|
agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; |
|
cov[2]=agexact; |
|
if(nagesqr==1) |
|
cov[3]= agexact*agexact; |
|
for (kk=1; kk<=cptcovage;kk++) { |
|
if(!FixedV[Tvar[Tage[kk]]]) |
|
cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; /* Tage[kk] gives the data-covariate associated with age */ |
|
else |
|
cov[Tage[kk]+2+nagesqr]=cotvar[mw[mi][i]][Tvar[Tage[kk]]][i]*agexact; /* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) */ |
|
} |
|
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
|
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
|
savm=oldm; |
|
oldm=newm; |
|
} /* end mult */ |
|
|
|
s1=s[mw[mi][i]][i]; |
|
s2=s[mw[mi+1][i]][i]; |
|
bbh=(double)bh[mi][i]/(double)stepm; |
|
lli= (savm[s1][s2]>1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2])); /* exponential inter-extrapolation */ |
|
ipmx +=1; |
|
sw += weight[i]; |
|
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; |
|
} /* end of wave */ |
|
} /* end of individual */ |
|
}else if (mle==4){ /* ml=4 no inter-extrapolation */ |
|
for (i=1,ipmx=0, sw=0.; i<=imx; i++){ |
|
for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; |
|
for(mi=1; mi<= wav[i]-1; mi++){ |
|
for (ii=1;ii<=nlstate+ndeath;ii++) |
|
for (j=1;j<=nlstate+ndeath;j++){ |
|
oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
savm[ii][j]=(ii==j ? 1.0 : 0.0); |
|
} |
|
for(d=0; d<dh[mi][i]; d++){ |
|
newm=savm; |
|
agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; |
|
cov[2]=agexact; |
|
if(nagesqr==1) |
|
cov[3]= agexact*agexact; |
|
for (kk=1; kk<=cptcovage;kk++) { |
|
cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; |
|
} |
|
|
} else if ( s2==-1 ) { /* alive */ |
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
for (j=1,survp=0. ; j<=nlstate; j++) |
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; |
savm=oldm; |
/*survp += out[s1][j]; */ |
oldm=newm; |
lli= log(survp); |
} /* end mult */ |
} |
|
/* else if (s2==-4) { */ |
s1=s[mw[mi][i]][i]; |
/* for (j=3,survp=0. ; j<=nlstate; j++) */ |
s2=s[mw[mi+1][i]][i]; |
/* survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; */ |
if( s2 > nlstate){ |
/* lli= log(survp); */ |
lli=log(out[s1][s2] - savm[s1][s2]); |
/* } */ |
} else if ( s2==-1 ) { /* alive */ |
/* else if (s2==-5) { */ |
for (j=1,survp=0. ; j<=nlstate; j++) |
/* for (j=1,survp=0. ; j<=2; j++) */ |
survp += out[s1][j]; |
/* survp += (1.+bbh)*out[s1][j]- bbh*savm[s1][j]; */ |
lli= log(survp); |
/* lli= log(survp); */ |
}else{ |
/* } */ |
lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]); /* Original formula */ |
else if (mle==1){ |
} |
lli= log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]); /* linear interpolation */ |
ipmx +=1; |
/* lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*(savm[s1][s2])):log((1.+bbh)*out[s1][s2]));*/ /* linear interpolation */ |
sw += weight[i]; |
} else if(mle==2){ |
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; |
lli= (savm[s1][s2]>(double)1.e-8 ?log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]):log((1.+bbh)*out[s1][s2])); /* linear interpolation */ |
/* printf("num[i]=%09ld, i=%6d s1=%1d s2=%1d mi=%1d mw=%1d dh=%3d prob=%10.6f w=%6.4f out=%10.6f sav=%10.6f\n",num[i],i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],(s2==-1? -1: out[s1][s2]),(s2==-1? -1: savm[s1][s2])); */ |
} else if(mle==3){ /* exponential inter-extrapolation */ |
} /* end of wave */ |
lli= (savm[s1][s2]>(double)1.e-8 ?(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]):log((1.+bbh)*out[s1][s2])); /* exponential inter-extrapolation */ |
} /* end of individual */ |
} else if (mle==4){ /* mle=4 no inter-extrapolation */ |
}else{ /* ml=5 no inter-extrapolation no jackson =0.8a */ |
lli=log(out[s1][s2]); /* Original formula */ |
for (i=1,ipmx=0, sw=0.; i<=imx; i++){ |
} else{ /* mle=0 back to 1 */ |
for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; |
lli= log((1.+bbh)*out[s1][s2]- bbh*savm[s1][s2]); /* linear interpolation */ |
for(mi=1; mi<= wav[i]-1; mi++){ |
/*lli=log(out[s1][s2]); */ /* Original formula */ |
for (ii=1;ii<=nlstate+ndeath;ii++) |
} |
for (j=1;j<=nlstate+ndeath;j++){ |
/*lli=(1.+bbh)*log(out[s1][s2])- bbh*log(savm[s1][s2]);*/ |
oldm[ii][j]=(ii==j ? 1.0 : 0.0); |
/*if(lli ==000.0)*/ |
savm[ii][j]=(ii==j ? 1.0 : 0.0); |
/* printf("num[i], i=%d, bbh= %f lli=%f savm=%f out=%f %d\n",bbh,lli,savm[s1][s2], out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]],i); */ |
} |
ipmx +=1; |
for(d=0; d<dh[mi][i]; d++){ |
sw += weight[i]; |
newm=savm; |
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; |
agexact=agev[mw[mi][i]][i]+d*stepm/YEARM; |
/* if (lli < log(mytinydouble)){ */ |
cov[2]=agexact; |
/* printf("Close to inf lli = %.10lf < %.10lf i= %d mi= %d, s[%d][i]=%d s1=%d s2=%d\n", lli,log(mytinydouble), i, mi,mw[mi][i], s[mw[mi][i]][i], s1,s2); */ |
if(nagesqr==1) |
/* fprintf(ficlog,"Close to inf lli = %.10lf i= %d mi= %d, s[mw[mi][i]][i]=%d\n", lli, i, mi,s[mw[mi][i]][i]); */ |
cov[3]= agexact*agexact; |
/* } */ |
for (kk=1; kk<=cptcovage;kk++) { |
} /* end of wave */ |
if(!FixedV[Tvar[Tage[kk]]]) |
} /* end of individual */ |
cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; /* Tage[kk] gives the data-covariate associated with age */ |
|
else |
|
cov[Tage[kk]+2+nagesqr]=cotvar[mw[mi][i]][Tvar[Tage[kk]]][i]*agexact; /* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) */ |
|
} |
|
|
|
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
|
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
|
savm=oldm; |
|
oldm=newm; |
|
} /* end mult */ |
|
|
|
s1=s[mw[mi][i]][i]; |
|
s2=s[mw[mi+1][i]][i]; |
|
lli=log(out[s[mw[mi][i]][i]][s[mw[mi+1][i]][i]]); /* Original formula */ |
|
ipmx +=1; |
|
sw += weight[i]; |
|
ll[s[mw[mi][i]][i]] += 2*weight[i]*lli; |
|
/*printf("i=%6d s1=%1d s2=%1d mi=%1d mw=%1d dh=%3d prob=%10.6f w=%6.4f out=%10.6f sav=%10.6f\n",i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],out[s1][s2],savm[s1][s2]);*/ |
|
} /* end of wave */ |
|
} /* end of individual */ |
|
} /* End of if */ |
for(k=1,l=0.; k<=nlstate; k++) l += ll[k]; |
for(k=1,l=0.; k<=nlstate; k++) l += ll[k]; |
/* printf("l1=%f l2=%f ",ll[1],ll[2]); */ |
/* printf("l1=%f l2=%f ",ll[1],ll[2]); */ |
l= l*ipmx/sw; /* To get the same order of magnitude as if weight=1 for every body */ |
l= l*ipmx/sw; /* To get the same order of magnitude as if weight=1 for every body */ |
Line 6792 double func( double *x)
|
Line 5922 double func( double *x)
|
double funcone( double *x) |
double funcone( double *x) |
{ |
{ |
/* Same as func but slower because of a lot of printf and if */ |
/* Same as func but slower because of a lot of printf and if */ |
int i, ii, j, k, mi, d, kk, kv=0, kf=0; |
int i, ii, j, k, mi, d, kv=0, kf=0; |
int ioffset=0; |
int ioffset=0; |
int ipos=0,iposold=0,ncovv=0; |
int ipos=0,iposold=0,ncovv=0; |
|
|
char labficresilk[NCOVMAX+1]; |
|
double cotvarv, cotvarvold; |
double cotvarv, cotvarvold; |
double l, ll[NLSTATEMAX+1], cov[NCOVMAX+1]; |
double l, ll[NLSTATEMAX+1], cov[NCOVMAX+1]; |
double **out; |
double **out; |
Line 6829 double funcone( double *x)
|
Line 5958 double funcone( double *x)
|
/* Fixed */ |
/* Fixed */ |
/* for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; */ |
/* for (k=1; k<=cptcovn;k++) cov[2+nagesqr+k]=covar[Tvar[k]][i]; */ |
/* for (k=1; k<=ncoveff;k++){ /\* Simple and product fixed Dummy covariates without age* products *\/ */ |
/* for (k=1; k<=ncoveff;k++){ /\* Simple and product fixed Dummy covariates without age* products *\/ */ |
/*strcpy(labficresilk," "); */ /* A string fed with values of covariates and print in ficresilk at the end of the line to produce graphics with covariate values and also in order to verify the process of calculating the likelihood */ |
|
for (kf=1; kf<=ncovf;kf++){ /* V2 + V3 + V4 Simple and product fixed covariates without age* products *//* Missing values are set to -1 but should be dropped */ |
for (kf=1; kf<=ncovf;kf++){ /* V2 + V3 + V4 Simple and product fixed covariates without age* products *//* Missing values are set to -1 but should be dropped */ |
/* printf("Debug3 TvarFind[%d]=%d",kf, TvarFind[kf]); */ |
/* printf("Debug3 TvarFind[%d]=%d",kf, TvarFind[kf]); */ |
/* printf(" Tvar[TvarFind[kf]]=%d", Tvar[TvarFind[kf]]); */ |
/* printf(" Tvar[TvarFind[kf]]=%d", Tvar[TvarFind[kf]]); */ |
/* printf(" i=%d covar[Tvar[TvarFind[kf]]][i]=%f\n",i,covar[Tvar[TvarFind[kf]]][i]); */ |
/* printf(" i=%d covar[Tvar[TvarFind[kf]]][i]=%f\n",i,covar[Tvar[TvarFind[kf]]][i]); */ |
ipos=TvarFind[kf]; |
|
cov[ioffset+TvarFind[kf]]=covar[Tvar[TvarFind[kf]]][i];/* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1, only V1 is fixed (k=6)*/ |
cov[ioffset+TvarFind[kf]]=covar[Tvar[TvarFind[kf]]][i];/* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1, only V1 is fixed (k=6)*/ |
/* if(globpr) */ |
|
/* sprintf(labficresilk+strlen(labficresilk)," %g",cov[ioffset+ipos]); */ |
|
/* cov[ioffset+TvarFind[1]]=covar[Tvar[TvarFind[1]]][i]; */ |
/* cov[ioffset+TvarFind[1]]=covar[Tvar[TvarFind[1]]][i]; */ |
/* cov[2+6]=covar[Tvar[6]][i]; */ |
/* cov[2+6]=covar[Tvar[6]][i]; */ |
/* cov[2+6]=covar[2][i]; V2 */ |
/* cov[2+6]=covar[2][i]; V2 */ |
Line 6848 double funcone( double *x)
|
Line 5973 double funcone( double *x)
|
/* cov[2+9]=covar[Tvar[9]][i]; */ |
/* cov[2+9]=covar[Tvar[9]][i]; */ |
/* cov[2+9]=covar[1][i]; V1 */ |
/* cov[2+9]=covar[1][i]; V1 */ |
} |
} |
/* In model V2+V1*V4+age*V3+V3*V2 Tvar[1] is V2, Tvar[2=V1*V4] |
/* In model V2+V1*V4+age*V3+V3*V2 Tvar[1] is V2, Tvar[2=V1*V4] |
is 5, Tvar[3=age*V3] should not be computed because of age Tvar[4=V3*V2]=6 |
is 5, Tvar[3=age*V3] should not be computed because of age Tvar[4=V3*V2]=6 |
has been calculated etc */ |
has been calculated etc */ |
/* For an individual i, wav[i] gives the number of effective waves */ |
/* For an individual i, wav[i] gives the number of effective waves */ |
/* We compute the contribution to Likelihood of each effective transition |
/* We compute the contribution to Likelihood of each effective transition |
mw[mi][i] is real wave of the mi th effectve wave */ |
mw[mi][i] is real wave of the mi th effectve wave */ |
/* Then statuses are computed at each begin and end of an effective wave s1=s[ mw[mi][i] ][i]; |
/* Then statuses are computed at each begin and end of an effective wave s1=s[ mw[mi][i] ][i]; |
s2=s[mw[mi+1][i]][i]; |
s2=s[mw[mi+1][i]][i]; |
And the iv th varying covariate in the DATA is the cotvar[mw[mi+1][i]][ncovcol+nqv+iv][i] |
And the iv th varying covariate in the DATA is the cotvar[mw[mi+1][i]][ncovcol+nqv+iv][i] |
*/ |
*/ |
/* This part may be useless now because everythin should be in covar */ |
/* This part may be useless now because everythin should be in covar */ |
/* for (k=1; k<=nqfveff;k++){ /\* Simple and product fixed Quantitative covariates without age* products *\/ */ |
/* for (k=1; k<=nqfveff;k++){ /\* Simple and product fixed Quantitative covariates without age* products *\/ */ |
/* cov[++ioffset]=coqvar[TvarFQ[k]][i];/\* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1, only V2 and V1*V2 is fixed (k=6 and 7?)*\/ */ |
/* cov[++ioffset]=coqvar[TvarFQ[k]][i];/\* V5+V4+V3+V4*V3+V5*age+V2+V1*V2+V1*age+V1, only V2 and V1*V2 is fixed (k=6 and 7?)*\/ */ |
Line 6966 double funcone( double *x)
|
Line 6091 double funcone( double *x)
|
* 3 ncovta=15 +age*V3*V2+age*V2+agev3+ageV4 +age*V6 + age*V7 + age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 |
* 3 ncovta=15 +age*V3*V2+age*V2+agev3+ageV4 +age*V6 + age*V7 + age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 |
* 3 TvarAVVA[1]@15= itva 3 2 2 3 4 6 7 6 3 7 3 6 4 7 4 |
* 3 TvarAVVA[1]@15= itva 3 2 2 3 4 6 7 6 3 7 3 6 4 7 4 |
* 3 ncovta 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
* 3 ncovta 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
* |
*?TvarAVVAind[1]@15= V3 is in k=2 1 1 2 3 4 5 4,2 5,2, 4,3 5 3}TvarVVAind[] |
* TvarAVVAind[1]@15= V3 is in k=6 6 12 13 14 15 16 18 18 19,19, 20,20 21,21}TvarVVAind[] |
* TvarAVVAind[1]@15= V3 is in k=6 6 12 13 14 15 16 18 18 19,19, 20,20 21,21}TvarVVAind[] |
* 3 ncovvta=10 +age*V6 + age*V7 + age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 |
* 3 ncovvta=10 +age*V6 + age*V7 + age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 |
* 3 we want to compute =cotvar[mw[mi][i]][TvarVVA[ncovva]][i] at position TvarVVAind[ncovva] |
* 3 we want to compute =cotvar[mw[mi][i]][TvarVVA[ncovva]][i] at position TvarVVAind[ncovva] |
Line 6980 double funcone( double *x)
|
Line 6105 double funcone( double *x)
|
* 2, 3, 4, 6, 7, |
* 2, 3, 4, 6, 7, |
* 6, 8, 9, 10, 11} |
* 6, 8, 9, 10, 11} |
* TvarFind[itv] 0 0 0 |
* TvarFind[itv] 0 0 0 |
* FixedV[itv] 1 1 1 0 1 0 1 0 1 0 1 0 1 0 |
* FixedV[itv] 1 1 1 0 1 0 1 0 1 0 0 |
|
*? FixedV[itv] 1 1 1 0 1 0 1 0 1 0 1 0 1 0 |
* Tvar[TvarFind[ncovf]]=[1]=2 [2]=3 [4]=4 |
* Tvar[TvarFind[ncovf]]=[1]=2 [2]=3 [4]=4 |
* Tvar[TvarFind[itv]] [0]=? ?ncovv 1 à ncovvt] |
* Tvar[TvarFind[itv]] [0]=? ?ncovv 1 à ncovvt] |
* Not a fixed cotvar[mw][itv][i] 6 7 6 2 7, 2, 6, 3, 7, 3, 6, 4, 7, 4} |
* Not a fixed cotvar[mw][itv][i] 6 7 6 2 7, 2, 6, 3, 7, 3, 6, 4, 7, 4} |
* fixed covar[itv] [6] [7] [6][2] |
* fixed covar[itv] [6] [7] [6][2] |
*/ |
*/ |
|
|
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ /* V6 V7 V7*V2 V6*V3 V7*V3 V6*V4 V7*V4 Time varying covariates (single and extended product but no age) including individual from products, product is computed dynamically */ |
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ /* V6 V7 V7*V2 V6*V3 V7*V3 V6*V4 V7*V4 Time varying covariates (single and extended product but no age) including individual from products, product is computed dynamically */ |
itv=TvarVV[ncovv]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, or fixed covariate of a varying product after exploding product Vn*Vm into Vn and then Vm */ |
itv=TvarVV[ncovv]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, or fixed covariate of a varying product after exploding product Vn*Vm into Vn and then Vm */ |
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
Line 7001 double funcone( double *x)
|
Line 6127 double funcone( double *x)
|
cotvarv=covar[itv][i]; /* Good: In V6*V3, 3 is fixed at position of the data */ |
cotvarv=covar[itv][i]; /* Good: In V6*V3, 3 is fixed at position of the data */ |
/* printf("DEBUG Fixed cov[ioffset+ipos=%d]=%g \n",ioffset+ipos,cotvarv); */ |
/* printf("DEBUG Fixed cov[ioffset+ipos=%d]=%g \n",ioffset+ipos,cotvarv); */ |
} |
} |
/* if(globpr) */ |
|
/* sprintf(labficresilk+strlen(labficresilk)," %g",cotvarv); */ |
|
if(ipos!=iposold){ /* Not a product or first of a product */ |
if(ipos!=iposold){ /* Not a product or first of a product */ |
cotvarvold=cotvarv; |
cotvarvold=cotvarv; |
}else{ /* A second product */ |
}else{ /* A second product */ |
cotvarv=cotvarv*cotvarvold; |
cotvarv=cotvarv*cotvarvold; |
/* if(globpr) */ |
|
/* sprintf(labficresilk+strlen(labficresilk)," *"); */ |
|
/* printf("DEBUG * \n"); */ |
|
} |
} |
iposold=ipos; |
iposold=ipos; |
cov[ioffset+ipos]=cotvarv; |
cov[ioffset+ipos]=cotvarv; |
Line 7052 double funcone( double *x)
|
Line 6173 double funcone( double *x)
|
cov[2]=agexact; |
cov[2]=agexact; |
if(nagesqr==1) |
if(nagesqr==1) |
cov[3]= agexact*agexact; |
cov[3]= agexact*agexact; |
/* for (kk=1; kk<=cptcovage;kk++) { /\* + age*V3*V2 +age*V2 +age*V3 +age*V4 For age product with simple covariates or product of fixed covariates *\/ */ |
for(ncovva=1, iposold=0; ncovva <= ncovta ; ncovva++){ /* Time varying covariates with age including individual from products, product is computed dynamically */ |
for (kk=1; kk<=cptcovprodage;kk++) { /* + age*V3*V2 +age*V2 +age*V3 +age*V4 For age product with simple covariates or product of fixed covariates */ |
itv=TvarAVVA[ncovva]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, exploding product Vn*Vm into Vn and then Vm */ |
ipos=Tage[kk]; |
ipos=TvarAVVAind[ncovva]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
if(!FixedV[Tvar[Tage[kk]]]){ /* age*V3*V2 +age*V2 +age*V3 +age*V4 Fixed covariate with age age*V3 or age*V2*V3 Tvar[Tage[kk]] has its own already calculated column */ |
|
/* printf("DEBUG kk=%d, Fixed Tvar[Tage[kk]]=%d agexact=%g\n",kk, Tvar[Tage[kk]], agexact); */ |
|
cov[Tage[kk]+2+nagesqr]=covar[Tvar[Tage[kk]]][i]*agexact; |
|
/* printf("DEBUG Fixed cov[Tage[kk]+2+nagesqr=%d]=%g agexact=%g \n",Tage[kk]+2+nagesqr,cov[Tage[kk]+2+nagesqr], agexact); */ |
|
}else{ /* +age*V6 + age*V7 + age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 time varying covariates with age age*V7 or age*V7*V3 is Tvar[Tage[kk]] defined, yes*/ |
|
/* printf("DEBUG kk=%d, Varyingd Tvar[Tage[kk]]=%d\n",kk, Tvar[Tage[kk]]); */ |
|
cov[Tage[kk]+2+nagesqr]=cotvar[mw[mi][i]][Tvar[Tage[kk]]][i]*agexact; /* Are you sure? because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) */ |
|
/* printf("DEBUG Varying cov[Tage[kk]+2+nagesqr=%d]=%g agexact=%g \n",Tage[kk]+2+nagesqr,cov[Tage[kk]+2+nagesqr], agexact); */ |
|
} |
|
/* if(globpr) */ |
|
/* sprintf(labficresilk+strlen(labficresilk)," %g*ageF",cov[Tage[kk]+2+nagesqr]); */ |
|
} |
|
/* For product with age age*Vn*Vm where Vn*Vm is time varying */ |
|
/* for(kv=1; kv<=cptcovprodvage;kv++){ /\*HERY? +age*V6 + age*V7 +age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 Number of time varying covariates with age *\/ */ |
|
for(ncovva=1, iposold=0; ncovva <= ncovvta ; ncovva++){ /* +age*V6 + age*V7 +age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 Time varying covariates with age including individual from products, product is computed dynamically */ |
|
itv=TvarVVA[ncovva]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, exploding product Vn*Vm into Vn and then Vm */ |
|
ipos=TvarVVAind[ncovva]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
|
/* if(TvarFind[itv]==0){ /\* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv *\/ */ |
/* if(TvarFind[itv]==0){ /\* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv *\/ */ |
if(FixedV[itv]!=0){ /* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv */ |
if(FixedV[itv]!=0){ /* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv */ |
/* printf("DEBUG ncovva=%d, Varying TvarVVA[ncovva]=%d agexact=%g\n", ncovva, TvarVVA[ncovva], agexact); */ |
/* printf("DEBUG ncovva=%d, Varying TvarAVVA[ncovva]=%d\n", ncovva, TvarAVVA[ncovva]); */ |
cotvarv=cotvar[mw[mi][i]][TvarVVA[ncovva]][i]; /* because cotvar starts now at first ncovcol+nqv+ntv+nqtv (1 to nqtv) */ |
cotvarv=cotvar[mw[mi][i]][TvarAVVA[ncovva]][i]; /* because cotvar starts now at first ncovcol+nqv+ntv+nqtv (1 to nqtv) */ |
}else{ /* fixed covariate */ |
}else{ /* fixed covariate */ |
/* cotvarv=covar[Tvar[TvarFind[itv]]][i]; /\* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model *\/ */ |
/* cotvarv=covar[Tvar[TvarFind[itv]]][i]; /\* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model *\/ */ |
/* printf("DEBUG ncovva=%d, Fixed TvarVVA[ncovva]=%d agexact=%g\n", ncovva, TvarVVA[ncovva], agexact); */ |
/* printf("DEBUG ncovva=%d, Fixed TvarAVVA[ncovva]=%d\n", ncovva, TvarAVVA[ncovva]); */ |
cotvarv=covar[itv][i]; /* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model */ |
cotvarv=covar[itv][i]; /* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model */ |
} |
} |
if(ipos!=iposold){ /* Not a product or first of a product */ |
if(ipos!=iposold){ /* Not a product or first of a product */ |
Line 7088 double funcone( double *x)
|
Line 6192 double funcone( double *x)
|
cotvarv=cotvarv*cotvarvold; |
cotvarv=cotvarv*cotvarvold; |
} |
} |
iposold=ipos; |
iposold=ipos; |
|
/* printf("DEBUG Product cov[ioffset+ipos=%d] \n",ioffset+ipos); */ |
cov[ioffset+ipos]=cotvarv*agexact; |
cov[ioffset+ipos]=cotvarv*agexact; |
/* printf("DEBUG Product cov[ioffset+ipos=%d]=%g, agexact=%g.3 \n",ioffset+ipos,cov[ioffset+ipos], agexact); */ |
|
/* if(globpr) */ |
|
/* sprintf(labficresilk+strlen(labficresilk)," %g*age",cov[ioffset+ipos]); */ |
|
|
|
/* For products */ |
/* For products */ |
} |
} |
|
|
/* printf("i=%d,mi=%d,d=%d,mw[mi][i]=%d\n",i, mi,d,mw[mi][i]); */ |
/* printf("i=%d,mi=%d,d=%d,mw[mi][i]=%d\n",i, mi,d,mw[mi][i]); */ |
/* for(kk=1;kk<=ncovmodel;kk++){ */ |
|
/* printf(" %d=%11.6f",kk,cov[kk]); */ |
|
/* } */ |
|
/* printf("\n"); */ |
|
/* savm=pmij(pmmij,cov,ncovmodel,x,nlstate); */ |
/* savm=pmij(pmmij,cov,ncovmodel,x,nlstate); */ |
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
out=matprod2(newm,oldm,1,nlstate+ndeath,1,nlstate+ndeath, |
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
1,nlstate+ndeath,pmij(pmmij,cov,ncovmodel,x,nlstate)); |
Line 7160 double funcone( double *x)
|
Line 6257 double funcone( double *x)
|
%11.6f %11.6f %11.6f ", \ |
%11.6f %11.6f %11.6f ", \ |
num[i], agebegin, ageend, i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],weight[i]*gipmx/gsw, |
num[i], agebegin, ageend, i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],weight[i]*gipmx/gsw, |
2*weight[i]*lli,(s2==-1? -1: out[s1][s2]),(s2==-1? -1: savm[s1][s2])); |
2*weight[i]*lli,(s2==-1? -1: out[s1][s2]),(s2==-1? -1: savm[s1][s2])); |
|
/* printf("%09ld %6.1f %6.1f %6d %2d %2d %2d %2d %3d %15.6f %8.4f %8.3f\ */ |
/* printf("%09ld %6.1f %6.1f %6d %2d %2d %2d %2d %3d %15.6f %8.4f %8.3f\ */ |
|
/* %11.6f %11.6f %11.6f ", \ */ |
/* %11.6f %11.6f %11.6f ", \ */ |
/* num[i], agebegin, ageend, i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],weight[i]*gipmx/gsw, */ |
/* num[i], agebegin, ageend, i,s1,s2,mi,mw[mi][i],dh[mi][i],exp(lli),weight[i],weight[i]*gipmx/gsw, */ |
/* 2*weight[i]*lli,(s2==-1? -1: out[s1][s2]),(s2==-1? -1: savm[s1][s2])); */ |
/* 2*weight[i]*lli,(s2==-1? -1: out[s1][s2]),(s2==-1? -1: savm[s1][s2])); */ |
Line 7171 double funcone( double *x)
|
Line 6267 double funcone( double *x)
|
/* printf(" %10.6f",-ll[k]*gipmx/gsw); */ |
/* printf(" %10.6f",-ll[k]*gipmx/gsw); */ |
} |
} |
fprintf(ficresilk," %10.6f ", -llt); |
fprintf(ficresilk," %10.6f ", -llt); |
/* fprintf(ficresilk,"%s", labficresilk); */ |
|
/* printf(" %10.6f\n", -llt); */ |
/* printf(" %10.6f\n", -llt); */ |
/* if(debugILK){ /\* debugILK is set by a #d in a comment line *\/ */ |
/* if(debugILK){ /\* debugILK is set by a #d in a comment line *\/ */ |
/* fprintf(ficresilk,"%09ld ", num[i]); */ /* not necessary */ |
/* fprintf(ficresilk,"%09ld ", num[i]); */ /* not necessary */ |
Line 7189 double funcone( double *x)
|
Line 6284 double funcone( double *x)
|
} |
} |
iposold=ipos; |
iposold=ipos; |
} |
} |
for(ncovva=1, iposold=0; ncovva <= ncovvta ; ncovva++){ /* Time varying covariates with age including individual from products, product is computed dynamically */ |
|
itv=TvarVVA[ncovva]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, exploding product Vn*Vm into Vn and then Vm */ |
|
ipos=TvarVVAind[ncovva]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
|
fprintf(ficresilk," %g*age",cov[ioffset+ipos]); |
|
} |
|
/* if(FixedV[itv]!=0){ /\* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv *\/ */ |
|
/* cotvarv=cotvar[mw[mi][i]][TvarVVA[ncovva]][i]; /\* because cotvar starts now at first ncovcol+nqv+ntv+nqtv (1 to nqtv) *\/ */ |
|
/* }else{ /\* fixed covariate *\/ */ |
|
/* cotvarv=covar[itv][i]; /\* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model *\/ */ |
|
/* } */ |
|
/* if(ipos!=iposold){ /\* Not a product or first of a product *\/ */ |
|
/* cotvarvold=cotvarv; */ |
|
/* }else{ /\* A second product *\/ */ |
|
/* cotvarv=cotvarv*cotvarvold; */ |
|
/* } */ |
|
/* iposold=ipos; */ |
|
/* cov[ioffset+ipos]=cotvarv; */ |
|
/* /\* For products *\/ */ |
|
/* fprintf(ficresilk," %g*age",cotvarv);/\* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) *\/ */ |
|
/* } */ |
|
/* for (kk=1; kk<=cptcovage;kk++) { */ |
/* for (kk=1; kk<=cptcovage;kk++) { */ |
/* if(!FixedV[Tvar[Tage[kk]]]){ */ |
/* if(!FixedV[Tvar[Tage[kk]]]){ */ |
/* fprintf(ficresilk," %g*age",covar[Tvar[Tage[kk]]][i]); */ |
/* fprintf(ficresilk," %g*age",covar[Tvar[Tage[kk]]][i]); */ |
Line 7218 double funcone( double *x)
|
Line 6293 double funcone( double *x)
|
/* /\* printf(" %g*age",cotvar[mw[mi][i]][Tvar[Tage[kk]]][i]);/\\* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) *\\/ *\/ */ |
/* /\* printf(" %g*age",cotvar[mw[mi][i]][Tvar[Tage[kk]]][i]);/\\* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) *\\/ *\/ */ |
/* } */ |
/* } */ |
/* } */ |
/* } */ |
|
for(ncovva=1, iposold=0; ncovva <= ncovta ; ncovva++){ /* Time varying covariates with age including individual from products, product is computed dynamically */ |
|
itv=TvarAVVA[ncovva]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, exploding product Vn*Vm into Vn and then Vm */ |
|
ipos=TvarAVVAind[ncovva]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
|
/* if(TvarFind[itv]==0){ /\* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv *\/ */ |
|
if(FixedV[itv]!=0){ /* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv */ |
|
/* printf("DEBUG ncovva=%d, Varying TvarAVVA[ncovva]=%d\n", ncovva, TvarAVVA[ncovva]); */ |
|
cotvarv=cotvar[mw[mi][i]][TvarAVVA[ncovva]][i]; /* because cotvar starts now at first ncovcol+nqv+ntv+nqtv (1 to nqtv) */ |
|
}else{ /* fixed covariate */ |
|
/* cotvarv=covar[Tvar[TvarFind[itv]]][i]; /\* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model *\/ */ |
|
/* printf("DEBUG ncovva=%d, Fixed TvarAVVA[ncovva]=%d\n", ncovva, TvarAVVA[ncovva]); */ |
|
cotvarv=covar[itv][i]; /* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model */ |
|
} |
|
if(ipos!=iposold){ /* Not a product or first of a product */ |
|
cotvarvold=cotvarv; |
|
}else{ /* A second product */ |
|
/* printf("DEBUG * \n"); */ |
|
cotvarv=cotvarv*cotvarvold; |
|
} |
|
cotvarv=cotvarv*agexact; |
|
fprintf(ficresilk," %g*age",cotvarv); |
|
iposold=ipos; |
|
/* printf("DEBUG Product cov[ioffset+ipos=%d] \n",ioffset+ipos); */ |
|
cov[ioffset+ipos]=cotvarv; |
|
/* For products */ |
|
} |
/* printf("\n"); */ |
/* printf("\n"); */ |
/* } /\* End debugILK *\/ */ |
/* } /\* End debugILK *\/ */ |
fprintf(ficresilk,"\n"); |
fprintf(ficresilk,"\n"); |
/* printf("\n"); */ |
|
} /* End if globpr */ |
} /* End if globpr */ |
} /* end of wave */ |
} /* end of wave */ |
} /* end of individual */ |
} /* end of individual */ |
Line 7245 void likelione(FILE *ficres,double p[],
|
Line 6344 void likelione(FILE *ficres,double p[],
|
Plotting could be done. |
Plotting could be done. |
*/ |
*/ |
void pstamp(FILE *ficres); |
void pstamp(FILE *ficres); |
int k, kf, kk, kvar, kvarold, ncovv, iposold, ipos, itv; |
int k, kf, kk, kvar, ncovv, iposold, ipos; |
|
|
if(*globpri !=0){ /* Just counts and sums, no printings */ |
if(*globpri !=0){ /* Just counts and sums, no printings */ |
strcpy(fileresilk,"ILK_"); |
strcpy(fileresilk,"ILK_"); |
Line 7263 void likelione(FILE *ficres,double p[],
|
Line 6362 void likelione(FILE *ficres,double p[],
|
fprintf(ficresilk," -2*gipw/gsw*weight*ll(total) "); |
fprintf(ficresilk," -2*gipw/gsw*weight*ll(total) "); |
|
|
/* if(debugILK){ /\* debugILK is set by a #d in a comment line *\/ */ |
/* if(debugILK){ /\* debugILK is set by a #d in a comment line *\/ */ |
for(kf=1;kf <= ncovf; kf++){ /* Fixed covariates */ |
for(kf=1;kf <= ncovf; kf++){ |
fprintf(ficresilk,"V%d",Tvar[TvarFind[kf]]); |
fprintf(ficresilk,"V%d",Tvar[TvarFind[kf]]); |
/* printf("V%d",Tvar[TvarFind[kf]]); */ |
/* printf("V%d",Tvar[TvarFind[kf]]); */ |
} |
|
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ /* Time varying covariates V6 V7 V7*V2 V6*V3 V7*V3 V6*V4 V7*V4 Time varying covariates (single and extended product but no age) including individual from products, product is computed dynamically */ |
|
itv=TvarVV[ncovv]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, or fixed covariate of a varying product after exploding product Vn*Vm into Vn and then Vm */ |
|
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate */ |
|
if(FixedV[itv]!=0){ /* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv */ |
|
kvar=TvarVV[ncovv]; |
|
}else{ |
|
kvar=itv; |
|
} |
} |
if(ipos!=iposold){ /* Not a product or first of a product */ |
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ |
kvarold=kvar; |
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate */ |
/* printf(" %d",ipos); */ |
if(ipos!=iposold){ /* Not a product or first of a product */ |
fprintf(ficresilk," V%d",kvarold); |
/* printf(" %d",ipos); */ |
}else{ /* a second product */ |
fprintf(ficresilk," V%d",TvarVV[ncovv]); |
/* printf("*"); */ |
}else{ |
fprintf(ficresilk,"*"); |
/* printf("*"); */ |
fprintf(ficresilk," V%d",kvar); |
fprintf(ficresilk,"*"); |
} |
} |
iposold=ipos; |
iposold=ipos; |
} |
} |
for (kk=1; kk<=cptcovprodage;kk++) { /* Fixed Covariates with age + age*V3*V2 +age*V2 +age*V3 +age*V4 For age product with simple covariates or product of fixed covariates */ |
for (kk=1; kk<=cptcovage;kk++) { |
ipos=Tage[kk]; |
if(!FixedV[Tvar[Tage[kk]]]){ |
if(!FixedV[Tvar[Tage[kk]]]){/* age*V3*V2 +age*V2 +age*V3 +age*V4 Fixed covariate with age age*V3 or age*V2*V3 Tvar[Tage[kk]] has its own already calculated column */ |
/* printf(" %d*age(Fixed)",Tvar[Tage[kk]]); */ |
/* printf(" %d*age(Fixed)",Tvar[Tage[kk]]); */ |
fprintf(ficresilk," %d*age(Fixed)",Tvar[Tage[kk]]); |
fprintf(ficresilk," %d*age(Fixed)",Tvar[Tage[kk]]); |
}else{ |
}else{ |
fprintf(ficresilk," %d*age(Varying)",Tvar[Tage[kk]]);/* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) */ |
fprintf(ficresilk," %d*age(Varying)",Tvar[Tage[kk]]);/* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) */ |
/* printf(" %d*age(Varying)",Tvar[Tage[kk]]);/\* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) *\/ */ |
/* printf(" %d*age(Varying)",Tvar[Tage[kk]]);/\* because cotvar starts now at first ncovcol+nqv+ (1 to nqtv) *\/ */ |
} |
} |
} |
} |
|
for(ncovva=1, iposold=0; ncovva <= ncovvta ; ncovva++){ /* +age*V6 + age*V7 +age*V6*V3 +age*V7*V3 + age*V6*V4 +age*V7*V4 Time varying covariates with age including individual from products, product is computed dynamically */ |
|
itv=TvarVVA[ncovva]; /* TvarVV={3, 1, 3} gives the name of each varying covariate, exploding product Vn*Vm into Vn and then Vm */ |
|
ipos=TvarVVAind[ncovva]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate*/ |
|
/* if(TvarFind[itv]==0){ /\* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv *\/ */ |
|
if(FixedV[itv]!=0){ /* Not a fixed covariate? Could be a fixed covariate of a product with a higher than ncovcol+nqv, itv */ |
|
/* printf("DEBUG ncovva=%d, Varying TvarVVA[ncovva]=%d agexact=%g\n", ncovva, TvarVVA[ncovva], agexact); */ |
|
kvar=TvarVVA[ncovva]; |
|
/* cotvarv=cotvar[mw[mi][i]][TvarVVA[ncovva]][i]; /\* because cotvar starts now at first ncovcol+nqv+ntv+nqtv (1 to nqtv) *\/ */ |
|
}else{ /* fixed covariate */ |
|
/* cotvarv=covar[Tvar[TvarFind[itv]]][i]; /\* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model *\/ */ |
|
/* printf("DEBUG ncovva=%d, Fixed TvarVVA[ncovva]=%d agexact=%g\n", ncovva, TvarVVA[ncovva], agexact); */ |
|
kvar=itv; |
|
/* cotvarv=covar[itv][i]; /\* Error: TvarFind gives the name, that is the true column of fixed covariates, but Tvar of the model *\/ */ |
|
} |
|
if(ipos!=iposold){ /* Not a product or first of a product */ |
|
kvarold=kvar; |
|
fprintf(ficresilk," age*V%d",kvarold); |
|
}else{ /* a second product */ |
|
/* printf("*"); */ |
|
fprintf(ficresilk," *V%d",kvar); |
|
/* printf("DEBUG * \n"); */ |
|
} |
|
iposold=ipos; |
|
/* printf("DEBUG Product cov[ioffset+ipos=%d]=%g, agexact=%g.3 \n",ioffset+ipos,cov[ioffset+ipos], agexact); */ |
|
/* if(globpr) */ |
|
/* sprintf(labficresilk+strlen(labficresilk)," %g*age",cov[ioffset+ipos]); */ |
|
|
|
/* For products */ |
|
} |
|
/* } /\* End if debugILK *\/ */ |
/* } /\* End if debugILK *\/ */ |
/* printf("\n"); */ |
/* printf("\n"); */ |
fprintf(ficresilk,"\n"); |
fprintf(ficresilk,"\n"); |
Line 7349 void likelione(FILE *ficres,double p[],
|
Line 6410 void likelione(FILE *ficres,double p[],
|
fprintf(fichtm,"<br>- Probability p<sub>%dj</sub> by origin %d and destination j. Dot's sizes are related to corresponding weight: <a href=\"%s-p%dj.png\">%s-p%dj.png</a><br>\n \ |
fprintf(fichtm,"<br>- Probability p<sub>%dj</sub> by origin %d and destination j. Dot's sizes are related to corresponding weight: <a href=\"%s-p%dj.png\">%s-p%dj.png</a><br>\n \ |
<img src=\"%s-p%dj.png\">\n",k,k,subdirf2(optionfilefiname,"ILK_"),k,subdirf2(optionfilefiname,"ILK_"),k,subdirf2(optionfilefiname,"ILK_"),k); |
<img src=\"%s-p%dj.png\">\n",k,k,subdirf2(optionfilefiname,"ILK_"),k,subdirf2(optionfilefiname,"ILK_"),k,subdirf2(optionfilefiname,"ILK_"),k); |
for(kf=1; kf <= ncovf; kf++){ /* For each simple dummy covariate of the model */ |
for(kf=1; kf <= ncovf; kf++){ /* For each simple dummy covariate of the model */ |
/* kvar=Tvar[TvarFind[kf]]; */ /* variable */ |
kvar=Tvar[TvarFind[kf]]; /* variable */ |
fprintf(fichtm,"<br>- Probability p<sub>%dj</sub> by origin %d and destination j with colored covariate V%d. Same dot size of all points but with a different color for transitions with dummy variable V%d=1 at beginning of transition (keeping former color for V%d=0): <a href=\"%s-p%dj.png\">%s-p%dj.png</a><br> \ |
fprintf(fichtm,"<br>- Probability p<sub>%dj</sub> by origin %d and destination j with colored covariate V%d. Same dot size of all points but with a different color for transitions with dummy variable V%d=1 at beginning of transition (keeping former color for V%d=0): ",k,k,Tvar[TvarFind[kf]],Tvar[TvarFind[kf]],Tvar[TvarFind[kf]]); |
<img src=\"%s-p%dj-%d.png\">",k,k,Tvar[TvarFind[kf]],Tvar[TvarFind[kf]],Tvar[TvarFind[kf]],subdirf2(optionfilefiname,"ILK_"),k,subdirf2(optionfilefiname,"ILK_"),k,subdirf2(optionfilefiname,"ILK_"),k,Tvar[TvarFind[kf]]); |
fprintf(fichtm,"<a href=\"%s-p%dj-%d.png\">%s-p%dj-%d.png</a><br>",subdirf2(optionfilefiname,"ILK_"),k,kvar,subdirf2(optionfilefiname,"ILK_"),k,kvar); |
|
fprintf(fichtm,"<img src=\"%s-p%dj-%d.png\">",subdirf2(optionfilefiname,"ILK_"),k,Tvar[TvarFind[kf]]); |
} |
} |
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ /* Loop on the time varying extended covariates (with extension of Vn*Vm */ |
for(ncovv=1, iposold=0; ncovv <= ncovvt ; ncovv++){ /* Loop on the time varying extended covariates (with extension of Vn*Vm */ |
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate */ |
ipos=TvarVVind[ncovv]; /* TvarVVind={2, 5, 5] gives the position in the model of the ncovv th varying covariate */ |
Line 7410 void likelione(FILE *ficres,double p[],
|
Line 6472 void likelione(FILE *ficres,double p[],
|
|
|
void mlikeli(FILE *ficres,double p[], int npar, int ncovmodel, int nlstate, double ftol, double (*func)(double [])) |
void mlikeli(FILE *ficres,double p[], int npar, int ncovmodel, int nlstate, double ftol, double (*func)(double [])) |
{ |
{ |
int i,j,k, jk, jkk=0, iter=0; |
int i,j, jkk=0, iter=0; |
double **xi; |
double **xi; |
double fret; |
/*double fret;*/ |
double fretone; /* Only one call to likelihood */ |
/*double fretone;*/ /* Only one call to likelihood */ |
/* char filerespow[FILENAMELENGTH];*/ |
/* char filerespow[FILENAMELENGTH];*/ |
|
|
double * p1; /* Shifted parameters from 0 instead of 1 */ |
/*double * p1;*/ /* Shifted parameters from 0 instead of 1 */ |
#ifdef NLOPT |
#ifdef NLOPT |
int creturn; |
int creturn; |
nlopt_opt opt; |
nlopt_opt opt; |
Line 7429 void mlikeli(FILE *ficres,double p[], in
|
Line 6491 void mlikeli(FILE *ficres,double p[], in
|
|
|
|
|
xi=matrix(1,npar,1,npar); |
xi=matrix(1,npar,1,npar); |
for (i=1;i<=npar;i++) |
for (i=1;i<=npar;i++) /* Starting with canonical directions j=1,n xi[i=1,n][j] */ |
for (j=1;j<=npar;j++) |
for (j=1;j<=npar;j++) |
xi[i][j]=(i==j ? 1.0 : 0.0); |
xi[i][j]=(i==j ? 1.0 : 0.0); |
printf("Powell\n"); fprintf(ficlog,"Powell\n"); |
printf("Powell-prax\n"); fprintf(ficlog,"Powell-prax\n"); |
strcpy(filerespow,"POW_"); |
strcpy(filerespow,"POW_"); |
strcat(filerespow,fileres); |
strcat(filerespow,fileres); |
if((ficrespow=fopen(filerespow,"w"))==NULL) { |
if((ficrespow=fopen(filerespow,"w"))==NULL) { |
Line 7498 void mlikeli(FILE *ficres,double p[], in
|
Line 6560 void mlikeli(FILE *ficres,double p[], in
|
#else /* FLATSUP */ |
#else /* FLATSUP */ |
/* powell(p,xi,npar,ftol,&iter,&fret,func);*/ |
/* powell(p,xi,npar,ftol,&iter,&fret,func);*/ |
/* praxis ( t0, h0, n, prin, x, beale_f ); */ |
/* praxis ( t0, h0, n, prin, x, beale_f ); */ |
int prin=4; |
int prin=1; |
double h0=0.25; |
double h0=0.25; |
#include "praxis.h" |
double macheps; |
|
double fmin; |
|
macheps=pow(16.0,-13.0); |
|
/* #include "praxis.h" */ |
/* Be careful that praxis start at x[0] and powell start at p[1] */ |
/* Be careful that praxis start at x[0] and powell start at p[1] */ |
/* praxis ( ftol, h0, npar, prin, p, func ); */ |
/* praxis ( ftol, h0, npar, prin, p, func ); */ |
p1= (p+1); /* p *(p+1)@8 and p *(p1)@8 are equal p1[0]=p[1] */ |
/* p1= (p+1); */ /* p *(p+1)@8 and p *(p1)@8 are equal p1[0]=p[1] */ |
printf("Praxis \n"); |
printf("Praxis Gegenfurtner \n"); |
fprintf(ficlog, "Praxis \n");fflush(ficlog); |
fprintf(ficlog, "Praxis Gegenfurtner\n");fflush(ficlog); |
praxis ( ftol, h0, npar, prin, p1, func ); |
/* praxis ( ftol, h0, npar, prin, p1, func ); */ |
|
/* fmin = praxis(1.e-5,macheps, h, n, prin, x, func); */ |
|
fmin = praxis(ftol,macheps, h0, npar, prin, p, func); |
printf("End Praxis\n"); |
printf("End Praxis\n"); |
#endif /* FLATSUP */ |
#endif /* FLATSUP */ |
|
|
Line 8638 void prevalence(double ***probs, double
|
Line 7705 void prevalence(double ***probs, double
|
int i, m, jk, j1, bool, z1,j, iv; |
int i, m, jk, j1, bool, z1,j, iv; |
int mi; /* Effective wave */ |
int mi; /* Effective wave */ |
int iage; |
int iage; |
double agebegin, ageend; |
double agebegin; /*, ageend;*/ |
|
|
double **prop; |
double **prop; |
double posprop; |
double posprop; |
Line 8877 void concatwav(int wav[], int **dh, int
|
Line 7944 void concatwav(int wav[], int **dh, int
|
if(j==0) j=1; /* Survives at least one month after exam */ |
if(j==0) j=1; /* Survives at least one month after exam */ |
else if(j<0){ |
else if(j<0){ |
nberr++; |
nberr++; |
printf("Error! Negative delay (%d to death) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
printf("Error! Negative delay (%d to death) between waves %d and %d of individual %ld (around line %d) who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
j=1; /* Temporary Dangerous patch */ |
j=1; /* Temporary Dangerous patch */ |
printf(" We assumed that the date of interview was correct (and not the date of death) and postponed the death %d month(s) (one stepm) after the interview. You MUST fix the contradiction between dates.\n",stepm); |
printf(" We assumed that the date of interview was correct (and not the date of death) and postponed the death %d month(s) (one stepm) after the interview. You MUST fix the contradiction between dates.\n",stepm); |
fprintf(ficlog,"Error! Negative delay (%d to death) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
fprintf(ficlog,"Error! Negative delay (%d to death) between waves %d and %d of individual %ld (around line %d) who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
fprintf(ficlog," We assumed that the date of interview was correct (and not the date of death) and postponed the death %d month(s) (one stepm) after the interview. You MUST fix the contradiction between dates.\n",stepm); |
fprintf(ficlog," We assumed that the date of interview was correct (and not the date of death) and postponed the death %d month(s) (one stepm) after the interview. You MUST fix the contradiction between dates.\n",stepm); |
} |
} |
k=k+1; |
k=k+1; |
Line 8914 void concatwav(int wav[], int **dh, int
|
Line 7981 void concatwav(int wav[], int **dh, int
|
/*printf("%d %lf %d %d %d\n", i,agev[mw[mi][i]][i],j,s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]);*/ |
/*printf("%d %lf %d %d %d\n", i,agev[mw[mi][i]][i],j,s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]);*/ |
if(j<0){ |
if(j<0){ |
nberr++; |
nberr++; |
printf("Error! Negative delay (%d) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
printf("Error! Negative delay (%d) between waves %d and %d of individual %ld (around line %d) who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
fprintf(ficlog,"Error! Negative delay (%d) between waves %d and %d of individual %ld at line %d who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
fprintf(ficlog,"Error! Negative delay (%d) between waves %d and %d of individual %ld (around line %d) who is aged %.1f with statuses from %d to %d\n ",j,mw[mi][i],mw[mi+1][i],num[i], i,agev[mw[mi][i]][i],s[mw[mi][i]][i] ,s[mw[mi+1][i]][i]); |
} |
} |
sum=sum+j; |
sum=sum+j; |
} |
} |
Line 10107 void varprob(char optionfilefiname[], do
|
Line 9174 void varprob(char optionfilefiname[], do
|
double ***varpij; |
double ***varpij; |
|
|
strcpy(fileresprob,"PROB_"); |
strcpy(fileresprob,"PROB_"); |
strcat(fileresprob,fileres); |
strcat(fileresprob,fileresu); |
if((ficresprob=fopen(fileresprob,"w"))==NULL) { |
if((ficresprob=fopen(fileresprob,"w"))==NULL) { |
printf("Problem with resultfile: %s\n", fileresprob); |
printf("Problem with resultfile: %s\n", fileresprob); |
fprintf(ficlog,"Problem with resultfile: %s\n", fileresprob); |
fprintf(ficlog,"Problem with resultfile: %s\n", fileresprob); |
Line 10525 void printinghtml(char fileresu[], char
|
Line 9592 void printinghtml(char fileresu[], char
|
int popforecast, int mobilav, int prevfcast, int mobilavproj, int prevbcast, int estepm , \ |
int popforecast, int mobilav, int prevfcast, int mobilavproj, int prevbcast, int estepm , \ |
double jprev1, double mprev1,double anprev1, double dateprev1, double dateprojd, double dateback1, \ |
double jprev1, double mprev1,double anprev1, double dateprev1, double dateprojd, double dateback1, \ |
double jprev2, double mprev2,double anprev2, double dateprev2, double dateprojf, double dateback2){ |
double jprev2, double mprev2,double anprev2, double dateprev2, double dateprojf, double dateback2){ |
int jj1, k1, i1, cpt, k4, nres; |
int jj1, k1, cpt, nres; |
/* In fact some results are already printed in fichtm which is open */ |
/* In fact some results are already printed in fichtm which is open */ |
fprintf(fichtm,"<ul><li><a href='#firstorder'>Result files (first order: no variance)</a>\n \ |
fprintf(fichtm,"<ul><li><a href='#firstorder'>Result files (first order: no variance)</a>\n \ |
<li><a href='#secondorder'>Result files (second order (variance)</a>\n \ |
<li><a href='#secondorder'>Result files (second order (variance)</a>\n \ |
Line 10662 divided by h: <sub>h</sub>P<sub>ij</sub>
|
Line 9729 divided by h: <sub>h</sub>P<sub>ij</sub>
|
<img src=\"%s_%d-3-%d.svg\">",stepm,subdirf2(optionfilefiname,"PE_"),k1,nres,subdirf2(optionfilefiname,"PE_"),k1,nres,subdirf2(optionfilefiname,"PE_"),k1,nres); |
<img src=\"%s_%d-3-%d.svg\">",stepm,subdirf2(optionfilefiname,"PE_"),k1,nres,subdirf2(optionfilefiname,"PE_"),k1,nres,subdirf2(optionfilefiname,"PE_"),k1,nres); |
/* Survival functions (period) in state j */ |
/* Survival functions (period) in state j */ |
for(cpt=1; cpt<=nlstate;cpt++){ |
for(cpt=1; cpt<=nlstate;cpt++){ |
fprintf(fichtm,"<br>\n- Survival functions in state %d. And probability to be observed in state %d being in state (1 to %d) at different ages. <a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a><br>", cpt, cpt, nlstate, subdirf2(optionfilefiname,"LIJ_"),cpt,k1,nres,subdirf2(optionfilefiname,"LIJ_"),cpt,k1,nres); |
fprintf(fichtm,"<br>\n- Survival functions in state %d. And probability to be observed in state %d being in state (1 to %d) at different ages. Mean times spent in state (or Life Expectancy or Health Expectancy etc.) are the areas under each curve. <a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a><br>", cpt, cpt, nlstate, subdirf2(optionfilefiname,"LIJ_"),cpt,k1,nres,subdirf2(optionfilefiname,"LIJ_"),cpt,k1,nres); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"PIJ_"),subdirf2(optionfilefiname,"PIJ_")); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"PIJ_"),subdirf2(optionfilefiname,"PIJ_")); |
fprintf(fichtm,"<img src=\"%s_%d-%d-%d.svg\">",subdirf2(optionfilefiname,"LIJ_"),cpt,k1,nres); |
fprintf(fichtm,"<img src=\"%s_%d-%d-%d.svg\">",subdirf2(optionfilefiname,"LIJ_"),cpt,k1,nres); |
} |
} |
/* State specific survival functions (period) */ |
/* State specific survival functions (period) */ |
for(cpt=1; cpt<=nlstate;cpt++){ |
for(cpt=1; cpt<=nlstate;cpt++){ |
fprintf(fichtm,"<br>\n- Survival functions in state %d and in any other live state (total).\ |
fprintf(fichtm,"<br>\n- Survival functions in state %d and in any other live state (total).\ |
And probability to be observed in various states (up to %d) being in state %d at different ages. \ |
And probability to be observed in various states (up to %d) being in state %d at different ages. Mean times spent in state (or Life Expectancy or Health Expectancy etc.) are the areas under each curve. \ |
<a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a><br> ", cpt, nlstate, cpt, subdirf2(optionfilefiname,"LIJT_"),cpt,k1,nres,subdirf2(optionfilefiname,"LIJT_"),cpt,k1,nres); |
<a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a><br> ", cpt, nlstate, cpt, subdirf2(optionfilefiname,"LIJT_"),cpt,k1,nres,subdirf2(optionfilefiname,"LIJT_"),cpt,k1,nres); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"PIJ_"),subdirf2(optionfilefiname,"PIJ_")); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"PIJ_"),subdirf2(optionfilefiname,"PIJ_")); |
fprintf(fichtm,"<img src=\"%s_%d-%d-%d.svg\">",subdirf2(optionfilefiname,"LIJT_"),cpt,k1,nres); |
fprintf(fichtm,"<img src=\"%s_%d-%d-%d.svg\">",subdirf2(optionfilefiname,"LIJT_"),cpt,k1,nres); |
} |
} |
/* Period (forward stable) prevalence in each health state */ |
/* Period (forward stable) prevalence in each health state */ |
for(cpt=1; cpt<=nlstate;cpt++){ |
for(cpt=1; cpt<=nlstate;cpt++){ |
fprintf(fichtm,"<br>\n- Convergence to period (stable) prevalence in state %d. Or probability for a person being in state (1 to %d) at different ages, to be in state %d some years after. <a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a><br>", cpt, nlstate, cpt, subdirf2(optionfilefiname,"P_"),cpt,k1,nres,subdirf2(optionfilefiname,"P_"),cpt,k1,nres); |
fprintf(fichtm,"<br>\n- Convergence to period (stable) prevalence in state %d. Or probability for a person being in state (1 to %d) at different ages, to be alive in state %d some years after. <a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a><br>", cpt, nlstate, cpt, subdirf2(optionfilefiname,"P_"),cpt,k1,nres,subdirf2(optionfilefiname,"P_"),cpt,k1,nres); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"PIJ_"),subdirf2(optionfilefiname,"PIJ_")); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"PIJ_"),subdirf2(optionfilefiname,"PIJ_")); |
fprintf(fichtm,"<img src=\"%s_%d-%d-%d.svg\">" ,subdirf2(optionfilefiname,"P_"),cpt,k1,nres); |
fprintf(fichtm,"<img src=\"%s_%d-%d-%d.svg\">" ,subdirf2(optionfilefiname,"P_"),cpt,k1,nres); |
} |
} |
Line 10701 divided by h: <sub>h</sub>P<sub>ij</sub>
|
Line 9768 divided by h: <sub>h</sub>P<sub>ij</sub>
|
/* Back projection of prevalence up to stable (mixed) back-prevalence in each health state */ |
/* Back projection of prevalence up to stable (mixed) back-prevalence in each health state */ |
for(cpt=1; cpt<=nlstate;cpt++){ |
for(cpt=1; cpt<=nlstate;cpt++){ |
fprintf(fichtm,"<br>\n- Back projection of cross-sectional prevalence (estimated with cases observed from %.1f to %.1f and mobil_average=%d), \ |
fprintf(fichtm,"<br>\n- Back projection of cross-sectional prevalence (estimated with cases observed from %.1f to %.1f and mobil_average=%d), \ |
from year %.1f up to year %.1f (probably close to stable [mixed] back prevalence in state %d (randomness in cross-sectional prevalence is not taken into \ |
from year %.1f up to year %.1f (probably close to stable [mixed] back prevalence in state %d). Randomness in cross-sectional prevalence is not taken into \ |
account but can visually be appreciated). Or probability to have been in an state %d, knowing that the person was in either state (1 or %d) \ |
account but can visually be appreciated. Or probability to have been in an state %d, knowing that the person was in either state (1 or %d) \ |
with weights corresponding to observed prevalence at different ages. <a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a>", dateprev1, dateprev2, mobilavproj, dateback1, dateback2, cpt, cpt, nlstate, subdirf2(optionfilefiname,"PROJB_"),cpt,k1,nres,subdirf2(optionfilefiname,"PROJB_"),cpt,k1,nres); |
with weights corresponding to observed prevalence at different ages. <a href=\"%s_%d-%d-%d.svg\">%s_%d-%d-%d.svg</a>", dateprev1, dateprev2, mobilavproj, dateback1, dateback2, cpt, cpt, nlstate, subdirf2(optionfilefiname,"PROJB_"),cpt,k1,nres,subdirf2(optionfilefiname,"PROJB_"),cpt,k1,nres); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"FB_"),subdirf2(optionfilefiname,"FB_")); |
fprintf(fichtm," (data from text file <a href=\"%s.txt\">%s.txt</a>)\n<br>",subdirf2(optionfilefiname,"FB_"),subdirf2(optionfilefiname,"FB_")); |
fprintf(fichtm," <img src=\"%s_%d-%d-%d.svg\">", subdirf2(optionfilefiname,"PROJB_"),cpt,k1,nres); |
fprintf(fichtm," <img src=\"%s_%d-%d-%d.svg\">", subdirf2(optionfilefiname,"PROJB_"),cpt,k1,nres); |
Line 10926 void printinggnuplot(char fileresu[], ch
|
Line 9993 void printinggnuplot(char fileresu[], ch
|
for(kf=1; kf <= ncovf; kf++){ /* For each simple dummy covariate of the model */ |
for(kf=1; kf <= ncovf; kf++){ /* For each simple dummy covariate of the model */ |
kvar=Tvar[TvarFind[kf]]; /* variable name */ |
kvar=Tvar[TvarFind[kf]]; /* variable name */ |
/* k=18+Tvar[TvarFind[kf]];/\*offset because there are 18 columns in the ILK_ file but could be placed else where *\/ */ |
/* k=18+Tvar[TvarFind[kf]];/\*offset because there are 18 columns in the ILK_ file but could be placed else where *\/ */ |
k=18+kf;/*offset because there are 18 columns in the ILK_ file */ |
/* k=18+kf;/\*offset because there are 18 columns in the ILK_ file *\/ */ |
|
/* k=19+kf;/\*offset because there are 19 columns in the ILK_ file *\/ */ |
|
k=16+nlstate+kf;/*offset because there are 19 columns in the ILK_ file, first cov Vn on col 21 with 4 living states */ |
for (i=1; i<= nlstate ; i ++) { |
for (i=1; i<= nlstate ; i ++) { |
fprintf(ficgp,"\nset out \"%s-p%dj-%d.png\";set ylabel \"Probability for each individual/wave\";",subdirf2(optionfilefiname,"ILK_"),i,kvar); |
fprintf(ficgp,"\nset out \"%s-p%dj-%d.png\";set ylabel \"Probability for each individual/wave\";",subdirf2(optionfilefiname,"ILK_"),i,kvar); |
fprintf(ficgp,"unset log;\n# For each simple dummy covariate of the model \n plot \"%s\"",subdirf(fileresilk)); |
fprintf(ficgp,"unset log;\n# For each simple dummy covariate of the model \n plot \"%s\"",subdirf(fileresilk)); |
Line 11612 set ter svg size 640, 480\nunset log y\n
|
Line 10681 set ter svg size 640, 480\nunset log y\n
|
fprintf(ficgp," u %d:(",ioffset); |
fprintf(ficgp," u %d:(",ioffset); |
kl=0; |
kl=0; |
strcpy(gplotcondition,"("); |
strcpy(gplotcondition,"("); |
for (k=1; k<=cptcoveff; k++){ /* For each covariate writing the chain of conditions */ |
/* for (k=1; k<=cptcoveff; k++){ /\* For each covariate writing the chain of conditions *\/ */ |
/* lv= decodtabm(k1,k,cptcoveff); /\* Should be the covariate value corresponding to combination k1 and covariate k *\/ */ |
/* lv= decodtabm(k1,k,cptcoveff); /\* Should be the covariate value corresponding to combination k1 and covariate k *\/ */ |
lv=codtabm(k1,TnsdVar[Tvaraff[k]]); |
for (k=1; k<=cptcovs; k++){ /* For each covariate k get corresponding value lv for combination k1 */ |
|
/* lv=codtabm(k1,TnsdVar[Tvaraff[k]]); */ |
|
lv=Tvresult[nres][k]; |
|
vlv=TinvDoQresult[nres][Tvresult[nres][k]]; |
/* decodtabm(1,1,4) = 1 because h=1 k= (1) 1 1 1 */ |
/* decodtabm(1,1,4) = 1 because h=1 k= (1) 1 1 1 */ |
/* decodtabm(1,2,4) = 1 because h=1 k= 1 (1) 1 1 */ |
/* decodtabm(1,2,4) = 1 because h=1 k= 1 (1) 1 1 */ |
/* decodtabm(13,3,4)= 2 because h=13 k= 1 1 (2) 2 */ |
/* decodtabm(13,3,4)= 2 because h=13 k= 1 1 (2) 2 */ |
/* vlv= nbcode[Tvaraff[k]][lv]; /\* Value of the modality of Tvaraff[k] *\/ */ |
/* vlv= nbcode[Tvaraff[k]][lv]; /\* Value of the modality of Tvaraff[k] *\/ */ |
vlv= nbcode[Tvaraff[k]][codtabm(k1,TnsdVar[Tvaraff[k]])]; |
/* vlv= nbcode[Tvaraff[k]][codtabm(k1,TnsdVar[Tvaraff[k]])]; */ |
kl++; |
kl++; |
sprintf(gplotcondition+strlen(gplotcondition),"$%d==%d && $%d==%d " ,kl,Tvaraff[k], kl+1, nbcode[Tvaraff[k]][lv]); |
/* sprintf(gplotcondition+strlen(gplotcondition),"$%d==%d && $%d==%d " ,kl,Tvaraff[k], kl+1, nbcode[Tvaraff[k]][lv]); */ |
|
sprintf(gplotcondition+strlen(gplotcondition),"$%d==%d && $%d==%d " ,kl,lv, kl+1, vlv ); |
kl++; |
kl++; |
if(k <cptcoveff && cptcoveff>1) |
if(k <cptcovs && cptcovs>1) |
sprintf(gplotcondition+strlen(gplotcondition)," && "); |
sprintf(gplotcondition+strlen(gplotcondition)," && "); |
} |
} |
strcpy(gplotcondition+strlen(gplotcondition),")"); |
strcpy(gplotcondition+strlen(gplotcondition),")"); |
Line 11707 set ter svg size 640, 480\nunset log y\n
|
Line 10780 set ter svg size 640, 480\nunset log y\n
|
}else{ |
}else{ |
fprintf(ficgp,",\\\n '' "); |
fprintf(ficgp,",\\\n '' "); |
} |
} |
if(cptcoveff ==0){ /* No covariate */ |
/* if(cptcoveff ==0){ /\* No covariate *\/ */ |
|
if(cptcovs ==0){ /* No covariate */ |
ioffset=2; /* Age is in 2 */ |
ioffset=2; /* Age is in 2 */ |
/*# yearproj age p11 p21 p31 p.1 p12 p22 p32 p.2 p13 p23 p33 p.3 p14 p24 p34 p.4*/ |
/*# yearproj age p11 p21 p31 p.1 p12 p22 p32 p.2 p13 p23 p33 p.3 p14 p24 p34 p.4*/ |
/*# 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 */ |
/*# 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 */ |
Line 11731 set ter svg size 640, 480\nunset log y\n
|
Line 10805 set ter svg size 640, 480\nunset log y\n
|
/*# 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 */ |
/*# 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 */ |
iyearc=ioffset-1; |
iyearc=ioffset-1; |
iagec=ioffset; |
iagec=ioffset; |
fprintf(ficgp," u %d:(",ioffset); /* PROBLEM HERE VERIFY */ |
fprintf(ficgp," u %d:(",ioffset); |
kl=0; |
kl=0; |
strcpy(gplotcondition,"("); |
strcpy(gplotcondition,"("); |
for (k=1; k<=cptcovs; k++){ /* For each covariate k of the resultline, get corresponding value lv for combination k1 */ |
for (k=1; k<=cptcovs; k++){ /* For each covariate k of the resultline, get corresponding value lv for combination k1 */ |
Line 11819 set ter svg size 640, 480\nunset log y\n
|
Line 10893 set ter svg size 640, 480\nunset log y\n
|
fprintf(ficgp,"#Number of graphics: first is logit, 2nd is probabilities, third is incidences per year\n"); |
fprintf(ficgp,"#Number of graphics: first is logit, 2nd is probabilities, third is incidences per year\n"); |
fprintf(ficgp,"#model=1+age+%s \n",model); |
fprintf(ficgp,"#model=1+age+%s \n",model); |
fprintf(ficgp,"# Type of graphic ng=%d\n",ng); |
fprintf(ficgp,"# Type of graphic ng=%d\n",ng); |
fprintf(ficgp,"# k1=1 to 2^%d=%d\n",cptcoveff,m);/* to be checked */ |
/* fprintf(ficgp,"# k1=1 to 2^%d=%d\n",cptcoveff,m);/\* to be checked *\/ */ |
|
fprintf(ficgp,"# k1=1 to 2^%d=%d\n",cptcovs,m);/* to be checked */ |
/* for(k1=1; k1 <=m; k1++) /\* For each combination of covariate *\/ */ |
/* for(k1=1; k1 <=m; k1++) /\* For each combination of covariate *\/ */ |
for(nres=1; nres <= nresult; nres++){ /* For each resultline */ |
for(nres=1; nres <= nresult; nres++){ /* For each resultline */ |
/* k1=nres; */ |
/* k1=nres; */ |
Line 11948 set ter svg size 640, 480\nunset log y\n
|
Line 11023 set ter svg size 640, 480\nunset log y\n
|
if(cptcovdageprod >0){ |
if(cptcovdageprod >0){ |
/* if(j==Tprod[ijp]) { */ /* not necessary */ |
/* if(j==Tprod[ijp]) { */ /* not necessary */ |
/* printf("Tprod[%d]=%d, j=%d\n", ij, Tprod[ijp], j); */ |
/* printf("Tprod[%d]=%d, j=%d\n", ij, Tprod[ijp], j); */ |
if(ijp <=cptcovprod) { /* Product */ |
if(ijp <=cptcovprod) { /* Product Vn*Vm and age*VN*Vm*/ |
if(DummyV[Tvard[ijp][1]]==0){/* Vn is dummy */ |
if(DummyV[Tvardk[ijp][1]]==0){/* Vn is dummy */ |
if(DummyV[Tvard[ijp][2]]==0){/* Vn and Vm are dummy */ |
if(DummyV[Tvardk[ijp][2]]==0){/* Vn and Vm are dummy */ |
/* fprintf(ficgp,"+p%d*%d*%d",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],nbcode[Tvard[ijp][2]][codtabm(k1,j)]); */ |
/* fprintf(ficgp,"+p%d*%d*%d",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],nbcode[Tvard[ijp][2]][codtabm(k1,j)]); */ |
fprintf(ficgp,"+p%d*%d*%d*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][1]],Tinvresult[nres][Tvard[ijp][2]]); |
fprintf(ficgp,"+p%d*%d*%d*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][1]],Tinvresult[nres][Tvard[ijp][2]]); |
}else{ /* Vn is dummy and Vm is quanti */ |
}else{ /* Vn is dummy and Vm is quanti */ |
/* fprintf(ficgp,"+p%d*%d*%f",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],Tqinvresult[nres][Tvard[ijp][2]]); */ |
/* fprintf(ficgp,"+p%d*%d*%f",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],Tqinvresult[nres][Tvard[ijp][2]]); */ |
fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); |
fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvardk[ijp][1]],Tqinvresult[nres][Tvardk[ijp][2]]); |
} |
} |
}else{ /* Vn*Vm Vn is quanti */ |
}else{ /* age* Vn*Vm Vn is quanti HERE */ |
if(DummyV[Tvard[ijp][2]]==0){ |
if(DummyV[Tvard[ijp][2]]==0){ |
fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][2]],Tqinvresult[nres][Tvard[ijp][1]]); |
fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvardk[ijp][2]],Tqinvresult[nres][Tvardk[ijp][1]]); |
}else{ /* Both quanti */ |
}else{ /* Both quanti */ |
fprintf(ficgp,"+p%d*%f*%f*x",i+j+2+nagesqr-1,Tqinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); |
fprintf(ficgp,"+p%d*%f*%f*x",i+j+2+nagesqr-1,Tqinvresult[nres][Tvardk[ijp][1]],Tqinvresult[nres][Tvardk[ijp][2]]); |
} |
} |
} |
} |
ijp++; |
ijp++; |
Line 12060 set ter svg size 640, 480\nunset log y\n
|
Line 11135 set ter svg size 640, 480\nunset log y\n
|
/* if(j==Tprod[ijp]) { /\* *\/ */ |
/* if(j==Tprod[ijp]) { /\* *\/ */ |
/* printf("Tprod[%d]=%d, j=%d\n", ij, Tprod[ijp], j); */ |
/* printf("Tprod[%d]=%d, j=%d\n", ij, Tprod[ijp], j); */ |
if(ijp <=cptcovprod) { /* Product */ |
if(ijp <=cptcovprod) { /* Product */ |
if(DummyV[Tvard[ijp][1]]==0){/* Vn is dummy */ |
if(DummyV[Tvardk[ijp][1]]==0){/* Vn is dummy */ |
if(DummyV[Tvard[ijp][2]]==0){/* Vn and Vm are dummy */ |
if(DummyV[Tvardk[ijp][2]]==0){/* Vn and Vm are dummy */ |
/* fprintf(ficgp,"+p%d*%d*%d",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],nbcode[Tvard[ijp][2]][codtabm(k1,j)]); */ |
/* fprintf(ficgp,"+p%d*%d*%d",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],nbcode[Tvard[ijp][2]][codtabm(k1,j)]); */ |
fprintf(ficgp,"+p%d*%d*%d*x",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tinvresult[nres][Tvard[ijp][1]],Tinvresult[nres][Tvard[ijp][2]]); |
fprintf(ficgp,"+p%d*%d*%d*x",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tinvresult[nres][Tvardk[ijp][1]],Tinvresult[nres][Tvardk[ijp][2]]); |
/* fprintf(ficgp,"+p%d*%d*%d",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][1]],Tinvresult[nres][Tvard[ijp][2]]); */ |
/* fprintf(ficgp,"+p%d*%d*%d",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][1]],Tinvresult[nres][Tvard[ijp][2]]); */ |
}else{ /* Vn is dummy and Vm is quanti */ |
}else{ /* Vn is dummy and Vm is quanti */ |
/* fprintf(ficgp,"+p%d*%d*%f",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],Tqinvresult[nres][Tvard[ijp][2]]); */ |
/* fprintf(ficgp,"+p%d*%d*%f",i+j+2+nagesqr-1,nbcode[Tvard[ijp][1]][codtabm(k1,j)],Tqinvresult[nres][Tvard[ijp][2]]); */ |
fprintf(ficgp,"+p%d*%d*%f*x",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); |
fprintf(ficgp,"+p%d*%d*%f*x",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tinvresult[nres][Tvardk[ijp][1]],Tqinvresult[nres][Tvardk[ijp][2]]); |
/* fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); */ |
/* fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); */ |
} |
} |
}else{ /* Vn*Vm Vn is quanti */ |
}else{ /* Vn*Vm Vn is quanti */ |
if(DummyV[Tvard[ijp][2]]==0){ |
if(DummyV[Tvardk[ijp][2]]==0){ |
fprintf(ficgp,"+p%d*%d*%f",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tinvresult[nres][Tvard[ijp][2]],Tqinvresult[nres][Tvard[ijp][1]]); |
fprintf(ficgp,"+p%d*%d*%f",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tinvresult[nres][Tvardk[ijp][2]],Tqinvresult[nres][Tvardk[ijp][1]]); |
/* fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][2]],Tqinvresult[nres][Tvard[ijp][1]]); */ |
/* fprintf(ficgp,"+p%d*%d*%f*x",i+j+2+nagesqr-1,Tinvresult[nres][Tvard[ijp][2]],Tqinvresult[nres][Tvard[ijp][1]]); */ |
}else{ /* Both quanti */ |
}else{ /* Both quanti */ |
fprintf(ficgp,"+p%d*%f*%f",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tqinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); |
fprintf(ficgp,"+p%d*%f*%f",k3+(cpt-1)*ncovmodel+1+j+nagesqr,Tqinvresult[nres][Tvardk[ijp][1]],Tqinvresult[nres][Tvardk[ijp][2]]); |
/* fprintf(ficgp,"+p%d*%f*%f*x",i+j+2+nagesqr-1,Tqinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); */ |
/* fprintf(ficgp,"+p%d*%f*%f*x",i+j+2+nagesqr-1,Tqinvresult[nres][Tvard[ijp][1]],Tqinvresult[nres][Tvard[ijp][2]]); */ |
} |
} |
} |
} |
Line 12381 void prevforecast(char fileres[], double
|
Line 11456 void prevforecast(char fileres[], double
|
*/ |
*/ |
/* double anprojd, mprojd, jprojd; */ |
/* double anprojd, mprojd, jprojd; */ |
/* double anprojf, mprojf, jprojf; */ |
/* double anprojf, mprojf, jprojf; */ |
int yearp, stepsize, hstepm, nhstepm, j, k, cptcod, i, h, i1, k4, nres=0; |
int yearp, stepsize, hstepm, nhstepm, j, k, i, h, nres=0; |
double agec; /* generic age */ |
double agec; /* generic age */ |
double agelim, ppij, yp,yp1,yp2; |
double agelim, ppij; |
double *popeffectif,*popcount; |
/*double *popcount;*/ |
double ***p3mat; |
double ***p3mat; |
/* double ***mobaverage; */ |
/* double ***mobaverage; */ |
char fileresf[FILENAMELENGTH]; |
char fileresf[FILENAMELENGTH]; |
Line 12437 void prevforecast(char fileres[], double
|
Line 11512 void prevforecast(char fileres[], double
|
/* date2dmy(dateintmean,&jintmean,&mintmean,&aintmean); */ |
/* date2dmy(dateintmean,&jintmean,&mintmean,&aintmean); */ |
/* date2dmy(dateprojd,&jprojd, &mprojd, &anprojd); */ |
/* date2dmy(dateprojd,&jprojd, &mprojd, &anprojd); */ |
/* date2dmy(dateprojf,&jprojf, &mprojf, &anprojf); */ |
/* date2dmy(dateprojf,&jprojf, &mprojf, &anprojf); */ |
i1=pow(2,cptcoveff); |
/* i1=pow(2,cptcoveff); */ |
if (cptcovn < 1){i1=1;} |
/* if (cptcovn < 1){i1=1;} */ |
|
|
fprintf(ficresf,"# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jintmean,mintmean,aintmean,dateintmean,dateprev1,dateprev2); |
fprintf(ficresf,"# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jintmean,mintmean,aintmean,dateintmean,dateprev1,dateprev2); |
|
|
fprintf(ficresf,"#****** Routine prevforecast **\n"); |
fprintf(ficresf,"#****** Routine prevforecast **\n"); |
|
|
/* if (h==(int)(YEARM*yearp)){ */ |
/* if (h==(int)(YEARM*yearp)){ */ |
for(nres=1; nres <= nresult; nres++) /* For each resultline */ |
for(nres=1; nres <= nresult; nres++){ /* For each resultline */ |
for(k=1; k<=i1;k++){ /* We want to find the combination k corresponding to the values of the dummies given in this resut line (to be cleaned one day) */ |
k=TKresult[nres]; |
if(i1 != 1 && TKresult[nres]!= k) |
if(TKresult[nres]==0) k=1; /* To be checked for noresult */ |
continue; |
/* for(k=1; k<=i1;k++){ /\* We want to find the combination k corresponding to the values of the dummies given in this resut line (to be cleaned one day) *\/ */ |
if(invalidvarcomb[k]){ |
/* if(i1 != 1 && TKresult[nres]!= k) */ |
printf("\nCombination (%d) projection ignored because no cases \n",k); |
/* continue; */ |
continue; |
/* if(invalidvarcomb[k]){ */ |
} |
/* printf("\nCombination (%d) projection ignored because no cases \n",k); */ |
|
/* continue; */ |
|
/* } */ |
fprintf(ficresf,"\n#****** hpijx=probability over h years, hp.jx is weighted by observed prev \n#"); |
fprintf(ficresf,"\n#****** hpijx=probability over h years, hp.jx is weighted by observed prev \n#"); |
for(j=1;j<=cptcoveff;j++) { |
for(j=1;j<=cptcovs;j++){ |
/* fprintf(ficresf," V%d (=) %d",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,Tvaraff[j])]); */ |
/* for(j=1;j<=cptcoveff;j++) { */ |
fprintf(ficresf," V%d (=) %d",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); |
/* /\* fprintf(ficresf," V%d (=) %d",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,Tvaraff[j])]); *\/ */ |
} |
/* fprintf(ficresf," V%d (=) %d",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); */ |
for (k4=1; k4<= nsq; k4++){ /* For each selected (single) quantitative value */ |
/* } */ |
fprintf(ficresf," V%d=%f ",Tvqresult[nres][k4],Tqresult[nres][k4]); |
/* for (k4=1; k4<= nsq; k4++){ /\* For each selected (single) quantitative value *\/ */ |
|
/* fprintf(ficresf," V%d=%f ",Tvqresult[nres][k4],Tqresult[nres][k4]); */ |
|
/* } */ |
|
fprintf(ficresf," V%d=%lg ",Tvresult[nres][j],TinvDoQresult[nres][Tvresult[nres][j]]); |
} |
} |
|
|
fprintf(ficresf," yearproj age"); |
fprintf(ficresf," yearproj age"); |
for(j=1; j<=nlstate+ndeath;j++){ |
for(j=1; j<=nlstate+ndeath;j++){ |
for(i=1; i<=nlstate;i++) |
for(i=1; i<=nlstate;i++) |
Line 12485 void prevforecast(char fileres[], double
|
Line 11566 void prevforecast(char fileres[], double
|
} |
} |
} |
} |
fprintf(ficresf,"\n"); |
fprintf(ficresf,"\n"); |
for(j=1;j<=cptcoveff;j++) |
/* for(j=1;j<=cptcoveff;j++) */ |
|
for(j=1;j<=cptcovs;j++) |
|
fprintf(ficresf,"%d %lg ",Tvresult[nres][j],TinvDoQresult[nres][Tvresult[nres][j]]); |
/* fprintf(ficresf,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,Tvaraff[j])]); /\* Tvaraff not correct *\/ */ |
/* fprintf(ficresf,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,Tvaraff[j])]); /\* Tvaraff not correct *\/ */ |
fprintf(ficresf,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); /* TnsdVar[Tvaraff] correct */ |
/* fprintf(ficresf,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); /\* TnsdVar[Tvaraff] correct *\/ */ |
fprintf(ficresf,"%.f %.f ",anprojd+yearp,agec+h*hstepm/YEARM*stepm); |
fprintf(ficresf,"%.f %.f ",anprojd+yearp,agec+h*hstepm/YEARM*stepm); |
|
|
for(j=1; j<=nlstate+ndeath;j++) { |
for(j=1; j<=nlstate+ndeath;j++) { |
Line 12524 void prevforecast(char fileres[], double
|
Line 11607 void prevforecast(char fileres[], double
|
anback2 year of end of backprojection (same day and month as back1). |
anback2 year of end of backprojection (same day and month as back1). |
prevacurrent and prev are prevalences. |
prevacurrent and prev are prevalences. |
*/ |
*/ |
int yearp, stepsize, hstepm, nhstepm, j, k, cptcod, i, h, i1, k4, nres=0; |
int yearp, stepsize, hstepm, nhstepm, j, k, i, h, nres=0; |
double agec; /* generic age */ |
double agec; /* generic age */ |
double agelim, ppij, ppi, yp,yp1,yp2; /* ,jintmean,mintmean,aintmean;*/ |
double agelim, ppij, ppi; /* ,jintmean,mintmean,aintmean;*/ |
double *popeffectif,*popcount; |
/*double *popcount;*/ |
double ***p3mat; |
double ***p3mat; |
/* double ***mobaverage; */ |
/* double ***mobaverage; */ |
char fileresfb[FILENAMELENGTH]; |
char fileresfb[FILENAMELENGTH]; |
Line 12579 void prevforecast(char fileres[], double
|
Line 11662 void prevforecast(char fileres[], double
|
/* if(jintmean==0) jintmean=1; */ |
/* if(jintmean==0) jintmean=1; */ |
/* if(mintmean==0) jintmean=1; */ |
/* if(mintmean==0) jintmean=1; */ |
|
|
i1=pow(2,cptcoveff); |
/* i1=pow(2,cptcoveff); */ |
if (cptcovn < 1){i1=1;} |
/* if (cptcovn < 1){i1=1;} */ |
|
|
fprintf(ficresfb,"# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jintmean,mintmean,aintmean,dateintmean,dateprev1,dateprev2); |
fprintf(ficresfb,"# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jintmean,mintmean,aintmean,dateintmean,dateprev1,dateprev2); |
printf("# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jintmean,mintmean,aintmean,dateintmean,dateprev1,dateprev2); |
printf("# Mean day of interviews %.lf/%.lf/%.lf (%.2f) between %.2f and %.2f \n",jintmean,mintmean,aintmean,dateintmean,dateprev1,dateprev2); |
|
|
fprintf(ficresfb,"#****** Routine prevbackforecast **\n"); |
fprintf(ficresfb,"#****** Routine prevbackforecast **\n"); |
|
|
for(nres=1; nres <= nresult; nres++) /* For each resultline */ |
for(nres=1; nres <= nresult; nres++){ /* For each resultline */ |
for(k=1; k<=i1;k++){ |
k=TKresult[nres]; |
if(i1 != 1 && TKresult[nres]!= k) |
if(TKresult[nres]==0) k=1; /* To be checked for noresult */ |
continue; |
/* for(k=1; k<=i1;k++){ */ |
if(invalidvarcomb[k]){ |
/* if(i1 != 1 && TKresult[nres]!= k) */ |
printf("\nCombination (%d) projection ignored because no cases \n",k); |
/* continue; */ |
continue; |
/* if(invalidvarcomb[k]){ */ |
} |
/* printf("\nCombination (%d) projection ignored because no cases \n",k); */ |
|
/* continue; */ |
|
/* } */ |
fprintf(ficresfb,"\n#****** hbijx=probability over h years, hb.jx is weighted by observed prev \n#"); |
fprintf(ficresfb,"\n#****** hbijx=probability over h years, hb.jx is weighted by observed prev \n#"); |
for(j=1;j<=cptcoveff;j++) { |
for(j=1;j<=cptcovs;j++){ |
fprintf(ficresfb," V%d (=) %d",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); |
/* for(j=1;j<=cptcoveff;j++) { */ |
} |
/* fprintf(ficresfb," V%d (=) %d",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); */ |
for (k4=1; k4<= nsq; k4++){ /* For each selected (single) quantitative value */ |
/* } */ |
fprintf(ficresf," V%d=%f ",Tvqresult[nres][k4],Tqresult[nres][k4]); |
fprintf(ficresfb," V%d=%lg ",Tvresult[nres][j],TinvDoQresult[nres][Tvresult[nres][j]]); |
} |
} |
|
/* fprintf(ficrespij,"******\n"); */ |
|
/* for (k4=1; k4<= nsq; k4++){ /\* For each selected (single) quantitative value *\/ */ |
|
/* fprintf(ficresfb," V%d=%f ",Tvqresult[nres][k4],Tqresult[nres][k4]); */ |
|
/* } */ |
fprintf(ficresfb," yearbproj age"); |
fprintf(ficresfb," yearbproj age"); |
for(j=1; j<=nlstate+ndeath;j++){ |
for(j=1; j<=nlstate+ndeath;j++){ |
for(i=1; i<=nlstate;i++) |
for(i=1; i<=nlstate;i++) |
Line 12632 void prevforecast(char fileres[], double
|
Line 11721 void prevforecast(char fileres[], double
|
} |
} |
} |
} |
fprintf(ficresfb,"\n"); |
fprintf(ficresfb,"\n"); |
for(j=1;j<=cptcoveff;j++) |
/* for(j=1;j<=cptcoveff;j++) */ |
fprintf(ficresfb,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); |
for(j=1;j<=cptcovs;j++) |
|
fprintf(ficresfb,"%d %lg ",Tvresult[nres][j],TinvDoQresult[nres][Tvresult[nres][j]]); |
|
/* fprintf(ficresfb,"%d %d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); */ |
fprintf(ficresfb,"%.f %.f ",anbackd+yearp,agec-h*hstepm/YEARM*stepm); |
fprintf(ficresfb,"%.f %.f ",anbackd+yearp,agec-h*hstepm/YEARM*stepm); |
for(i=1; i<=nlstate+ndeath;i++) { |
for(i=1; i<=nlstate+ndeath;i++) { |
ppij=0.;ppi=0.; |
ppij=0.;ppi=0.; |
Line 13202 void printinggnuplotmort(char fileresu[]
|
Line 12293 void printinggnuplotmort(char fileresu[]
|
|
|
char dirfileres[132],optfileres[132]; |
char dirfileres[132],optfileres[132]; |
|
|
int ng; |
/*int ng;*/ |
|
|
|
|
/*#ifdef windows */ |
/*#ifdef windows */ |
Line 13226 int readdata(char datafile[], int firsto
|
Line 12317 int readdata(char datafile[], int firsto
|
/*-------- data file ----------*/ |
/*-------- data file ----------*/ |
FILE *fic; |
FILE *fic; |
char dummy[]=" "; |
char dummy[]=" "; |
int i=0, j=0, n=0, iv=0, v; |
int i = 0, j = 0, n = 0, iv = 0;/* , v;*/ |
int lstra; |
int lstra; |
int linei, month, year,iout; |
int linei, month, year,iout; |
int noffset=0; /* This is the offset if BOM data file */ |
int noffset=0; /* This is the offset if BOM data file */ |
Line 13597 int decoderesult( char resultline[], int
|
Line 12688 int decoderesult( char resultline[], int
|
if (strlen(resultsav) >1){ |
if (strlen(resultsav) >1){ |
j=nbocc(resultsav,'='); /**< j=Number of covariate values'=' in this resultline */ |
j=nbocc(resultsav,'='); /**< j=Number of covariate values'=' in this resultline */ |
} |
} |
if(j == 0){ /* Resultline but no = */ |
if(j == 0 && cptcovs== 0){ /* Resultline but no = and no covariate in the model */ |
TKresult[nres]=0; /* Combination for the nresult and the model */ |
TKresult[nres]=0; /* Combination for the nresult and the model */ |
return (0); |
return (0); |
} |
} |
if( j != cptcovs ){ /* Be careful if a variable is in a product but not single */ |
if( j != cptcovs ){ /* Be careful if a variable is in a product but not single */ |
printf("ERROR: the number of variables in the resultline which is %d, differs from the number %d of single variables used in the model line, %s.\n",j, cptcovs, model); |
fprintf(ficlog,"ERROR: the number of variables in the resultline which is %d, differs from the number %d of single variables used in the model line, 1+age+%s.\n",j, cptcovs, model);fflush(ficlog); |
fprintf(ficlog,"ERROR: the number of variables in the resultline which is %d, differs from the number %d of single variables used in the model line, %s.\n",j, cptcovs, model); |
printf("ERROR: the number of variables in the resultline which is %d, differs from the number %d of single variables used in the model line, 1+age+%s.\n",j, cptcovs, model);fflush(stdout); |
/* return 1;*/ |
if(j==0) |
|
return 1; |
} |
} |
for(k=1; k<=j;k++){ /* Loop on any covariate of the RESULT LINE */ |
for(k=1; k<=j;k++){ /* Loop on any covariate of the RESULT LINE */ |
if(nbocc(resultsav,'=') >1){ |
if(nbocc(resultsav,'=') >1){ |
Line 13787 int decoderesult( char resultline[], int
|
Line 12879 int decoderesult( char resultline[], int
|
precov[nres][k1]=Tvalsel[k3q]; |
precov[nres][k1]=Tvalsel[k3q]; |
/* printf("Decoderesult Quantitative nres=%d,precov[nres=%d][k1=%d]=%.f V(k2q=V%d)= Tvalsel[%d]=%d, Tvarsel[%d]=%f\n",nres, nres, k1,precov[nres][k1], k2q, k3q, Tvarsel[k3q], k3q, Tvalsel[k3q]); */ |
/* printf("Decoderesult Quantitative nres=%d,precov[nres=%d][k1=%d]=%.f V(k2q=V%d)= Tvalsel[%d]=%d, Tvarsel[%d]=%f\n",nres, nres, k1,precov[nres][k1], k2q, k3q, Tvarsel[k3q], k3q, Tvalsel[k3q]); */ |
k4q++;; |
k4q++;; |
}else if( Dummy[k1]==2 ){ /* For dummy with age product */ |
}else if( Dummy[k1]==2 ){ /* For dummy with age product "V2+V3+V4+V6+V7+V6*V2+V7*V2+V6*V3+V7*V3+V6*V4+V7*V4+age*V2+age*V3+age*V4+age*V6+age*V7+age*V6*V2+age*V6*V3+age*V7*V3+age*V6*V4+age*V7*V4\r"*/ |
/* Tvar[k1]; */ /* Age variable */ |
/* Tvar[k1]; */ /* Age variable */ /* 17 age*V6*V2 ?*/ |
/* Wrong we want the value of variable name Tvar[k1] */ |
/* Wrong we want the value of variable name Tvar[k1] */ |
|
if(Typevar[k1]==2 || Typevar[k1]==3 ){ /* For product quant or dummy (with or without age) */ |
k3= resultmodel[nres][k1]; /* nres=1 k1=2 resultmodel[2(V4)] = 1=k3 ; k1=3 resultmodel[3(V3)] = 2=k3*/ |
precov[nres][k1]=TinvDoQresult[nres][Tvardk[k1][1]] * TinvDoQresult[nres][Tvardk[k1][2]]; |
k2=(int)Tvarsel[k3]; /* nres=1 k1=2=>k3=1 Tvarsel[resultmodel[2]]= Tvarsel[1] = 4=k2 (V4); k1=3=>k3=2 Tvarsel[2]=3 (V3)*/ |
/* printf("Decoderesult Quantitative or Dummy (not with age) nres=%d k1=%d precov[nres=%d][k1=%d]=%.f V%d(=%.f) * V%d(=%.f) \n",nres, k1, nres, k1,precov[nres][k1], Tvardk[k1][1], TinvDoQresult[nres][Tvardk[k1][1]], Tvardk[k1][2], TinvDoQresult[nres][Tvardk[k1][2]]); */ |
TinvDoQresult[nres][(int)Tvarsel[k3]]=Tvalsel[k3]; /* TinvDoQresult[nres][4]=1 */ |
}else{ |
precov[nres][k1]=Tvalsel[k3]; |
k3= resultmodel[nres][k1]; /* nres=1 k1=2 resultmodel[2(V4)] = 1=k3 ; k1=3 resultmodel[3(V3)] = 2=k3*/ |
|
k2=(int)Tvarsel[k3]; /* nres=1 k1=2=>k3=1 Tvarsel[resultmodel[2]]= Tvarsel[1] = 4=k2 (V4); k1=3=>k3=2 Tvarsel[2]=3 (V3)*/ |
|
TinvDoQresult[nres][(int)Tvarsel[k3]]=Tvalsel[k3]; /* TinvDoQresult[nres][4]=1 */ |
|
precov[nres][k1]=Tvalsel[k3]; |
|
} |
/* printf("Decoderesult Dummy with age k=%d, k1=%d precov[nres=%d][k1=%d]=%.f Tvar[%d]=V%d k2=Tvarsel[%d]=%d Tvalsel[%d]=%d\n",k, k1, nres, k1,precov[nres][k1], k1, Tvar[k1], k3,(int)Tvarsel[k3], k3, (int)Tvalsel[k3]); */ |
/* printf("Decoderesult Dummy with age k=%d, k1=%d precov[nres=%d][k1=%d]=%.f Tvar[%d]=V%d k2=Tvarsel[%d]=%d Tvalsel[%d]=%d\n",k, k1, nres, k1,precov[nres][k1], k1, Tvar[k1], k3,(int)Tvarsel[k3], k3, (int)Tvalsel[k3]); */ |
}else if( Dummy[k1]==3 ){ /* For quant with age product */ |
}else if( Dummy[k1]==3 ){ /* For quant with age product */ |
k3q= resultmodel[nres][k1]; /* resultmodel[1(V5)] = 25.1=k3q */ |
if(Typevar[k1]==2 || Typevar[k1]==3 ){ /* For product quant or dummy (with or without age) */ |
k2q=(int)Tvarsel[k3q]; /* Tvarsel[resultmodel[1]]= Tvarsel[1] = 4=k2 */ |
precov[nres][k1]=TinvDoQresult[nres][Tvardk[k1][1]] * TinvDoQresult[nres][Tvardk[k1][2]]; |
TinvDoQresult[nres][(int)Tvarsel[k3q]]=Tvalsel[k3q]; /* TinvDoQresult[nres][5]=25.1 */ |
/* printf("Decoderesult Quantitative or Dummy (not with age) nres=%d k1=%d precov[nres=%d][k1=%d]=%.f V%d(=%.f) * V%d(=%.f) \n",nres, k1, nres, k1,precov[nres][k1], Tvardk[k1][1], TinvDoQresult[nres][Tvardk[k1][1]], Tvardk[k1][2], TinvDoQresult[nres][Tvardk[k1][2]]); */ |
precov[nres][k1]=Tvalsel[k3q]; |
}else{ |
|
k3q= resultmodel[nres][k1]; /* resultmodel[1(V5)] = 25.1=k3q */ |
|
k2q=(int)Tvarsel[k3q]; /* Tvarsel[resultmodel[1]]= Tvarsel[1] = 4=k2 */ |
|
TinvDoQresult[nres][(int)Tvarsel[k3q]]=Tvalsel[k3q]; /* TinvDoQresult[nres][5]=25.1 */ |
|
precov[nres][k1]=Tvalsel[k3q]; |
|
} |
/* printf("Decoderesult Quantitative with age nres=%d, k1=%d, precov[nres=%d][k1=%d]=%f Tvar[%d]=V%d V(k2q=%d)= Tvarsel[%d]=%d, Tvalsel[%d]=%f\n",nres, k1, nres, k1,precov[nres][k1], k1, Tvar[k1], k2q, k3q, Tvarsel[k3q], k3q, Tvalsel[k3q]); */ |
/* printf("Decoderesult Quantitative with age nres=%d, k1=%d, precov[nres=%d][k1=%d]=%f Tvar[%d]=V%d V(k2q=%d)= Tvarsel[%d]=%d, Tvalsel[%d]=%f\n",nres, k1, nres, k1,precov[nres][k1], k1, Tvar[k1], k2q, k3q, Tvarsel[k3q], k3q, Tvalsel[k3q]); */ |
}else if(Typevar[k1]==2 || Typevar[k1]==3 ){ /* For product quant or dummy (with or without age) */ |
}else if(Typevar[k1]==2 || Typevar[k1]==3 ){ /* For product quant or dummy (with or without age) */ |
precov[nres][k1]=TinvDoQresult[nres][Tvardk[k1][1]] * TinvDoQresult[nres][Tvardk[k1][2]]; |
precov[nres][k1]=TinvDoQresult[nres][Tvardk[k1][1]] * TinvDoQresult[nres][Tvardk[k1][2]]; |
Line 13833 int decodemodel( char model[], int lasto
|
Line 12934 int decodemodel( char model[], int lasto
|
*/ |
*/ |
/* V2+V1+V4+V3*age Tvar[4]=3 ; V1+V2*age Tvar[2]=2; V1+V1*age Tvar[2]=1, Tage[1]=2 */ |
/* V2+V1+V4+V3*age Tvar[4]=3 ; V1+V2*age Tvar[2]=2; V1+V1*age Tvar[2]=1, Tage[1]=2 */ |
{ |
{ |
int i, j, k, ks, v; |
int i, j, k, ks;/* , v;*/ |
int n,m; |
int n,m; |
int j1, k1, k11, k12, k2, k3, k4; |
int j1, k1, k11, k12, k2, k3, k4; |
char modelsav[300]; |
char modelsav[300]; |
Line 13883 int decodemodel( char model[], int lasto
|
Line 12984 int decodemodel( char model[], int lasto
|
if (strlen(modelsav) >1){ /* V2 +V3 +V4 +V6 +V7 +V6*V2 +V7*V2 +V6*V3 +V7*V3 +V6*V4 +V7*V4 +age*V2 +age*V3 +age*V4 +age*V6 +age*V7 +age*V6*V2 +V7*V2 +age*V6*V3 +age*V7*V3 +age*V6*V4 +age*V7*V4 */ |
if (strlen(modelsav) >1){ /* V2 +V3 +V4 +V6 +V7 +V6*V2 +V7*V2 +V6*V3 +V7*V3 +V6*V4 +V7*V4 +age*V2 +age*V3 +age*V4 +age*V6 +age*V7 +age*V6*V2 +V7*V2 +age*V6*V3 +age*V7*V3 +age*V6*V4 +age*V7*V4 */ |
j=nbocc(modelsav,'+'); /**< j=Number of '+' */ |
j=nbocc(modelsav,'+'); /**< j=Number of '+' */ |
j1=nbocc(modelsav,'*'); /**< j1=Number of '*' */ |
j1=nbocc(modelsav,'*'); /**< j1=Number of '*' */ |
/* cptcovs=j+1-j1; */ /* is wrong , see after */ |
cptcovs=0; /**< Number of simple covariates V1 +V1*age +V3 +V3*V4 +age*age => V1 + V3 =4+1-3=2 Wrong */ |
cptcovt= j+1; /* Number of total covariates in the model, not including |
cptcovt= j+1; /* Number of total covariates in the model, not including |
* cst, age and age*age |
* cst, age and age*age |
* V1+V1*age+ V3 + V3*V4+age*age=> 3+1=4*/ |
* V1+V1*age+ V3 + V3*V4+age*age=> 3+1=4*/ |
/* including age products which are counted in cptcovage. |
/* including age products which are counted in cptcovage. |
* but the covariates which are products must be treated |
* but the covariates which are products must be treated |
* separately: ncovn=4- 2=2 (V1+V3). */ |
* separately: ncovn=4- 2=2 (V1+V3). */ |
cptcovprod=0; /**< Number of products and single product with age V1*V2 +v3*age = 2 */ |
cptcovprod=0; /**< Number of products V1*V2 +v3*age = 2 */ |
cptcovdageprod=0; /* Number of double products with age age*Vn*VM or Vn*age*Vm or Vn*Vm*age */ |
cptcovdageprod=0; /* Number of doouble products with age age*Vn*VM or Vn*age*Vm or Vn*Vm*age */ |
cptcovprodnoage=0; /**< Number of covariate products without age: V3*V4 =1 */ |
cptcovprodnoage=0; /**< Number of covariate products without age: V3*V4 =1 */ |
cptcovprodage=0; /**< Number of varying covariate products with age: age*V6(v)*V3(f) =1 */ |
cptcovprodage=0; |
/* cptcovprodage=nboccstr(modelsav,"age");*/ |
/* cptcovprodage=nboccstr(modelsav,"age");*/ |
|
|
/* Design |
/* Design |
Line 13948 int decodemodel( char model[], int lasto
|
Line 13049 int decodemodel( char model[], int lasto
|
Tvar[k]=0; Tprod[k]=0; Tposprod[k]=0; |
Tvar[k]=0; Tprod[k]=0; Tposprod[k]=0; |
} |
} |
cptcovage=0; |
cptcovage=0; |
|
|
|
/* First loop in order to calculate */ |
|
/* for age*VN*Vm |
|
* Provides, Typevar[k], Tage[cptcovage], existcomb[n][m], FixedV[ncovcolt+k12] |
|
* Tprod[k1]=k Tposprod[k]=k1; Tvard[k1][1] =m; |
|
*/ |
|
/* Needs FixedV[Tvardk[k][1]] */ |
|
/* For others: |
|
* Sets Typevar[k]; |
|
* Tvar[k]=ncovcol+nqv+ntv+nqtv+k11; |
|
* Tposprod[k]=k11; |
|
* Tprod[k11]=k; |
|
* Tvardk[k][1] =m; |
|
* Needs FixedV[Tvardk[k][1]] == 0 |
|
*/ |
|
|
for(k=1; k<=cptcovt;k++){ /* Loop on total covariates of the model line */ |
for(k=1; k<=cptcovt;k++){ /* Loop on total covariates of the model line */ |
cutl(stra,strb,modelsav,'+'); /* keeps in strb after the first '+' cutl from left to right |
cutl(stra,strb,modelsav,'+'); /* keeps in strb after the first '+' cutl from left to right |
modelsav==V2+V1+V5*age+V4+V3*age strb=V3*age stra=V2+V1V5*age+V4 */ /* <model> "V5+V4+V3+V4*V3+V5*age+V1*age+V1" strb="V5" stra="V4+V3+V4*V3+V5*age+V1*age+V1" */ |
modelsav==V2+V1+V5*age+V4+V3*age strb=V3*age stra=V2+V1V5*age+V4 */ /* <model> "V5+V4+V3+V4*V3+V5*age+V1*age+V1" strb="V5" stra="V4+V3+V4*V3+V5*age+V1*age+V1" */ |
Line 13956 int decodemodel( char model[], int lasto
|
Line 13073 int decodemodel( char model[], int lasto
|
/* printf("i=%d a=%s b=%s sav=%s\n",i, stra,strb,modelsav);*/ |
/* printf("i=%d a=%s b=%s sav=%s\n",i, stra,strb,modelsav);*/ |
/*scanf("%d",i);*/ |
/*scanf("%d",i);*/ |
if (strchr(strb,'*')) { /**< Model includes a product V2+V1+V5*age+ V4+V3*age strb=V3*age OR double product with age strb=age*V6*V2 or V6*V2*age or V6*age*V2 */ |
if (strchr(strb,'*')) { /**< Model includes a product V2+V1+V5*age+ V4+V3*age strb=V3*age OR double product with age strb=age*V6*V2 or V6*V2*age or V6*age*V2 */ |
cutl(strc,strd,strb,'*'); /**< k=1 strd*strc Vm*Vn: strb=V3*age(input) strc=age strd=V3 ; V3*V2 strc=V2, strd=V3 OR strb=age*V6*V2 strc=V6*V2 strd=age OR strb=V6*age*V2 c=age*V2 d=V6 OR b=V6*V2*age c=V2*age d=V6 */ |
cutl(strc,strd,strb,'*'); /**< k=1 strd*strc Vm*Vn: strb=V3*age(input) strc=age strd=V3 ; V3*V2 strc=V2, strd=V3 OR strb=age*V6*V2 strc=V6*V2 strd=age OR c=V2*age OR c=age*V2 */ |
if(strchr(strc,'*')) { /**< Model with age and DOUBLE product: allowed since 0.99r44, strc=V6*V2 or V2*age or age*V2, strd=age or V6 or V6 OR (strb=age*V6*V2 or V6*V2*age or V6*age*V2) */ |
if(strchr(strc,'*')) { /**< Model with age and DOUBLE product: allowed since 0.99r44, strc=V6*V2 or V2*age or age*V2, strd=age or V6 or V6 */ |
Typevar[k]=3; /* 3 for age and double product age*Vn*Vm varying of fixed */ |
Typevar[k]=3; /* 3 for age and double product age*Vn*Vm varying of fixed */ |
if(strstr(strc,"age")!=0) { /* It means that strc=V2*age=Vm*age or age*V2 (not V6*V2) and thus that strd=Vn and strb=V6*V2*age or V6*age*V2 (but not age*V6*V2) */ |
if(strstr(strc,"age")!=0) { /* It means that strc=V2*age or age*V2 and thus that strd=Vn */ |
cutl(stre,strf,strc,'*') ; /* if strc=age*Vm then stre=Vm and strf=age, if strc=Vm*age then stre=age and strf=Vm. */ |
cutl(stre,strf,strc,'*') ; /* strf=age or Vm, stre=Vm or age. If strc=V6*V2 then strf=V6 and stre=V2 */ |
strcpy(strc,strb); /* save strb(=age*Vn*Vm) into strc , strd=Vn */ |
strcpy(strc,strb); /* save strb(=age*Vn*Vm) into strc */ |
/* We want strb=Vn*Vm */ |
/* We want strb=Vn*Vm */ |
if(strcmp(strf,"age")==0){ /* strf is "age" so stre=Vm =V2 (strc=age*Vm and strb Vn*age*Vm) . */ |
if(strcmp(strf,"age")==0){ /* strf is "age" so that stre=Vm =V2 . */ |
strcpy(strb,strd); /* strd=Vn */ |
strcpy(strb,strd); |
strcat(strb,"*"); |
strcat(strb,"*"); |
strcat(strb,stre);/* strb=Vn*Vm */ |
strcat(strb,stre); |
}else{ /* strf=Vm so stre=age. strd=Vn If strf=V6 then stre=V2 */ |
}else{ /* strf=Vm If strf=V6 then stre=V2 */ |
strcpy(strb,strf); |
strcpy(strb,strf); |
strcat(strb,"*"); |
strcat(strb,"*"); |
strcat(strb,strd); /* strb=Vm*Vn */ |
strcat(strb,stre); |
strcpy(strd,strb); /* in order for strd to not be "age" for next test (will be strd=Vn*Vm */ |
strcpy(strd,strb); /* in order for strd to not be "age" for next test (will be Vn*Vm */ |
} |
} |
printf("DEBUG FIXED k=%d, Tage[k]=%d, Tvar[Tage[k]=%d,FixedV[Tvar[Tage[k]]]=%d\n",k,Tage[k],Tvar[Tage[k]],FixedV[Tvar[Tage[k]]]); |
/* printf("DEBUG FIXED k=%d, Tage[k]=%d, Tvar[Tage[k]=%d,FixedV[Tvar[Tage[k]]]=%d\n",k,Tage[k],Tvar[Tage[k]],FixedV[Tvar[Tage[k]]]); */ |
/* FixedV[Tvar[Tage[k]]]=0;*/ /* HERY not sure */ |
/* FixedV[Tvar[Tage[k]]]=0; /\* HERY not sure if V7*V4*age Fixed might not exist yet*\/ */ |
}else{ /* strb=age*Vn*Vm strc=Vn*Vm (and strd=age) and should be strb=Vn*Vm but want to keep original strb double product */ |
}else{ /* strc=Vn*Vm (and strd=age) and should be strb=Vn*Vm but want to keep original strb double product */ |
strcpy(stre,strb); /* save full b in stre */ |
strcpy(stre,strb); /* save full b in stre */ |
strcpy(strb,strc); /* save short c in new short b for next block strb=Vn*Vm*/ |
strcpy(strb,strc); /* save short c in new short b for next block strb=Vn*Vm*/ |
strcpy(strf,strc); /* save short c in new short f */ |
strcpy(strf,strc); /* save short c in new short f */ |
Line 14007 int decodemodel( char model[], int lasto
|
Line 13124 int decodemodel( char model[], int lasto
|
Tvardk[k][1] =m; /* m 1 for V1*/ |
Tvardk[k][1] =m; /* m 1 for V1*/ |
Tvard[k1][2] =n; /* n 4 for V4*/ |
Tvard[k1][2] =n; /* n 4 for V4*/ |
Tvardk[k][2] =n; /* n 4 for V4*/ |
Tvardk[k][2] =n; /* n 4 for V4*/ |
/* Tvar[Tage[cptcovage]]=k1;*/ /* Tvar[6=age*V3*V2]=9 (new fixed covariate) */ |
/* Tvar[Tage[cptcovage]]=k1;*/ /* Tvar[6=age*V3*V2]=9 (new fixed covariate) */ /* We don't know about Fixed yet HERE */ |
if( FixedV[Tvardk[k][1]] == 0 && FixedV[Tvardk[k][2]] == 0){ /* If the product is a fixed covariate then we feed the new column with Vn*Vm */ |
if( FixedV[Tvardk[k][1]] == 0 && FixedV[Tvardk[k][2]] == 0){ /* If the product is a fixed covariate then we feed the new column with Vn*Vm */ |
for (i=1; i<=lastobs;i++){/* For fixed product */ |
for (i=1; i<=lastobs;i++){/* For fixed product */ |
/* Computes the new covariate which is a product of |
/* Computes the new covariate which is a product of |
Line 14043 int decodemodel( char model[], int lasto
|
Line 13160 int decodemodel( char model[], int lasto
|
/*Tage[cptcovage]=k;*/ /* For age*V3*V2 Tage[1]=V3*V3=9 HERY too*/ |
/*Tage[cptcovage]=k;*/ /* For age*V3*V2 Tage[1]=V3*V3=9 HERY too*/ |
/* Tvar[Tage[cptcovage]]=k1; */ |
/* Tvar[Tage[cptcovage]]=k1; */ |
cptcovprodvage++; |
cptcovprodvage++; |
k12=2*k11-1; |
|
FixedV[ncovcolt+k12]=1; /* We expand Vn*Vm */ |
FixedV[ncovcolt+k12]=1; /* We expand Vn*Vm */ |
FixedV[ncovcolt+k12+1]=1; |
k12++; |
|
FixedV[ncovcolt+k12]=1; |
} |
} |
} |
} |
/* Tage[cptcovage]=k; /\* V2+V1+V4+V3*age Tvar[4]=3, Tage[1] = 4 or V1+V1*age Tvar[2]=1, Tage[1]=2 *\/ */ |
/* Tage[cptcovage]=k; /\* V2+V1+V4+V3*age Tvar[4]=3, Tage[1] = 4 or V1+V1*age Tvar[2]=1, Tage[1]=2 *\/ */ |
Line 14157 int decodemodel( char model[], int lasto
|
Line 13274 int decodemodel( char model[], int lasto
|
/*printf("a=%s b=%s sav=%s\n", stra,strb,modelsav); |
/*printf("a=%s b=%s sav=%s\n", stra,strb,modelsav); |
scanf("%d",i);*/ |
scanf("%d",i);*/ |
} /* end of loop + on total covariates */ |
} /* end of loop + on total covariates */ |
|
|
|
|
} /* end if strlen(modelsave == 0) age*age might exist */ |
} /* end if strlen(modelsave == 0) age*age might exist */ |
} /* end if strlen(model == 0) */ |
} /* end if strlen(model == 0) */ |
cptcovs=cptcovt - cptcovdageprod - cptcovprod;/**< Number of simple covariates V1 +V1*age +V3 +V3*V4 +age*age + age*v4*V3=> V1 + V3 =4+1-3=2 */ |
cptcovs=cptcovt - cptcovdageprod - cptcovprod;/**< Number of simple covariates V1 +V1*age +V3 +V3*V4 +age*age + age*v4*V3=> V1 + V3 =4+1-3=2 */ |
Line 14195 Fixed[k] 0=fixed (product or simple), 1
|
Line 13314 Fixed[k] 0=fixed (product or simple), 1
|
Dummy[k] 0=dummy (0 1), 1 quantitative (single or product without age), 2 dummy with age product, 3 quant with age product\n",model); |
Dummy[k] 0=dummy (0 1), 1 quantitative (single or product without age), 2 dummy with age product, 3 quant with age product\n",model); |
for(k=-1;k<=NCOVMAX; k++){ Fixed[k]=0; Dummy[k]=0;} |
for(k=-1;k<=NCOVMAX; k++){ Fixed[k]=0; Dummy[k]=0;} |
for(k=1;k<=NCOVMAX; k++){TvarFind[k]=0; TvarVind[k]=0;} |
for(k=1;k<=NCOVMAX; k++){TvarFind[k]=0; TvarVind[k]=0;} |
|
|
|
|
|
/* Second loop for calculating Fixed[k], Dummy[k]*/ |
|
|
|
|
for(k=1, ncovf=0, nsd=0, nsq=0, ncovv=0,ncovva=0,ncovvta=0, ncova=0, ncoveff=0, nqfveff=0, ntveff=0, nqtveff=0, ncovvt=0;k<=cptcovt; k++){ /* or cptocvt loop on k from model */ |
for(k=1, ncovf=0, nsd=0, nsq=0, ncovv=0,ncovva=0,ncovvta=0, ncova=0, ncoveff=0, nqfveff=0, ntveff=0, nqtveff=0, ncovvt=0;k<=cptcovt; k++){ /* or cptocvt loop on k from model */ |
if (Tvar[k] <=ncovcol && Typevar[k]==0 ){ /* Simple fixed dummy (<=ncovcol) covariates */ |
if (Tvar[k] <=ncovcol && Typevar[k]==0 ){ /* Simple fixed dummy (<=ncovcol) covariates */ |
Fixed[k]= 0; |
Fixed[k]= 0; |
Line 15238 int hPijx(double *p, int bage, int fage)
|
Line 14362 int hPijx(double *p, int bage, int fage)
|
int agelim; |
int agelim; |
int hstepm; |
int hstepm; |
int nhstepm; |
int nhstepm; |
int h, i, i1, j, k, k4, nres=0; |
int h, i, i1, j, k, nres=0; |
|
|
double agedeb; |
double agedeb; |
double ***p3mat; |
double ***p3mat; |
Line 15444 int main(int argc, char *argv[])
|
Line 14568 int main(int argc, char *argv[])
|
|
|
double fret; |
double fret; |
double dum=0.; /* Dummy variable */ |
double dum=0.; /* Dummy variable */ |
double ***p3mat; |
/* double*** p3mat;*/ |
/* double ***mobaverage; */ |
/* double ***mobaverage; */ |
double wald; |
double wald; |
|
|
char line[MAXLINE]; |
char line[MAXLINE], linetmp[MAXLINE]; |
char path[MAXLINE],pathc[MAXLINE],pathcd[MAXLINE],pathtot[MAXLINE]; |
char path[MAXLINE],pathc[MAXLINE],pathcd[MAXLINE],pathtot[MAXLINE]; |
|
|
char modeltemp[MAXLINE]; |
char modeltemp[MAXLINE]; |
Line 15457 int main(int argc, char *argv[])
|
Line 14581 int main(int argc, char *argv[])
|
char pathr[MAXLINE], pathimach[MAXLINE]; |
char pathr[MAXLINE], pathimach[MAXLINE]; |
char *tok, *val; /* pathtot */ |
char *tok, *val; /* pathtot */ |
/* int firstobs=1, lastobs=10; /\* nobs = lastobs-firstobs declared globally ;*\/ */ |
/* int firstobs=1, lastobs=10; /\* nobs = lastobs-firstobs declared globally ;*\/ */ |
int c, h , cpt, c2; |
int c, h; /* c2; */ |
int jl=0; |
int jl=0; |
int i1, j1, jk, stepsize=0; |
int i1, j1, jk, stepsize=0; |
int count=0; |
int count=0; |
Line 15492 int main(int argc, char *argv[])
|
Line 14616 int main(int argc, char *argv[])
|
double ***delti3; /* Scale */ |
double ***delti3; /* Scale */ |
double *delti; /* Scale */ |
double *delti; /* Scale */ |
double ***eij, ***vareij; |
double ***eij, ***vareij; |
double **varpl; /* Variances of prevalence limits by age */ |
//double **varpl; /* Variances of prevalence limits by age */ |
|
|
double *epj, vepp; |
double *epj, vepp; |
|
|
Line 15550 int main(int argc, char *argv[])
|
Line 14674 int main(int argc, char *argv[])
|
getcwd(pathcd, size); |
getcwd(pathcd, size); |
#endif |
#endif |
syscompilerinfo(0); |
syscompilerinfo(0); |
printf("\nIMaCh version %s, %s\n%s",version, copyright, fullversion); |
printf("\nIMaCh prax version %s, %s\n%s",version, copyright, fullversion); |
if(argc <=1){ |
if(argc <=1){ |
printf("\nEnter the parameter file name: "); |
printf("\nEnter the parameter file name: "); |
if(!fgets(pathr,FILENAMELENGTH,stdin)){ |
if(!fgets(pathr,FILENAMELENGTH,stdin)){ |
Line 15781 int main(int argc, char *argv[])
|
Line 14905 int main(int argc, char *argv[])
|
}else |
}else |
break; |
break; |
} |
} |
if((num_filled=sscanf(line,"model=1+age%[^.\n]", model)) !=EOF){ |
if((num_filled=sscanf(line,"model=%[^.\n]", model)) !=EOF){ /* Every character after model but dot and return */ |
|
if (num_filled != 1){ |
|
printf("ERROR %d: Model should be at minimum 'model=1+age+' instead of '%s'\n",num_filled, line); |
|
fprintf(ficlog,"ERROR %d: Model should be at minimum 'model=1+age+' instead of '%s'\n",num_filled, line); |
|
model[0]='\0'; |
|
goto end; |
|
}else{ |
|
trimbtab(linetmp,line); /* Trims multiple blanks in line */ |
|
strcpy(line, linetmp); |
|
} |
|
} |
|
if((num_filled=sscanf(line,"model=1+age%[^.\n]", model)) !=EOF){ /* Every character after 1+age but dot and return */ |
if (num_filled != 1){ |
if (num_filled != 1){ |
printf("ERROR %d: Model should be at minimum 'model=1+age+' instead of '%s'\n",num_filled, line); |
printf("ERROR %d: Model should be at minimum 'model=1+age+' instead of '%s'\n",num_filled, line); |
fprintf(ficlog,"ERROR %d: Model should be at minimum 'model=1+age+' instead of '%s'\n",num_filled, line); |
fprintf(ficlog,"ERROR %d: Model should be at minimum 'model=1+age+' instead of '%s'\n",num_filled, line); |
Line 16154 Please run with mle=-1 to get a correct
|
Line 15289 Please run with mle=-1 to get a correct
|
Tvard=imatrix(1,NCOVMAX,1,2); /* n=Tvard[k1][1] and m=Tvard[k1][2] gives the couple n,m of the k1 th product Vn*Vm |
Tvard=imatrix(1,NCOVMAX,1,2); /* n=Tvard[k1][1] and m=Tvard[k1][2] gives the couple n,m of the k1 th product Vn*Vm |
* For V3*V2 (in V2+V1+V1*V4+age*V3+V3*V2), V3*V2 position is 2nd. |
* For V3*V2 (in V2+V1+V1*V4+age*V3+V3*V2), V3*V2 position is 2nd. |
* Tvard[k1=2][1]=3 (V3) Tvard[k1=2][2]=2(V2) */ |
* Tvard[k1=2][1]=3 (V3) Tvard[k1=2][2]=2(V2) */ |
Tvardk=imatrix(-1,NCOVMAX,1,2); |
Tvardk=imatrix(0,NCOVMAX,1,2); |
Tage=ivector(1,NCOVMAX); /* Gives the covariate id of covariates associated with age: V2 + V1 + age*V4 + V3*age |
Tage=ivector(1,NCOVMAX); /* Gives the covariate id of covariates associated with age: V2 + V1 + age*V4 + V3*age |
4 covariates (3 plus signs) |
4 covariates (3 plus signs) |
Tage[1=V3*age]= 4; Tage[2=age*V4] = 3 |
Tage[1=V3*age]= 4; Tage[2=age*V4] = 3 |
Line 16441 This file: <a href=\"%s\">%s</a></br>Tit
|
Line 15576 This file: <a href=\"%s\">%s</a></br>Tit
|
/* Calculates basic frequencies. Computes observed prevalence at single age |
/* Calculates basic frequencies. Computes observed prevalence at single age |
and for any valid combination of covariates |
and for any valid combination of covariates |
and prints on file fileres'p'. */ |
and prints on file fileres'p'. */ |
freqsummary(fileres, p, pstart, agemin, agemax, s, agev, nlstate, imx, Tvaraff, invalidvarcomb, nbcode, ncodemax,mint,anint,strstart, \ |
freqsummary(fileres, p, pstart, (double)agemin, agemax, s, agev, nlstate, imx, Tvaraff, invalidvarcomb, nbcode, ncodemax,mint,anint,strstart, \ |
firstpass, lastpass, stepm, weightopt, model); |
firstpass, lastpass, stepm, weightopt, model); |
|
|
fprintf(fichtm,"\n"); |
fprintf(fichtm,"\n"); |
Line 16532 Interval (in months) between two waves:
|
Line 15667 Interval (in months) between two waves:
|
#ifdef GSL |
#ifdef GSL |
printf("GSL optimization\n"); fprintf(ficlog,"Powell\n"); |
printf("GSL optimization\n"); fprintf(ficlog,"Powell\n"); |
#else |
#else |
printf("Powell\n"); fprintf(ficlog,"Powell\n"); |
printf("Powell-mort\n"); fprintf(ficlog,"Powell-mort\n"); |
#endif |
#endif |
strcpy(filerespow,"POW-MORT_"); |
strcpy(filerespow,"POW-MORT_"); |
strcat(filerespow,fileresu); |
strcat(filerespow,fileresu); |
Line 16635 Interval (in months) between two waves:
|
Line 15770 Interval (in months) between two waves:
|
|
|
for(i=1; i <=NDIM; i++) |
for(i=1; i <=NDIM; i++) |
for(j=i+1;j<=NDIM;j++) |
for(j=i+1;j<=NDIM;j++) |
matcov[i][j]=matcov[j][i]; |
matcov[i][j]=matcov[j][i]; |
|
|
printf("\nCovariance matrix\n "); |
printf("\nCovariance matrix\n "); |
fprintf(ficlog,"\nCovariance matrix\n "); |
fprintf(ficlog,"\nCovariance matrix\n "); |
Line 17089 Please run with mle=-1 to get a correct
|
Line 16224 Please run with mle=-1 to get a correct
|
} |
} |
|
|
/* Results */ |
/* Results */ |
/* Value of covariate in each resultine will be compututed (if product) and sorted according to model rank */ |
/* Value of covariate in each resultine will be computed (if product) and sorted according to model rank */ |
/* It is precov[] because we need the varying age in order to compute the real cov[] of the model equation */ |
/* It is precov[] because we need the varying age in order to compute the real cov[] of the model equation */ |
precov=matrix(1,MAXRESULTLINESPONE,1,NCOVMAX+1); |
precov=matrix(1,MAXRESULTLINESPONE,1,NCOVMAX+1); |
endishere=0; |
endishere=0; |
Line 17259 Please run with mle=-1 to get a correct
|
Line 16394 Please run with mle=-1 to get a correct
|
date2dmy(datebackf,&jbackf, &mbackf, &anbackf); |
date2dmy(datebackf,&jbackf, &mbackf, &anbackf); |
} |
} |
|
|
printinggnuplot(fileresu, optionfilefiname,ageminpar,agemaxpar,bage, fage, prevfcast, prevbcast, pathc,p, (int)anprojd-bage, (int)anbackd-fage); |
printinggnuplot(fileresu, optionfilefiname,ageminpar,agemaxpar,bage, fage, prevfcast, prevbcast, pathc,p, (int)anprojd-bage, (int)anbackd-fage);/* HERE valgrind Tvard*/ |
} |
} |
printinghtml(fileresu,title,datafile, firstpass, lastpass, stepm, weightopt, \ |
printinghtml(fileresu,title,datafile, firstpass, lastpass, stepm, weightopt, \ |
model,imx,jmin,jmax,jmean,rfileres,popforecast,mobilav,prevfcast,mobilavproj,prevbcast, estepm, \ |
model,imx,jmin,jmax,jmean,rfileres,popforecast,mobilav,prevfcast,mobilavproj,prevbcast, estepm, \ |
Line 17409 Please run with mle=-1 to get a correct
|
Line 16544 Please run with mle=-1 to get a correct
|
|
|
pstamp(ficreseij); |
pstamp(ficreseij); |
|
|
i1=pow(2,cptcoveff); /* Number of combination of dummy covariates */ |
/* i1=pow(2,cptcoveff); /\* Number of combination of dummy covariates *\/ */ |
if (cptcovn < 1){i1=1;} |
/* if (cptcovn < 1){i1=1;} */ |
|
|
for(nres=1; nres <= nresult; nres++) /* For each resultline */ |
for(nres=1; nres <= nresult; nres++){ /* For each resultline */ |
for(k=1; k<=i1;k++){ /* For any combination of dummy covariates, fixed and varying */ |
/* for(k=1; k<=i1;k++){ /\* For any combination of dummy covariates, fixed and varying *\/ */ |
if(i1 != 1 && TKresult[nres]!= k) |
/* if(i1 != 1 && TKresult[nres]!= k) */ |
continue; |
/* continue; */ |
fprintf(ficreseij,"\n#****** "); |
fprintf(ficreseij,"\n#****** "); |
printf("\n#****** "); |
printf("\n#****** "); |
for(j=1;j<=cptcoveff;j++) { |
for(j=1;j<=cptcovs;j++){ |
fprintf(ficreseij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); |
/* for(j=1;j<=cptcoveff;j++) { */ |
printf("V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); |
/* fprintf(ficreseij,"V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); */ |
|
fprintf(ficreseij," V%d=%lg ",Tvresult[nres][j],TinvDoQresult[nres][Tvresult[nres][j]]); |
|
printf(" V%d=%lg ",Tvresult[nres][j],TinvDoQresult[nres][Tvresult[nres][j]]); |
|
/* printf("V%d=%d ",Tvaraff[j],nbcode[Tvaraff[j]][codtabm(k,TnsdVar[Tvaraff[j]])]); */ |
} |
} |
for (j=1; j<= nsq; j++){ /* For each selected (single) quantitative value */ |
for (j=1; j<= nsq; j++){ /* For each selected (single) quantitative value */ |
printf(" V%d=%lg ",TvarsQ[j], TinvDoQresult[nres][TvarsQ[j]]); /* TvarsQ[j] gives the name of the jth quantitative (fixed or time v) */ |
printf(" V%d=%lg ",TvarsQ[j], TinvDoQresult[nres][TvarsQ[j]]); /* TvarsQ[j] gives the name of the jth quantitative (fixed or time v) */ |
Line 17489 Please run with mle=-1 to get a correct
|
Line 16627 Please run with mle=-1 to get a correct
|
/* */ |
/* */ |
if(i1 != 1 && TKresult[nres]!= k) /* TKresult[nres] is the combination of this nres resultline. All the i1 combinations are not output */ |
if(i1 != 1 && TKresult[nres]!= k) /* TKresult[nres] is the combination of this nres resultline. All the i1 combinations are not output */ |
continue; |
continue; |
printf("\n# model %s \n#****** Result for:", model); |
printf("\n# model=1+age+%s \n#****** Result for:", model); /* HERE model is empty */ |
fprintf(ficrest,"\n# model %s \n#****** Result for:", model); |
fprintf(ficrest,"\n# model=1+age+%s \n#****** Result for:", model); |
fprintf(ficlog,"\n# model %s \n#****** Result for:", model); |
fprintf(ficlog,"\n# model=1+age+%s \n#****** Result for:", model); |
/* It might not be a good idea to mix dummies and quantitative */ |
/* It might not be a good idea to mix dummies and quantitative */ |
/* for(j=1;j<=cptcoveff;j++){ /\* j=resultpos. Could be a loop on cptcovs: number of single dummy covariate in the result line as well as in the model *\/ */ |
/* for(j=1;j<=cptcoveff;j++){ /\* j=resultpos. Could be a loop on cptcovs: number of single dummy covariate in the result line as well as in the model *\/ */ |
for(j=1;j<=cptcovs;j++){ /* j=resultpos. Could be a loop on cptcovs: number of single covariate (dummy or quantitative) in the result line as well as in the model */ |
for(j=1;j<=cptcovs;j++){ /* j=resultpos. Could be a loop on cptcovs: number of single covariate (dummy or quantitative) in the result line as well as in the model */ |
Line 17664 Please run with mle=-1 to get a correct
|
Line 16802 Please run with mle=-1 to get a correct
|
|
|
|
|
free_vector(weight,firstobs,lastobs); |
free_vector(weight,firstobs,lastobs); |
free_imatrix(Tvardk,-1,NCOVMAX,1,2); |
free_imatrix(Tvardk,0,NCOVMAX,1,2); |
free_imatrix(Tvard,1,NCOVMAX,1,2); |
free_imatrix(Tvard,1,NCOVMAX,1,2); |
free_imatrix(s,1,maxwav+1,firstobs,lastobs); |
free_imatrix(s,1,maxwav+1,firstobs,lastobs); |
free_matrix(anint,1,maxwav,firstobs,lastobs); |
free_matrix(anint,1,maxwav,firstobs,lastobs); |
Line 17686 Please run with mle=-1 to get a correct
|
Line 16824 Please run with mle=-1 to get a correct
|
free_matrix(pmmij,1,nlstate+ndeath,1,nlstate+ndeath); |
free_matrix(pmmij,1,nlstate+ndeath,1,nlstate+ndeath); |
} /* mle==-3 arrives here for freeing */ |
} /* mle==-3 arrives here for freeing */ |
/* endfree:*/ |
/* endfree:*/ |
|
if(mle!=-3) free_matrix(precov, 1,MAXRESULTLINESPONE,1,NCOVMAX+1); /* Could be elsewhere ?*/ |
free_matrix(oldms, 1,nlstate+ndeath,1,nlstate+ndeath); |
free_matrix(oldms, 1,nlstate+ndeath,1,nlstate+ndeath); |
free_matrix(newms, 1,nlstate+ndeath,1,nlstate+ndeath); |
free_matrix(newms, 1,nlstate+ndeath,1,nlstate+ndeath); |
free_matrix(savms, 1,nlstate+ndeath,1,nlstate+ndeath); |
free_matrix(savms, 1,nlstate+ndeath,1,nlstate+ndeath); |
Line 17747 Please run with mle=-1 to get a correct
|
Line 16886 Please run with mle=-1 to get a correct
|
free_ivector(TmodelInvind,1,NCOVMAX); |
free_ivector(TmodelInvind,1,NCOVMAX); |
free_ivector(TmodelInvQind,1,NCOVMAX); |
free_ivector(TmodelInvQind,1,NCOVMAX); |
|
|
free_matrix(precov, 1,MAXRESULTLINESPONE,1,NCOVMAX+1); /* Could be elsewhere ?*/ |
/* free_matrix(precov, 1,MAXRESULTLINESPONE,1,NCOVMAX+1); /\* Could be elsewhere ?*\/ */ |
|
|
free_imatrix(nbcode,0,NCOVMAX,0,NCOVMAX); |
free_imatrix(nbcode,0,NCOVMAX,0,NCOVMAX); |
/* free_imatrix(codtab,1,100,1,10); */ |
/* free_imatrix(codtab,1,100,1,10); */ |