spd-1.3.0/0000755000175000017500000000000011655563114007311 500000000000000spd-1.3.0/fitpack/0000755000175000017500000000000011655563114010732 500000000000000spd-1.3.0/fitpack/surfit.f0000644000175000017500000005441311633462461012343 00000000000000 subroutine surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) c given the set of data points (x(i),y(i),z(i)) and the set of positive c numbers w(i),i=1,...,m, subroutine surfit determines a smooth bivar- c iate spline approximation s(x,y) of degrees kx and ky on the rect- c angle xb <= x <= xe, yb <= y <= ye. c if iopt = -1 surfit calculates the weighted least-squares spline c according to a given set of knots. c if iopt >= 0 the total numbers nx and ny of these knots and their c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- c ally by the routine. the smoothness of s(x,y) is then achieved by c minimalizing the discontinuity jumps in the derivatives of s(x,y) c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). c the amounth of smoothness is determined by the condition that f(p) = c sum ((w(i)*(z(i)-s(x(i),y(i))))**2) be <= s, with s a given non-neg- c ative constant, called the smoothing factor. c the fit is given in the b-spline representation (b-spline coefficients c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- c uated by means of subroutine bispev. c c calling sequence: c call surfit(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, c * nmax,eps,nx,tx,ny,ty,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a weighted c least-squares spline (iopt=-1) or a smoothing spline (iopt=0 c or 1) must be determined. c if iopt=0 the routine will start with an initial set of knots c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= c 1,...,ky+1. if iopt=1 the routine will continue with the set c of knots found at the last call of the routine. c attention: a call with iopt=1 must always be immediately pre- c ceded by another call with iopt=1 or iopt=0. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m >= (kx+1)*(ky+1). unchanged on exit. c x : real array of dimension at least (m). c y : real array of dimension at least (m). c z : real array of dimension at least (m). c before entry, x(i),y(i),z(i) must be set to the co-ordinates c of the i-th data point, for i=1,...,m. the order of the data c points is immaterial. unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) must c be set to the i-th value in the set of weights. the w(i) must c be strictly positive. unchanged on exit. c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- c yb,ye aries of the rectangular approximation domain. c xb<=x(i)<=xe,yb<=y(i)<=ye,i=1,...,m. unchanged on exit. c kx,ky : integer values. on entry kx and ky must specify the degrees c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic c (kx=ky=3) splines. unchanged on exit. c s : real. on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments c nxest : integer. unchanged on exit. c nyest : integer. unchanged on exit. c on entry, nxest and nyest must specify an upper bound for the c number of knots required in the x- and y-directions respect. c these numbers will also determine the storage space needed by c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). c in most practical situation nxest = kx+1+sqrt(m/2), nyest = c ky+1+sqrt(m/2) will be sufficient. see also further comments. c nmax : integer. on entry nmax must specify the actual dimension of c the arrays tx and ty. nmax >= nxest, nmax >=nyest. c unchanged on exit. c eps : real. c on entry, eps must specify a threshold for determining the c effective rank of an over-determined linear system of equat- c ions. 0 < eps < 1. if the number of decimal digits in the c computer representation of a real number is q, then 10**(-q) c is a suitable value for eps in most practical applications. c unchanged on exit. c nx : integer. c unless ier=10 (in case iopt >=0), nx will contain the total c number of knots with respect to the x-variable, of the spline c approximation returned. if the computation mode iopt=1 is c used, the value of nx should be left unchanged between sub- c sequent calls. c in case iopt=-1, the value of nx should be specified on entry c tx : real array of dimension nmax. c on succesful exit, this array will contain the knots of the c spline with respect to the x-variable, i.e. the position of c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the c position of the additional knots tx(1)=...=tx(kx+1)=xb and c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. c if the computation mode iopt=1 is used, the values of tx(1), c ...,tx(nx) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values tx(kx+2), c ...tx(nx-kx-1) must be supplied by the user, before entry. c see also the restrictions (ier=10). c ny : integer. c unless ier=10 (in case iopt >=0), ny will contain the total c number of knots with respect to the y-variable, of the spline c approximation returned. if the computation mode iopt=1 is c used, the value of ny should be left unchanged between sub- c sequent calls. c in case iopt=-1, the value of ny should be specified on entry c ty : real array of dimension nmax. c on succesful exit, this array will contain the knots of the c spline with respect to the y-variable, i.e. the position of c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the c position of the additional knots ty(1)=...=ty(ky+1)=yb and c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. c if the computation mode iopt=1 is used, the values of ty(1), c ...,ty(ny) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values ty(ky+2), c ...ty(ny-ky-1) must be supplied by the user, before entry. c see also the restrictions (ier=10). c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). c on succesful exit, c contains the coefficients of the spline c approximation s(x,y) c fp : real. unless ier=10, fp contains the weighted sum of c squared residuals of the spline approximation returned. c wrk1 : real array of dimension (lwrk1). used as workspace. c if the computation mode iopt=1 is used the value of wrk1(1) c should be left unchanged between subsequent calls. c on exit wrk1(2),wrk1(3),...,wrk1(1+(nx-kx-1)*(ny-ky-1)) will c contain the values d(i)/max(d(i)),i=1,...,(nx-kx-1)*(ny-ky-1) c with d(i) the i-th diagonal element of the reduced triangular c matrix for calculating the b-spline coefficients. it includes c those elements whose square is less than eps,which are treat- c ed as 0 in the case of presumed rank deficiency (ier<-2). c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of c the array wrk1 as declared in the calling (sub)program. c lwrk1 must not be too small. let c u = nxest-kx-1, v = nyest-ky-1, km = max(kx,ky)+1, c ne = max(nxest,nyest), bx = kx*v+ky+1, by = ky*u+kx+1, c if(bx.le.by) b1 = bx, b2 = b1+v-ky c if(bx.gt.by) b1 = by, b2 = b1+u-kx then c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 c wrk2 : real array of dimension (lwrk2). used as workspace, but c only in the case a rank deficient system is encountered. c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of c the array wrk2 as declared in the calling (sub)program. c lwrk2 > 0 . a save upper boundfor lwrk2 = u*v*(b2+1)+b2 c where u,v and b2 are as above. if there are enough data c points, scattered uniformly over the approximation domain c and if the smoothing factor s is not too small, there is a c good chance that this extra workspace is not needed. a lot c of memory might therefore be saved by setting lwrk2=1. c (see also ier > 10) c iwrk : integer array of dimension (kwrk). used as workspace. c kwrk : integer. on entry kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1). c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is an interpolating c spline (fp=0). c ier=-2 : normal return. the spline returned is the weighted least- c squares polynomial of degrees kx and ky. in this extreme c case fp gives the upper bound for the smoothing factor s. c ier<-2 : warning. the coefficients of the spline returned have been c computed as the minimal norm least-squares solution of a c (numerically) rank deficient system. (-ier) gives the rank. c especially if the rank deficiency which can be computed as c (nx-kx-1)*(ny-ky-1)+ier, is large the results may be inac- c curate. they could also seriously depend on the value of c eps. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameters nxest and c nyest. c probably causes : nxest or nyest too small. if these param- c eters are already large, it may also indicate that s is c too small c the approximation returned is the weighted least-squares c spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small or badly chosen eps. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=4 : error. no more knots can be added because the number of c b-spline coefficients (nx-kx-1)*(ny-ky-1) already exceeds c the number of data points m. c probably causes : either s or m too small. c the approximation returned is the weighted least-squares c spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=5 : error. no more knots can be added because the additional c knot would (quasi) coincide with an old one. c probably causes : s too small or too large a weight to an c inaccurate data point. c the approximation returned is the weighted least-squares c spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, 1<=kx,ky<=5, m>=(kx+1)*(ky+1), nxest>=2*kx+2, c nyest>=2*ky+2, 0=nxest, nmax>=nyest, c xb<=x(i)<=xe, yb<=y(i)<=ye, w(i)>0, i=1,...,m c lwrk1 >= u*v*(2+b1+b2)+2*(u+v+km*(m+ne)+ne-kx-ky)+b2+1 c kwrk >= m+(nxest-2*kx-1)*(nyest-2*ky-1) c if iopt=-1: 2*kx+2<=nx<=nxest c xb=0: s>=0 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c ier>10 : error. lwrk2 is too small, i.e. there is not enough work- c space for computing the minimal least-squares solution of c a rank deficient system of linear equations. ier gives the c requested value for lwrk2. there is no approximation re- c turned but, having saved the information contained in nx, c ny,tx,ty,wrk1, and having adjusted the value of lwrk2 and c the dimension of the array wrk2 accordingly, the user can c continue at the point the program was left, by calling c surfit with iopt=1. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating spline if c s=0 and the weighted least-squares polynomial (degrees kx,ky)if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c z(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in z(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the least-squares c polynomial and the corresponding upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximation shows more detail) to obtain closer fits. c to choose s very small is strongly discouraged. this considerably c increases computation time and memory requirements. it may also c cause rank-deficiency (ier<-2) and endager numerical stability. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if surfit is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. if the computation mode iopt=1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c surfit once more with the selected value for s but now with iopt=0. c indeed, surfit may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c the number of knots may also depend on the upper bounds nxest and c nyest. indeed, if at a certain stage in surfit the number of knots c in one direction (say nx) has reached the value of its upper bound c (nxest), then from that moment on all subsequent knots are added c in the other (y) direction. this may indicate that the value of c nxest is too small. on the other hand, it gives the user the option c of limiting the number of knots the routine locates in any direction c for example, by setting nxest=2*kx+2 (the lowest allowable value for c nxest), the user can indicate that he wants an approximation which c is a simple polynomial of degree kx in the variable x. c c other subroutines required: c fpback,fpbspl,fpsurf,fpdisc,fpgivs,fprank,fprati,fprota,fporde c c references: c dierckx p. : an algorithm for surface fitting with spline functions c ima j. numer. anal. 1 (1981) 267-283. c dierckx p. : an algorithm for surface fitting with spline functions c report tw50, dept. computer science,k.u.leuven, 1980. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : may 1979 c latest update : march 1987 c c .. c ..scalar arguments.. real xb,xe,yb,ye,s,eps,fp integer iopt,m,kx,ky,nxest,nyest,nmax,nx,ny,lwrk1,lwrk2,kwrk,ier c ..array arguments.. real x(m),y(m),z(m),w(m),tx(nmax),ty(nmax), * c((nxest-kx-1)*(nyest-ky-1)),wrk1(lwrk1),wrk2(lwrk2) integer iwrk(kwrk) c ..local scalars.. real tol integer i,ib1,ib3,jb1,ki,kmax,km1,km2,kn,kwest,kx1,ky1,la,lbx, * lby,lco,lf,lff,lfp,lh,lq,lsx,lsy,lwest,maxit,ncest,nest,nek, * nminx,nminy,nmx,nmy,nreg,nrint,nxk,nyk c ..function references.. integer max0 c ..subroutine references.. c fpsurf c .. c we set up the parameters tol and maxit. maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid,control is immediately repassed to the calling program. ier = 10 If (eps.le.0. .or. eps.ge.1.) Then Write (*, '(''SURFIT ERROR: eps is incorrectly defined'')') go to 70 End If If (kx.le.0 .or. kx.gt.5) Then Write (*, '(''SURFIT ERROR: kx is incorrectly defined'')') go to 70 End If kx1 = kx+1 If (ky.le.0 .or. ky.gt.5) Then Write (*, '(''SURFIT ERROR: ky is incorrectly defined'')') go to 70 End If ky1 = ky+1 kmax = max0(kx,ky) km1 = kmax+1 km2 = km1+1 If (iopt.lt.(-1) .or. iopt.gt.1) Then Write (*, '(''SURFIT ERROR: iopt is incorrectly defined'')') go to 70 End If If (m.lt.(kx1*ky1)) Then Write (*, '(''SURFIT ERROR: m is too small wrt kx and ky'')') go to 70 End If nminx = 2*kx1 If (nxest.lt.nminx .or. nxest.gt.nmax) Then Write (*, '(''SURFIT ERROR: nxest is out of range'')') go to 70 End If nminy = 2*ky1 If (nyest.lt.nminy .or. nyest.gt.nmax) Then Write (*, '(''SURFIT ERROR: nyest is out of range'')') go to 70 End If nest = max0(nxest,nyest) nxk = nxest-kx1 nyk = nyest-ky1 ncest = nxk*nyk nmx = nxest-nminx+1 nmy = nyest-nminy+1 nrint = nmx+nmy nreg = nmx*nmy ib1 = kx*nyk+ky1 jb1 = ky*nxk+kx1 ib3 = kx1*nyk+1 if(ib1.le.jb1) go to 10 ib1 = jb1 ib3 = ky1*nxk+1 10 lwest = ncest*(2+ib1+ib3)+2*(nrint+nest*km2+m*km1)+ib3 kwest = m+nreg If (lwrk1.lt.lwest) Then Write (*, '(''SURFIT ERROR: lwrk1 is too small'')') go to 70 End If If (kwrk.lt.kwest) Then Write (*, '(''SURFIT ERROR: kwrk is too small'')') go to 70 End If If (xb.ge.xe) Then Write (*, '(''SURFIT ERROR: xb >= xe'')') go to 70 End If If (yb.ge.ye) Then Write (*, '(''SURFIT ERROR: yb >= ye'')') go to 70 End If do 20 i=1,m if (w(i).le.0.) Then Write (*, '(''SURFIT ERROR: Zero or negative weight'')') go to 70 End If if (x(i).lt.xb .or. x(i).gt.xe) Then Write (*, '(''SURFIT ERROR: X-coordinate out of range'')') go to 70 End If If (y(i).lt.yb .or. y(i).gt.ye) Then Write (*, '(''SURFIT ERROR: Y-coordinate out of range'')') go to 70 End If 20 continue if(iopt.ge.0) go to 50 If (nx.lt.nminx .or. nx.gt.nxest) Then Write (*, '(''SURFIT ERROR: nx out of range'')') go to 70 End If nxk = nx-kx1 tx(kx1) = xb tx(nxk+1) = xe do 30 i=kx1,nxk if(tx(i+1).le.tx(i)) go to 70 30 continue If (ny.lt.nminy .or. ny.gt.nyest) Then Write (*, '(''SURFIT ERROR: ny out of range'')') go to 70 End If nyk = ny-ky1 ty(ky1) = yb ty(nyk+1) = ye do 40 i=ky1,nyk if(ty(i+1).le.ty(i)) go to 70 40 continue go to 60 50 If (s.lt.0.) Then Write (*, '(''SURFIT ERROR: s negative'')') go to 70 End If 60 ier = 0 c we partition the working space and determine the spline approximation kn = 1 ki = kn+m lq = 2 la = lq+ncest*ib3 lf = la+ncest*ib1 lff = lf+ncest lfp = lff+ncest lco = lfp+nrint lh = lco+nrint lbx = lh+ib3 nek = nest*km2 lby = lbx+nek lsx = lby+nek lsy = lsx+m*km1 call fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kx,ky,s,nxest,nyest, * eps,tol,maxit,nest,km1,km2,ib1,ib3,ncest,nrint,nreg,nx,tx, * ny,ty,c,fp,wrk1(1),wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff), * wrk1(la),wrk1(lq),wrk1(lbx),wrk1(lby),wrk1(lsx),wrk1(lsy), * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier) 70 return end spd-1.3.0/fitpack/parsur.f0000644000175000017500000004525411633462461012346 00000000000000 subroutine parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,nvest, * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) c given the set of ordered points f(i,j) in the idim-dimensional space, c corresponding to grid values (u(i),v(j)) ,i=1,...,mu ; j=1,...,mv, c parsur determines a smooth approximating spline surface s(u,v) , i.e. c f1 = s1(u,v) c ... u(1) <= u <= u(mu) ; v(1) <= v <= v(mv) c fidim = sidim(u,v) c with sl(u,v), l=1,2,...,idim bicubic spline functions with common c knots tu(i),i=1,...,nu in the u-variable and tv(j),j=1,...,nv in the c v-variable. c in addition, these splines will be periodic in the variable u if c ipar(1) = 1 and periodic in the variable v if ipar(2) = 1. c if iopt=-1, parsur determines the least-squares bicubic spline c surface according to a given set of knots. c if iopt>=0, the number of knots of s(u,v) and their position c is chosen automatically by the routine. the smoothness of s(u,v) is c achieved by minimalizing the discontinuity jumps of the derivatives c of the splines at the knots. the amount of smoothness of s(u,v) is c determined by the condition that c fp=sumi=1,mu(sumj=1,mv(dist(f(i,j)-s(u(i),v(j)))**2))<=s, c with s a given non-negative constant. c the fit s(u,v) is given in its b-spline representation and can be c evaluated by means of routine surev. c c calling sequence: c call parsur(iopt,ipar,idim,mu,u,mv,v,f,s,nuest,nvest,nu,tu, c * nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) c c parameters: c iopt : integer flag. unchanged on exit. c on entry iopt must specify whether a least-squares surface c (iopt=-1) or a smoothing surface (iopt=0 or 1)must be c determined. c if iopt=0 the routine will start with the initial set of c knots needed for determining the least-squares polynomial c surface. c if iopt=1 the routine will continue with the set of knots c found at the last call of the routine. c attention: a call with iopt=1 must always be immediately c preceded by another call with iopt = 1 or iopt = 0. c ipar : integer array of dimension 2. unchanged on exit. c on entry ipar(1) must specify whether (ipar(1)=1) or not c (ipar(1)=0) the splines must be periodic in the variable u. c on entry ipar(2) must specify whether (ipar(2)=1) or not c (ipar(2)=0) the splines must be periodic in the variable v. c idim : integer. on entry idim must specify the dimension of the c surface. 1 <= idim <= 3. unchanged on exit. c mu : integer. on entry mu must specify the number of grid points c along the u-axis. unchanged on exit. c mu >= mumin where mumin=4-2*ipar(1) c u : real array of dimension at least (mu). before entry, u(i) c must be set to the u-co-ordinate of the i-th grid point c along the u-axis, for i=1,2,...,mu. these values must be c supplied in strictly ascending order. unchanged on exit. c mv : integer. on entry mv must specify the number of grid points c along the v-axis. unchanged on exit. c mv >= mvmin where mvmin=4-2*ipar(2) c v : real array of dimension at least (mv). before entry, v(j) c must be set to the v-co-ordinate of the j-th grid point c along the v-axis, for j=1,2,...,mv. these values must be c supplied in strictly ascending order. unchanged on exit. c f : real array of dimension at least (mu*mv*idim). c before entry, f(mu*mv*(l-1)+mv*(i-1)+j) must be set to the c l-th co-ordinate of the data point corresponding to the c the grid point (u(i),v(j)) for l=1,...,idim ,i=1,...,mu c and j=1,...,mv. unchanged on exit. c if ipar(1)=1 it is expected that f(mu*mv*(l-1)+mv*(mu-1)+j) c = f(mu*mv*(l-1)+j), l=1,...,idim ; j=1,...,mv c if ipar(2)=1 it is expected that f(mu*mv*(l-1)+mv*(i-1)+mv) c = f(mu*mv*(l-1)+mv*(i-1)+1), l=1,...,idim ; i=1,...,mu c s : real. on entry (if iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments c nuest : integer. unchanged on exit. c nvest : integer. unchanged on exit. c on entry, nuest and nvest must specify an upper bound for the c number of knots required in the u- and v-directions respect. c these numbers will also determine the storage space needed by c the routine. nuest >= 8, nvest >= 8. c in most practical situation nuest = mu/2, nvest=mv/2, will c be sufficient. always large enough are nuest=mu+4+2*ipar(1), c nvest = mv+4+2*ipar(2), the number of knots needed for c interpolation (s=0). see also further comments. c nu : integer. c unless ier=10 (in case iopt>=0), nu will contain the total c number of knots with respect to the u-variable, of the spline c surface returned. if the computation mode iopt=1 is used, c the value of nu should be left unchanged between subsequent c calls. in case iopt=-1, the value of nu should be specified c on entry. c tu : real array of dimension at least (nuest). c on succesful exit, this array will contain the knots of the c splines with respect to the u-variable, i.e. the position of c the interior knots tu(5),...,tu(nu-4) as well as the position c of the additional knots tu(1),...,tu(4) and tu(nu-3),..., c tu(nu) needed for the b-spline representation. c if the computation mode iopt=1 is used,the values of tu(1) c ...,tu(nu) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values tu(5), c ...tu(nu-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c nv : integer. c unless ier=10 (in case iopt>=0), nv will contain the total c number of knots with respect to the v-variable, of the spline c surface returned. if the computation mode iopt=1 is used, c the value of nv should be left unchanged between subsequent c calls. in case iopt=-1, the value of nv should be specified c on entry. c tv : real array of dimension at least (nvest). c on succesful exit, this array will contain the knots of the c splines with respect to the v-variable, i.e. the position of c the interior knots tv(5),...,tv(nv-4) as well as the position c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., c tv(nv) needed for the b-spline representation. c if the computation mode iopt=1 is used,the values of tv(1) c ...,tv(nv) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values tv(5), c ...tv(nv-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c c : real array of dimension at least (nuest-4)*(nvest-4)*idim. c on succesful exit, c contains the coefficients of the spline c approximation s(u,v) c fp : real. unless ier=10, fp contains the sum of squared c residuals of the spline surface returned. c wrk : real array of dimension (lwrk). used as workspace. c if the computation mode iopt=1 is used the values of c wrk(1),...,wrk(4) should be left unchanged between subsequent c calls. c lwrk : integer. on entry lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. c lwrk must not be too small. c lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+ c 4*(mu+mv)+q*idim where q is the larger of mv and nuest. c iwrk : integer array of dimension (kwrk). used as workspace. c if the computation mode iopt=1 is used the values of c iwrk(1),.,iwrk(3) should be left unchanged between subsequent c calls. c kwrk : integer. on entry kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. c kwrk >= 3+mu+mv+nuest+nvest. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the surface returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline surface returned is an c interpolating surface (fp=0). c ier=-2 : normal return. the surface returned is the least-squares c polynomial surface. in this extreme case fp gives the c upper bound for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameters nuest and c nvest. c probably causes : nuest or nvest too small. if these param- c eters are already large, it may also indicate that s is c too small c the approximation returned is the least-squares surface c according to the current set of knots. the parameter fp c gives the corresponding sum of squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing surface with c fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing surface c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, 0<=ipar(1)<=1, 0<=ipar(2)<=1, 1 <=idim<=3 c mu >= 4-2*ipar(1),mv >= 4-2*ipar(2), nuest >=8, nvest >= 8, c kwrk>=3+mu+mv+nuest+nvest, c lwrk >= 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2)) c +4*(mu+mv)+max(nuest,mv)*idim c u(i-1)=0: s>=0 c if s=0: nuest>=mu+4+2*ipar(1) c nvest>=mv+4+2*ipar(2) c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the surface will be too smooth and signal will be c lost ; if s is too small the surface will pick up too much noise. in c the extreme cases the program will return an interpolating surface c if s=0 and the constrained least-squares polynomial surface if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the accuracy of the data values. c if the user has an idea of the statistical errors on the data, he c can also find a proper estimate for s. for, by assuming that, if he c specifies the right s, parsur will return a surface s(u,v) which c exactly reproduces the surface underlying the data he can evaluate c the sum(dist(f(i,j)-s(u(i),v(j)))**2) to find a good estimate for s. c for example, if he knows that the statistical errors on his f(i,j)- c values is not greater than 0.1, he may expect that a good s should c have a value not larger than mu*mv*(0.1)**2. c if nothing is known about the statistical error in f(i,j), s must c be determined by trial and error, taking account of the comments c above. the best is then to start with a very large value of s (to c determine the le-sq polynomial surface and the corresponding upper c bound fp0 for s) and then to progressively decrease the value of s c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... c and more carefully as the approximation shows more detail) to c obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt = 1 the program will continue with the knots found at c the last call of the routine. this will save a lot of computation c time if parsur is called repeatedly for different values of s. c the number of knots of the surface returned and their location will c depend on the value of s and on the complexity of the shape of the c surface underlying the data. if the computation mode iopt = 1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt=1,the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c parsur once more with the chosen value for s but now with iopt=0. c indeed, parsur may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c the number of knots may also depend on the upper bounds nuest and c nvest. indeed, if at a certain stage in parsur the number of knots c in one direction (say nu) has reached the value of its upper bound c (nuest), then from that moment on all subsequent knots are added c in the other (v) direction. this may indicate that the value of c nuest is too small. on the other hand, it gives the user the option c of limiting the number of knots the routine locates in any direction c for example, by setting nuest=8 (the lowest allowable value for c nuest), the user can indicate that he wants an approximation with c splines which are simple cubic polynomials in the variable u. c c other subroutines required: c fppasu,fpchec,fpchep,fpknot,fprati,fpgrpa,fptrnp,fpback, c fpbacp,fpbspl,fptrpe,fpdisc,fpgivs,fprota c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1989 c c .. c ..scalar arguments.. real s,fp integer iopt,idim,mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier c ..array arguments.. real u(mu),v(mv),f(mu*mv*idim),tu(nuest),tv(nvest), * c((nuest-4)*(nvest-4)*idim),wrk(lwrk) integer ipar(2),iwrk(kwrk) c ..local scalars.. real tol,ub,ue,vb,ve,peru,perv integer i,j,jwrk,kndu,kndv,knru,knrv,kwest,l1,l2,l3,l4, * lfpu,lfpv,lwest,lww,maxit,nc,mf,mumin,mvmin c ..function references.. integer max0 c ..subroutine references.. c fppasu,fpchec,fpchep c .. c we set up the parameters tol and maxit. maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(iopt.lt.(-1) .or. iopt.gt.1) go to 200 if(ipar(1).lt.0 .or. ipar(1).gt.1) go to 200 if(ipar(2).lt.0 .or. ipar(2).gt.1) go to 200 if(idim.le.0 .or. idim.gt.3) go to 200 mumin = 4-2*ipar(1) if(mu.lt.mumin .or. nuest.lt.8) go to 200 mvmin = 4-2*ipar(2) if(mv.lt.mvmin .or. nvest.lt.8) go to 200 mf = mu*mv nc = (nuest-4)*(nvest-4) lwest = 4+nuest*(mv*idim+11+4*ipar(1))+nvest*(11+4*ipar(2))+ * 4*(mu+mv)+max0(nuest,mv)*idim kwest = 3+mu+mv+nuest+nvest if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200 do 10 i=2,mu if(u(i-1).ge.u(i)) go to 200 10 continue do 20 i=2,mv if(v(i-1).ge.v(i)) go to 200 20 continue if(iopt.ge.0) go to 100 if(nu.lt.8 .or. nu.gt.nuest) go to 200 ub = u(1) ue = u(mu) if (ipar(1).ne.0) go to 40 j = nu do 30 i=1,4 tu(i) = ub tu(j) = ue j = j-1 30 continue call fpchec(u,mu,tu,nu,3,ier) if(ier.ne.0) go to 200 go to 60 40 l1 = 4 l2 = l1 l3 = nu-3 l4 = l3 peru = ue-ub tu(l2) = ub tu(l3) = ue do 50 j=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tu(l2) = tu(l4)-peru tu(l3) = tu(l1)+peru 50 continue call fpchep(u,mu,tu,nu,3,ier) if(ier.ne.0) go to 200 60 if(nv.lt.8 .or. nv.gt.nvest) go to 200 vb = v(1) ve = v(mv) if (ipar(2).ne.0) go to 80 j = nv do 70 i=1,4 tv(i) = vb tv(j) = ve j = j-1 70 continue call fpchec(v,mv,tv,nv,3,ier) if(ier.ne.0) go to 200 go to 150 80 l1 = 4 l2 = l1 l3 = nv-3 l4 = l3 perv = ve-vb tv(l2) = vb tv(l3) = ve do 90 j=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tv(l2) = tv(l4)-perv tv(l3) = tv(l1)+perv 90 continue call fpchep(v,mv,tv,nv,3,ier) if(ier) 200,150,200 100 if(s.lt.0.) go to 200 if(s.eq.0. .and. (nuest.lt.(mu+4+2*ipar(1)) .or. * nvest.lt.(mv+4+2*ipar(2))) )go to 200 ier = 0 c we partition the working space and determine the spline approximation 150 lfpu = 5 lfpv = lfpu+nuest lww = lfpv+nvest jwrk = lwrk-4-nuest-nvest knru = 4 knrv = knru+mu kndu = knrv+mv kndv = kndu+nuest call fppasu(iopt,ipar,idim,u,mu,v,mv,f,mf,s,nuest,nvest, * tol,maxit,nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4), * wrk(lfpu),wrk(lfpv),iwrk(1),iwrk(2),iwrk(3),iwrk(knru), * iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),jwrk,ier) 200 return end spd-1.3.0/fitpack/evapol.f0000644000175000017500000000512711633462461012313 00000000000000 real function evapol(tu,nu,tv,nv,c,rad,x,y) c function program evacir evaluates the function f(x,y) = s(u,v), c defined through the transformation c x = u*rad(v)*cos(v) y = u*rad(v)*sin(v) c and where s(u,v) is a bicubic spline ( 0<=u<=1 , -pi<=v<=pi ), given c in its standard b-spline representation. c c calling sequence: c f = evapol(tu,nu,tv,nv,c,rad,x,y) c c input parameters: c tu : real array, length nu, which contains the position of the c knots in the u-direction. c nu : integer, giving the total number of knots in the u-direction c tv : real array, length nv, which contains the position of the c knots in the v-direction. c nv : integer, giving the total number of knots in the v-direction c c : real array, length (nu-4)*(nv-4), which contains the c b-spline coefficients. c rad : real function subprogram, defining the boundary of the c approximation domain. must be declared external in the c calling (sub)-program c x,y : real values. c before entry x and y must be set to the co-ordinates of c the point where f(x,y) must be evaluated. c c output parameter: c f : real c on exit f contains the value of f(x,y) c c other subroutines required: c bispev,fpbisp,fpbspl c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1989 c c ..scalar arguments.. integer nu,nv real x,y c ..array arguments.. real tu(nu),tv(nv),c((nu-4)*(nv-4)) c ..user specified function real rad c ..local scalars.. integer ier real u,v,r,f,one,dist c ..local arrays real wrk(8) integer iwrk(2) c ..function references real atan2,sqrt c .. c calculate the (u,v)-coordinates of the given point. one = 1 u = 0. v = 0. dist = x**2+y**2 if(dist.le.0.) go to 10 v = atan2(y,x) r = rad(v) if(r.le.0.) go to 10 u = sqrt(dist)/r if(u.gt.one) u = one c evaluate s(u,v) 10 call bispev(tu,nu,tv,nv,c,3,3,u,1,v,1,f,wrk,8,iwrk,2,ier) evapol = f return end spd-1.3.0/fitpack/fppasu.f0000644000175000017500000003220311633462460012315 00000000000000 subroutine fppasu(iopt,ipar,idim,u,mu,v,mv,z,mz,s,nuest,nvest, * tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu,reducv,fpintu, * fpintv,lastdi,nplusu,nplusv,nru,nrv,nrdatu,nrdatv,wrk,lwrk,ier) c .. c ..scalar arguments.. real s,tol,fp,fp0,fpold,reducu,reducv integer iopt,idim,mu,mv,mz,nuest,nvest,maxit,nc,nu,nv,lastdi, * nplusu,nplusv,lwrk,ier c ..array arguments.. real u(mu),v(mv),z(mz*idim),tu(nuest),tv(nvest),c(nc*idim), * fpintu(nuest),fpintv(nvest),wrk(lwrk) integer ipar(2),nrdatu(nuest),nrdatv(nvest),nru(mu),nrv(mv) c ..local scalars real acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,con1,con9,con4, * peru,perv,ub,ue,vb,ve integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,iter,j,lau1,lav1,laa, * l,lau,lav,lbu,lbv,lq,lri,lsu,lsv,l1,l2,l3,l4,mm,mpm,mvnu,ncof, * nk1u,nk1v,nmaxu,nmaxv,nminu,nminv,nplu,nplv,npl1,nrintu, * nrintv,nue,nuk,nve,nuu,nvv c ..function references.. real abs,fprati integer max0,min0 c ..subroutine references.. c fpgrpa,fpknot c .. c set constants one = 1 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 c set boundaries of the approximation domain ub = u(1) ue = u(mu) vb = v(1) ve = v(mv) c we partition the working space. lsu = 1 lsv = lsu+mu*4 lri = lsv+mv*4 mm = max0(nuest,mv) lq = lri+mm*idim mvnu = nuest*mv*idim lau = lq+mvnu nuk = nuest*5 lbu = lau+nuk lav = lbu+nuk nuk = nvest*5 lbv = lav+nuk laa = lbv+nuk lau1 = lau if(ipar(1).eq.0) go to 10 peru = ue-ub lau1 = laa laa = laa+4*nuest 10 lav1 = lav if(ipar(2).eq.0) go to 20 perv = ve-vb lav1 = laa cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position. c c **************************************************************** c c given a set of knots we compute the least-squares spline sinf(u,v), c c and the corresponding sum of squared residuals fp=f(p=inf). c c if iopt=-1 sinf(u,v) is the requested approximation. c c if iopt=0 or iopt=1 we check whether we can accept the knots: c c if fp <=s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares spline until finally fp<=s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots equals nmaxu = mu+4+2*ipar(1) and nmaxv = mv+4+2*ipar(2) c c if s>0 and c c *iopt=0 we first compute the least-squares polynomial c c nu=nminu=8 and nv=nminv=8 c c *iopt=1 we start with the knots found at the last call of the c c routine, except for the case that s > fp0; then we can compute c c the least-squares polynomial directly. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c determine the number of knots for polynomial approximation. 20 nminu = 8 nminv = 8 if(iopt.lt.0) go to 100 c acc denotes the absolute tolerance for the root of f(p)=s. acc = tol*s c find nmaxu and nmaxv which denote the number of knots in u- and v- c direction in case of spline interpolation. nmaxu = mu+4+2*ipar(1) nmaxv = mv+4+2*ipar(2) c find nue and nve which denote the maximum number of knots c allowed in each direction nue = min0(nmaxu,nuest) nve = min0(nmaxv,nvest) if(s.gt.0.) go to 60 c if s = 0, s(u,v) is an interpolating spline. nu = nmaxu nv = nmaxv c test whether the required storage space exceeds the available one. if(nv.gt.nvest .or. nu.gt.nuest) go to 420 c find the position of the interior knots in case of interpolation. c the knots in the u-direction. nuu = nu-8 if(nuu.eq.0) go to 40 i = 5 j = 3-ipar(1) do 30 l=1,nuu tu(i) = u(j) i = i+1 j = j+1 30 continue c the knots in the v-direction. 40 nvv = nv-8 if(nvv.eq.0) go to 60 i = 5 j = 3-ipar(2) do 50 l=1,nvv tv(i) = v(j) i = i+1 j = j+1 50 continue go to 100 c if s > 0 our initial choice of knots depends on the value of iopt. 60 if(iopt.eq.0) go to 90 if(fp0.le.s) go to 90 c if iopt=1 and fp0 > s we start computing the least- squares spline c according to the set of knots found at the last call of the routine. c we determine the number of grid coordinates u(i) inside each knot c interval (tu(l),tu(l+1)). l = 5 j = 1 nrdatu(1) = 0 mpm = mu-1 do 70 i=2,mpm nrdatu(j) = nrdatu(j)+1 if(u(i).lt.tu(l)) go to 70 nrdatu(j) = nrdatu(j)-1 l = l+1 j = j+1 nrdatu(j) = 0 70 continue c we determine the number of grid coordinates v(i) inside each knot c interval (tv(l),tv(l+1)). l = 5 j = 1 nrdatv(1) = 0 mpm = mv-1 do 80 i=2,mpm nrdatv(j) = nrdatv(j)+1 if(v(i).lt.tv(l)) go to 80 nrdatv(j) = nrdatv(j)-1 l = l+1 j = j+1 nrdatv(j) = 0 80 continue go to 100 c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares c polynomial (which is a spline without interior knots). 90 nu = nminu nv = nminv nrdatu(1) = mu-2 nrdatv(1) = mv-2 lastdi = 0 nplusu = 0 nplusv = 0 fp0 = 0. fpold = 0. reducu = 0. reducv = 0. 100 mpm = mu+mv ifsu = 0 ifsv = 0 ifbu = 0 ifbv = 0 p = -one c main loop for the different sets of knots.mpm=mu+mv is a save upper c bound for the number of trials. do 250 iter=1,mpm if(nu.eq.nminu .and. nv.eq.nminv) ier = -2 c find nrintu (nrintv) which is the number of knot intervals in the c u-direction (v-direction). nrintu = nu-nminu+1 nrintv = nv-nminv+1 c find ncof, the number of b-spline coefficients for the current set c of knots. nk1u = nu-4 nk1v = nv-4 ncof = nk1u*nk1v c find the position of the additional knots which are needed for the c b-spline representation of s(u,v). if(ipar(1).ne.0) go to 110 i = nu do 105 j=1,4 tu(j) = ub tu(i) = ue i = i-1 105 continue go to 120 110 l1 = 4 l2 = l1 l3 = nu-3 l4 = l3 tu(l2) = ub tu(l3) = ue do 115 j=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tu(l2) = tu(l4)-peru tu(l3) = tu(l1)+peru 115 continue 120 if(ipar(2).ne.0) go to 130 i = nv do 125 j=1,4 tv(j) = vb tv(i) = ve i = i-1 125 continue go to 140 130 l1 = 4 l2 = l1 l3 = nv-3 l4 = l3 tv(l2) = vb tv(l3) = ve do 135 j=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tv(l2) = tv(l4)-perv tv(l3) = tv(l1)+perv 135 continue c find the least-squares spline sinf(u,v) and calculate for each knot c interval tu(j+3)<=u<=tu(j+4) (tv(j+3)<=v<=tv(j+4)) the sum c of squared residuals fpintu(j),j=1,2,...,nu-7 (fpintv(j),j=1,2,... c ,nv-7) for the data points having their absciss (ordinate)-value c belonging to that interval. c fp gives the total sum of squared residuals. 140 call fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,tu, * nu,tv,nv,p,c,nc,fp,fpintu,fpintv,mm,mvnu,wrk(lsu),wrk(lsv), * wrk(lri),wrk(lq),wrk(lau),wrk(lau1),wrk(lav),wrk(lav1), * wrk(lbu),wrk(lbv),nru,nrv) if(ier.eq.(-2)) fp0 = fp c test whether the least-squares spline is an acceptable solution. if(iopt.lt.0) go to 440 fpms = fp-s if(abs(fpms) .lt. acc) go to 440 c if f(p=inf) < s, we accept the choice of knots. if(fpms.lt.0.) go to 300 c if nu=nmaxu and nv=nmaxv, sinf(u,v) is an interpolating spline. if(nu.eq.nmaxu .and. nv.eq.nmaxv) go to 430 c increase the number of knots. c if nu=nue and nv=nve we cannot further increase the number of knots c because of the storage capacity limitation. if(nu.eq.nue .and. nv.eq.nve) go to 420 ier = 0 c adjust the parameter reducu or reducv according to the direction c in which the last added knots were located. if(lastdi) 150,170,160 150 reducu = fpold-fp go to 170 160 reducv = fpold-fp c store the sum of squared residuals for the current set of knots. 170 fpold = fp c find nplu, the number of knots we should add in the u-direction. nplu = 1 if(nu.eq.nminu) go to 180 npl1 = nplusu*2 rn = nplusu if(reducu.gt.acc) npl1 = rn*fpms/reducu nplu = min0(nplusu*2,max0(npl1,nplusu/2,1)) c find nplv, the number of knots we should add in the v-direction. 180 nplv = 1 if(nv.eq.nminv) go to 190 npl1 = nplusv*2 rn = nplusv if(reducv.gt.acc) npl1 = rn*fpms/reducv nplv = min0(nplusv*2,max0(npl1,nplusv/2,1)) 190 if(nplu-nplv) 210,200,230 200 if(lastdi.lt.0) go to 230 210 if(nu.eq.nue) go to 230 c addition in the u-direction. lastdi = -1 nplusu = nplu ifsu = 0 do 220 l=1,nplusu c add a new knot in the u-direction call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,1) c test whether we cannot further increase the number of knots in the c u-direction. if(nu.eq.nue) go to 250 220 continue go to 250 230 if(nv.eq.nve) go to 210 c addition in the v-direction. lastdi = 1 nplusv = nplv ifsv = 0 do 240 l=1,nplusv c add a new knot in the v-direction. call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1) c test whether we cannot further increase the number of knots in the c v-direction. if(nv.eq.nve) go to 250 240 continue c restart the computations with the new set of knots. 250 continue c test whether the least-squares polynomial is a solution of our c approximation problem. 300 if(ier.eq.(-2)) go to 440 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline sp(u,v) c c ***************************************************** c c we have determined the number of knots and their position. we now c c compute the b-spline coefficients of the smoothing spline sp(u,v). c c this smoothing spline varies with the parameter p in such a way thatc c f(p)=suml=1,idim(sumi=1,mu(sumj=1,mv((z(i,j,l)-sp(u(i),v(j),l))**2) c c is a continuous, strictly decreasing function of p. moreover the c c least-squares polynomial corresponds to p=0 and the least-squares c c spline to p=infinity. iteratively we then have to determine the c c positive value of p such that f(p)=s. the process which is proposed c c here makes use of rational interpolation. f(p) is approximated by a c c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c c are used to calculate the new value of p such that r(p)=s. c c convergence is guaranteed by taking f1 > 0 and f3 < 0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = one ich1 = 0 ich3 = 0 c iteration process to find the root of f(p)=s. do 350 iter = 1,maxit c find the smoothing spline sp(u,v) and the corresponding sum of c squared residuals fp. call fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz,tu, * nu,tv,nv,p,c,nc,fp,fpintu,fpintv,mm,mvnu,wrk(lsu),wrk(lsv), * wrk(lri),wrk(lq),wrk(lau),wrk(lau1),wrk(lav),wrk(lav1), * wrk(lbu),wrk(lbv),nru,nrv) c test whether the approximation sp(u,v) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 440 c test whether the maximum allowable number of iterations has been c reached. if(iter.eq.maxit) go to 400 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 320 if((f2-f3).gt.acc) go to 310 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 + p2*con1 go to 350 310 if(f2.lt.0.) ich3 = 1 320 if(ich1.ne.0) go to 340 if((f1-f2).gt.acc) go to 330 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 350 if(p.ge.p3) p = p2*con1 + p3*con9 go to 350 c test whether the iteration process proceeds as theoretically c expected. 330 if(f2.gt.0.) ich1 = 1 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 c find the new value of p. p = fprati(p1,f1,p2,f2,p3,f3) 350 continue c error codes and messages. 400 ier = 3 go to 440 410 ier = 2 go to 440 420 ier = 1 go to 440 430 ier = -1 fp = 0. 440 return end spd-1.3.0/fitpack/fpseno.f0000644000175000017500000000202111633462461012305 00000000000000 subroutine fpseno(maxtr,up,left,right,info,merk,ibind,nbind) c subroutine fpseno fetches a branch of a triply linked tree the c information of which is kept in the arrays up,left,right and info. c the branch has a specified length nbind and is determined by the c parameter merk which points to its terminal node. the information c field of the nodes of this branch is stored in the array ibind. on c exit merk points to a new branch of length nbind or takes the value c 1 if no such branch was found. c .. c ..scalar arguments.. integer maxtr,merk,nbind c ..array arguments.. integer up(maxtr),left(maxtr),right(maxtr),info(maxtr), * ibind(nbind) c ..scalar arguments.. integer i,j,k c .. k = merk j = nbind do 10 i=1,nbind ibind(j) = info(k) k = up(k) j = j-1 10 continue 20 k = right(merk) if(k.ne.0) go to 30 merk = up(merk) if(merk-1) 40,40,20 30 merk = k k = left(merk) if(k.ne.0) go to 30 40 return end spd-1.3.0/fitpack/fpgivs.f0000644000175000017500000000076111633462460012321 00000000000000 subroutine fpgivs(piv,ww,cos,sin) c subroutine fpgivs calculates the parameters of a givens c transformation . c .. c ..scalar arguments.. real piv,ww,cos,sin c ..local scalars.. real dd,one,store c ..function references.. real abs,sqrt c .. one = 0.1e+01 store = abs(piv) if(store.ge.ww) dd = store*sqrt(one+(ww/piv)**2) if(store.lt.ww) dd = ww*sqrt(one+(piv/ww)**2) cos = ww/dd sin = piv/dd ww = dd return end spd-1.3.0/fitpack/regrid.f0000644000175000017500000004371211633462460012302 00000000000000 subroutine regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s, * nxest,nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier) c given the set of values z(i,j) on the rectangular grid (x(i),y(j)), c i=1,...,mx;j=1,...,my, subroutine regrid determines a smooth bivar- c iate spline approximation s(x,y) of degrees kx and ky on the rect- c angle xb <= x <= xe, yb <= y <= ye. c if iopt = -1 regrid calculates the least-squares spline according c to a given set of knots. c if iopt >= 0 the total numbers nx and ny of these knots and their c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic- c ally by the routine. the smoothness of s(x,y) is then achieved by c minimalizing the discontinuity jumps in the derivatives of s(x,y) c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1). c the amounth of smoothness is determined by the condition that f(p) = c sum ((z(i,j)-s(x(i),y(j))))**2) be <= s, with s a given non-negative c constant, called the smoothing factor. c the fit is given in the b-spline representation (b-spline coefficients c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval- c uated by means of subroutine bispev. c c calling sequence: c call regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,nxest,nyest, c * nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a least- c squares spline (iopt=-1) or a smoothing spline (iopt=0 or 1) c must be determined. c if iopt=0 the routine will start with an initial set of knots c tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i= c 1,...,ky+1. if iopt=1 the routine will continue with the set c of knots found at the last call of the routine. c attention: a call with iopt=1 must always be immediately pre- c ceded by another call with iopt=1 or iopt=0 and c s.ne.0. c unchanged on exit. c mx : integer. on entry mx must specify the number of grid points c along the x-axis. mx > kx . unchanged on exit. c x : real array of dimension at least (mx). before entry, x(i) c must be set to the x-co-ordinate of the i-th grid point c along the x-axis, for i=1,2,...,mx. these values must be c supplied in strictly ascending order. unchanged on exit. c my : integer. on entry my must specify the number of grid points c along the y-axis. my > ky . unchanged on exit. c y : real array of dimension at least (my). before entry, y(j) c must be set to the y-co-ordinate of the j-th grid point c along the y-axis, for j=1,2,...,my. these values must be c supplied in strictly ascending order. unchanged on exit. c z : real array of dimension at least (mx*my). c before entry, z(my*(i-1)+j) must be set to the data value at c the grid point (x(i),y(j)) for i=1,...,mx and j=1,...,my. c unchanged on exit. c xb,xe : real values. on entry xb,xe,yb and ye must specify the bound- c yb,ye aries of the rectangular approximation domain. c xb<=x(i)<=xe,i=1,...,mx; yb<=y(j)<=ye,j=1,...,my. c unchanged on exit. c kx,ky : integer values. on entry kx and ky must specify the degrees c of the spline. 1<=kx,ky<=5. it is recommended to use bicubic c (kx=ky=3) splines. unchanged on exit. c s : real. on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments c nxest : integer. unchanged on exit. c nyest : integer. unchanged on exit. c on entry, nxest and nyest must specify an upper bound for the c number of knots required in the x- and y-directions respect. c these numbers will also determine the storage space needed by c the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1). c in most practical situation nxest = mx/2, nyest=my/2, will c be sufficient. always large enough are nxest=mx+kx+1, nyest= c my+ky+1, the number of knots needed for interpolation (s=0). c see also further comments. c nx : integer. c unless ier=10 (in case iopt >=0), nx will contain the total c number of knots with respect to the x-variable, of the spline c approximation returned. if the computation mode iopt=1 is c used, the value of nx should be left unchanged between sub- c sequent calls. c in case iopt=-1, the value of nx should be specified on entry c tx : real array of dimension nmax. c on succesful exit, this array will contain the knots of the c spline with respect to the x-variable, i.e. the position of c the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the c position of the additional knots tx(1)=...=tx(kx+1)=xb and c tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat. c if the computation mode iopt=1 is used, the values of tx(1), c ...,tx(nx) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values tx(kx+2), c ...tx(nx-kx-1) must be supplied by the user, before entry. c see also the restrictions (ier=10). c ny : integer. c unless ier=10 (in case iopt >=0), ny will contain the total c number of knots with respect to the y-variable, of the spline c approximation returned. if the computation mode iopt=1 is c used, the value of ny should be left unchanged between sub- c sequent calls. c in case iopt=-1, the value of ny should be specified on entry c ty : real array of dimension nmax. c on succesful exit, this array will contain the knots of the c spline with respect to the y-variable, i.e. the position of c the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the c position of the additional knots ty(1)=...=ty(ky+1)=yb and c ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat. c if the computation mode iopt=1 is used, the values of ty(1), c ...,ty(ny) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values ty(ky+2), c ...ty(ny-ky-1) must be supplied by the user, before entry. c see also the restrictions (ier=10). c c : real array of dimension at least (nxest-kx-1)*(nyest-ky-1). c on succesful exit, c contains the coefficients of the spline c approximation s(x,y) c fp : real. unless ier=10, fp contains the sum of squared c residuals of the spline approximation returned. c wrk : real array of dimension (lwrk). used as workspace. c if the computation mode iopt=1 is used the values of wrk(1), c ...,wrk(4) should be left unchanged between subsequent calls. c lwrk : integer. on entry lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. c lwrk must not be too small. c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ c my*(ky+1) +u c where u is the larger of my and nxest. c iwrk : integer array of dimension (kwrk). used as workspace. c if the computation mode iopt=1 is used the values of iwrk(1), c ...,iwrk(3) should be left unchanged between subsequent calls c kwrk : integer. on entry kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. c kwrk >= 3+mx+my+nxest+nyest. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is an interpolating c spline (fp=0). c ier=-2 : normal return. the spline returned is the least-squares c polynomial of degrees kx and ky. in this extreme case fp c gives the upper bound for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameters nxest and c nyest. c probably causes : nxest or nyest too small. if these param- c eters are already large, it may also indicate that s is c too small c the approximation returned is the least-squares spline c according to the current set of knots. the parameter fp c gives the corresponding sum of squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, 1<=kx,ky<=5, mx>kx, my>ky, nxest>=2*kx+2, c nyest>=2*ky+2, kwrk>=3+mx+my+nxest+nyest, c lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+ c my*(ky+1) +max(my,nxest), c xb<=x(i-1)=0: s>=0 c if s=0 : nxest>=mx+kx+1, nyest>=my+ky+1 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c regrid does not allow individual weighting of the data-values. c so, if these were determined to widely different accuracies, then c perhaps the general data set routine surfit should rather be used c in spite of efficiency. c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating spline if c s=0 and the least-squares polynomial (degrees kx,ky) if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the accuracy of the data values. c if the user has an idea of the statistical errors on the data, he c can also find a proper estimate for s. for, by assuming that, if he c specifies the right s, regrid will return a spline s(x,y) which c exactly reproduces the function underlying the data he can evaluate c the sum((z(i,j)-s(x(i),y(j)))**2) to find a good estimate for this s c for example, if he knows that the statistical errors on his z(i,j)- c values is not greater than 0.1, he may expect that a good s should c have a value not larger than mx*my*(0.1)**2. c if nothing is known about the statistical error in z(i,j), s must c be determined by trial and error, taking account of the comments c above. the best is then to start with a very large value of s (to c determine the least-squares polynomial and the corresponding upper c bound fp0 for s) and then to progressively decrease the value of s c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... c and more carefully as the approximation shows more detail) to c obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if regrid is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. if the computation mode iopt=1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c regrid once more with the selected value for s but now with iopt=0. c indeed, regrid may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c the number of knots may also depend on the upper bounds nxest and c nyest. indeed, if at a certain stage in regrid the number of knots c in one direction (say nx) has reached the value of its upper bound c (nxest), then from that moment on all subsequent knots are added c in the other (y) direction. this may indicate that the value of c nxest is too small. on the other hand, it gives the user the option c of limiting the number of knots the routine locates in any direction c for example, by setting nxest=2*kx+2 (the lowest allowable value for c nxest), the user can indicate that he wants an approximation which c is a simple polynomial of degree kx in the variable x. c c other subroutines required: c fpback,fpbspl,fpregr,fpdisc,fpgivs,fpgrre,fprati,fprota,fpchec, c fpknot c c references: c dierckx p. : a fast algorithm for smoothing data on a rectangular c grid while using spline functions, siam j.numer.anal. c 19 (1982) 1286-1304. c dierckx p. : a fast algorithm for smoothing data on a rectangular c grid while using spline functions, report tw53, dept. c computer science,k.u.leuven, 1980. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : may 1979 c latest update : march 1989 c c .. c ..scalar arguments.. real xb,xe,yb,ye,s,fp integer iopt,mx,my,kx,ky,nxest,nyest,nx,ny,lwrk,kwrk,ier c ..array arguments.. real x(mx),y(my),z(mx*my),tx(nxest),ty(nyest), * c((nxest-kx-1)*(nyest-ky-1)),wrk(lwrk) integer iwrk(kwrk) c ..local scalars.. real tol integer i,j,jwrk,kndx,kndy,knrx,knry,kwest,kx1,kx2,ky1,ky2, * lfpx,lfpy,lwest,lww,maxit,nc,nminx,nminy,mz c ..function references.. integer max0 c ..subroutine references.. c fpregr,fpchec c .. c we set up the parameters tol and maxit. maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(kx.le.0 .or. kx.gt.5) go to 70 kx1 = kx+1 kx2 = kx1+1 if(ky.le.0 .or. ky.gt.5) go to 70 ky1 = ky+1 ky2 = ky1+1 if(iopt.lt.(-1) .or. iopt.gt.1) go to 70 nminx = 2*kx1 if(mx.lt.kx1 .or. nxest.lt.nminx) go to 70 nminy = 2*ky1 if(my.lt.ky1 .or. nyest.lt.nminy) go to 70 mz = mx*my nc = (nxest-kx1)*(nyest-ky1) lwest = 4+nxest*(my+2*kx2+1)+nyest*(2*ky2+1)+mx*kx1+ * my*ky1+max0(nxest,my) kwest = 3+mx+my+nxest+nyest if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 70 if(xb.gt.x(1) .or. xe.lt.x(mx)) go to 70 do 10 i=2,mx if(x(i-1).ge.x(i)) go to 70 10 continue if(yb.gt.y(1) .or. ye.lt.y(my)) go to 70 do 20 i=2,my if(y(i-1).ge.y(i)) go to 70 20 continue if(iopt.ge.0) go to 50 if(nx.lt.nminx .or. nx.gt.nxest) go to 70 j = nx do 30 i=1,kx1 tx(i) = xb tx(j) = xe j = j-1 30 continue call fpchec(x,mx,tx,nx,kx,ier) if(ier.ne.0) go to 70 if(ny.lt.nminy .or. ny.gt.nyest) go to 70 j = ny do 40 i=1,ky1 ty(i) = yb ty(j) = ye j = j-1 40 continue call fpchec(y,my,ty,ny,ky,ier) if(ier) 70,60,70 50 if(s.lt.0.) go to 70 if(s.eq.0. .and. (nxest.lt.(mx+kx1) .or. nyest.lt.(my+ky1)) ) * go to 70 ier = 0 c we partition the working space and determine the spline approximation 60 lfpx = 5 lfpy = lfpx+nxest lww = lfpy+nyest jwrk = lwrk-4-nxest-nyest knrx = 4 knry = knrx+mx kndx = knry+my kndy = kndx+nxest call fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,nxest,nyest, * tol,maxit,nc,nx,tx,ny,ty,c,fp,wrk(1),wrk(2),wrk(3),wrk(4), * wrk(lfpx),wrk(lfpy),iwrk(1),iwrk(2),iwrk(3),iwrk(knrx), * iwrk(knry),iwrk(kndx),iwrk(kndy),wrk(lww),jwrk,ier) 70 return end spd-1.3.0/fitpack/fpopsp.f0000644000175000017500000001734211633462460012335 00000000000000 subroutine fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr, * iopt,ider,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpu,fpv, * nru,nrv,wrk,lwrk) c given the set of function values r(i,j) defined on the rectangular c grid (u(i),v(j)),i=1,2,...,mu;j=1,2,...,mv, fpopsp determines a c smooth bicubic spline approximation with given knots tu(i),i=1,..,nu c in the u-direction and tv(j),j=1,2,...,nv in the v-direction. this c spline sp(u,v) will be periodic in the variable v and will satisfy c the following constraints c c s(tu(1),v) = dr(1) , tv(4) <=v<= tv(nv-3) c c s(tu(nu),v) = dr(4) , tv(4) <=v<= tv(nv-3) c c and (if iopt(2) = 1) c c d s(tu(1),v) c ------------ = dr(2)*cos(v)+dr(3)*sin(v) , tv(4) <=v<= tv(nv-3) c d u c c and (if iopt(3) = 1) c c d s(tu(nu),v) c ------------- = dr(5)*cos(v)+dr(6)*sin(v) , tv(4) <=v<= tv(nv-3) c d u c c where the parameters dr(i) correspond to the derivative values at the c poles as defined in subroutine spgrid. c c the b-spline coefficients of sp(u,v) are determined as the least- c squares solution of an overdetermined linear system which depends c on the value of p and on the values dr(i),i=1,...,6. the correspond- c ing sum of squared residuals sq is a simple quadratic function in c the variables dr(i). these may or may not be provided. the values c dr(i) which are not given will be determined so as to minimize the c resulting sum of squared residuals sq. in that case the user must c provide some initial guess dr(i) and some estimate (dr(i)-step, c dr(i)+step) of the range of possible values for these latter. c c sp(u,v) also depends on the parameter p (p>0) in such a way that c - if p tends to infinity, sp(u,v) becomes the least-squares spline c with given knots, satisfying the constraints. c - if p tends to zero, sp(u,v) becomes the least-squares polynomial, c satisfying the constraints. c - the function f(p)=sumi=1,mu(sumj=1,mv((r(i,j)-sp(u(i),v(j)))**2) c is continuous and strictly decreasing for p>0. c c ..scalar arguments.. integer ifsu,ifsv,ifbu,ifbv,mu,mv,mr,nu,nv,nuest,nvest, * nc,lwrk real r0,r1,p,fp c ..array arguments.. integer ider(4),nru(mu),nrv(mv),iopt(3) real u(mu),v(mv),r(mr),dr(6),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv), * wrk(lwrk),step(2) c ..local scalars.. real res,sq,sqq,sq0,sq1,step1,step2,three integer i,id0,iop0,iop1,i1,j,l,lau,lav1,lav2,la0,la1,lbu,lbv,lb0, * lb1,lc0,lc1,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number c ..local arrays.. integer nr(6) real delta(6),drr(6),sum(6),a(6,6),g(6) c ..function references.. integer max0 c ..subroutine references.. c fpgrsp,fpsysy c .. c set constant three = 3 c we partition the working space lsu = 1 lsv = lsu+4*mu lri = lsv+4*mv mm = max0(nuest,mv+nvest) lq = lri+mm mvnu = nuest*(mv+nvest-8) lau = lq+mvnu lav1 = lau+5*nuest lav2 = lav1+6*nvest lbu = lav2+4*nvest lbv = lbu+5*nuest la0 = lbv+5*nvest la1 = la0+2*mv lb0 = la1+2*mv lb1 = lb0+2*nvest lc0 = lb1+2*nvest lc1 = lc0+nvest lcs = lc1+nvest c we calculate the smoothing spline sp(u,v) according to the input c values dr(i),i=1,...,6. iop0 = iopt(2) iop1 = iopt(3) id0 = ider(1) id1 = ider(3) call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) sq0 = 0. sq1 = 0. if(id0.eq.0) sq0 = (r0-dr(1))**2 if(id1.eq.0) sq1 = (r1-dr(4))**2 sq = sq+sq0+sq1 c in case all derivative values dr(i) are given (step<=0) or in case c we have spline interpolation, we accept this spline as a solution. if(sq.le.0.) return if(step(1).le.0. .and. step(2).le.0.) return do 10 i=1,6 drr(i) = dr(i) 10 continue c number denotes the number of derivative values dr(i) that still must c be optimized. let us denote these parameters by g(j),j=1,...,number. number = 0 if(id0.gt.0) go to 20 number = 1 nr(1) = 1 delta(1) = step(1) 20 if(iop0.eq.0) go to 30 if(ider(2).ne.0) go to 30 step2 = step(1)*three/(tu(5)-tu(4)) nr(number+1) = 2 nr(number+2) = 3 delta(number+1) = step2 delta(number+2) = step2 number = number+2 30 if(id1.gt.0) go to 40 number = number+1 nr(number) = 4 delta(number) = step(2) 40 if(iop1.eq.0) go to 50 if(ider(4).ne.0) go to 50 step2 = step(2)*three/(tu(nu)-tu(nu-4)) nr(number+1) = 5 nr(number+2) = 6 delta(number+1) = step2 delta(number+2) = step2 number = number+2 50 if(number.eq.0) return c the sum of squared residulas sq is a quadratic polynomial in the c parameters g(j). we determine the unknown coefficients of this c polymomial by calculating (number+1)*(number+2)/2 different splines c according to specific values for g(j). do 60 i=1,number l = nr(i) step1 = delta(i) drr(l) = dr(l)+step1 call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) if(id0.eq.0) sq0 = (r0-drr(1))**2 if(id1.eq.0) sq1 = (r1-drr(4))**2 sum(i) = sum(i)+sq0+sq1 drr(l) = dr(l)-step1 call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) if(id0.eq.0) sq0 = (r0-drr(1))**2 if(id1.eq.0) sq1 = (r1-drr(4))**2 sqq = sqq+sq0+sq1 drr(l) = dr(l) a(i,i) = (sum(i)+sqq-sq-sq)/step1**2 if(a(i,i).le.0.) go to 110 g(i) = (sqq-sum(i))/(step1+step1) 60 continue if(number.eq.1) go to 90 do 80 i=2,number l1 = nr(i) step1 = delta(i) drr(l1) = dr(l1)+step1 i1 = i-1 do 70 j=1,i1 l2 = nr(j) step2 = delta(j) drr(l2) = dr(l2)+step2 call fpgrsp(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,r,mr,drr, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) if(id0.eq.0) sq0 = (r0-drr(1))**2 if(id1.eq.0) sq1 = (r1-drr(4))**2 sqq = sqq+sq0+sq1 a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2) drr(l2) = dr(l2) 70 continue drr(l1) = dr(l1) 80 continue c the optimal values g(j) are found as the solution of the system c d (sq) / d (g(j)) = 0 , j=1,...,number. 90 call fpsysy(a,number,g) do 100 i=1,number l = nr(i) dr(l) = dr(l)+g(i) 100 continue c we determine the spline sp(u,v) according to the optimal values g(j). 110 call fpgrsp(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,r,mr,dr, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(la0),wrk(la1),wrk(lb0), * wrk(lb1),wrk(lc0),wrk(lc1),wrk(lcs),nru,nrv) if(id0.eq.0) sq0 = (r0-dr(1))**2 if(id1.eq.0) sq1 = (r1-dr(4))**2 sq = sq+sq0+sq1 return end spd-1.3.0/fitpack/fprank.f0000644000175000017500000001542711633462461012312 00000000000000 subroutine fprank(a,f,n,m,na,tol,c,sq,rank,aa,ff,h) c subroutine fprank finds the minimum norm solution of a least- c squares problem in case of rank deficiency. c c input parameters: c a : array, which contains the non-zero elements of the observation c matrix after triangularization by givens transformations. c f : array, which contains the transformed right hand side. c n : integer,wich contains the dimension of a. c m : integer, which denotes the bandwidth of a. c tol : real value, giving a threshold to determine the rank of a. c c output parameters: c c : array, which contains the minimum norm solution. c sq : real value, giving the contribution of reducing the rank c to the sum of squared residuals. c rank : integer, which contains the rank of matrix a. c c ..scalar arguments.. integer n,m,na,rank real tol,sq c ..array arguments.. real a(na,m),f(n),c(n),aa(n,m),ff(n),h(m) c ..local scalars.. integer i,ii,ij,i1,i2,j,jj,j1,j2,j3,k,kk,m1,nl real cos,fac,piv,sin,yi double precision store,stor1,stor2,stor3 c ..function references.. integer min0 c ..subroutine references.. c fpgivs,fprota c .. m1 = m-1 c the rank deficiency nl is considered to be the number of sufficient c small diagonal elements of a. nl = 0 sq = 0. do 90 i=1,n if(a(i,1).gt.tol) go to 90 c if a sufficient small diagonal element is found, we put it to c zero. the remainder of the row corresponding to that zero diagonal c element is then rotated into triangle by givens rotations . c the rank deficiency is increased by one. nl = nl+1 if(i.eq.n) go to 90 yi = f(i) do 10 j=1,m1 h(j) = a(i,j+1) 10 continue h(m) = 0. i1 = i+1 do 60 ii=i1,n i2 = min0(n-ii,m1) piv = h(1) if(piv.eq.0.) go to 30 call fpgivs(piv,a(ii,1),cos,sin) call fprota(cos,sin,yi,f(ii)) if(i2.eq.0) go to 70 do 20 j=1,i2 j1 = j+1 call fprota(cos,sin,h(j1),a(ii,j1)) h(j) = h(j1) 20 continue go to 50 30 if(i2.eq.0) go to 70 do 40 j=1,i2 h(j) = h(j+1) 40 continue 50 h(i2+1) = 0. 60 continue c add to the sum of squared residuals the contribution of deleting c the row with small diagonal element. 70 sq = sq+yi**2 90 continue c rank denotes the rank of a. rank = n-nl c let b denote the (rank*n) upper trapezoidal matrix which can be c obtained from the (n*n) upper triangular matrix a by deleting c the rows and interchanging the columns corresponding to a zero c diagonal element. if this matrix is factorized using givens c transformations as b = (r) (u) where c r is a (rank*rank) upper triangular matrix, c u is a (rank*n) orthonormal matrix c then the minimal least-squares solution c is given by c = b' v, c where v is the solution of the system (r) (r)' v = g and c g denotes the vector obtained from the old right hand side f, by c removing the elements corresponding to a zero diagonal element of a. c initialization. do 100 i=1,rank do 100 j=1,m aa(i,j) = 0. 100 continue c form in aa the upper triangular matrix obtained from a by c removing rows and columns with zero diagonal elements. form in ff c the new right hand side by removing the elements of the old right c hand side corresponding to a deleted row. ii = 0 do 120 i=1,n if(a(i,1).le.tol) go to 120 ii = ii+1 ff(ii) = f(i) aa(ii,1) = a(i,1) jj = ii kk = 1 j = i j1 = min0(j-1,m1) if(j1.eq.0) go to 120 do 110 k=1,j1 j = j-1 if(a(j,1).le.tol) go to 110 kk = kk+1 jj = jj-1 aa(jj,kk) = a(j,k+1) 110 continue 120 continue c form successively in h the columns of a with a zero diagonal element. ii = 0 do 200 i=1,n ii = ii+1 if(a(i,1).gt.tol) go to 200 ii = ii-1 if(ii.eq.0) go to 200 jj = 1 j = i j1 = min0(j-1,m1) do 130 k=1,j1 j = j-1 if(a(j,1).le.tol) go to 130 h(jj) = a(j,k+1) jj = jj+1 130 continue do 140 kk=jj,m h(kk) = 0. 140 continue c rotate this column into aa by givens transformations. jj = ii do 190 i1=1,ii j1 = min0(jj-1,m1) piv = h(1) if(piv.ne.0.) go to 160 if(j1.eq.0) go to 200 do 150 j2=1,j1 j3 = j2+1 h(j2) = h(j3) 150 continue go to 180 160 call fpgivs(piv,aa(jj,1),cos,sin) if(j1.eq.0) go to 200 kk = jj do 170 j2=1,j1 j3 = j2+1 kk = kk-1 call fprota(cos,sin,h(j3),aa(kk,j3)) h(j2) = h(j3) 170 continue 180 jj = jj-1 h(j3) = 0. 190 continue 200 continue c solve the system (aa) (f1) = ff ff(rank) = ff(rank)/aa(rank,1) i = rank-1 if(i.eq.0) go to 230 do 220 j=2,rank store = ff(i) i1 = min0(j-1,m1) k = i do 210 ii=1,i1 k = k+1 stor1 = ff(k) stor2 = aa(i,ii+1) store = store-stor1*stor2 210 continue stor1 = aa(i,1) ff(i) = store/stor1 i = i-1 220 continue c solve the system (aa)' (f2) = f1 230 ff(1) = ff(1)/aa(1,1) if(rank.eq.1) go to 260 do 250 j=2,rank store = ff(j) i1 = min0(j-1,m1) k = j do 240 ii=1,i1 k = k-1 stor1 = ff(k) stor2 = aa(k,ii+1) store = store-stor1*stor2 240 continue stor1 = aa(j,1) ff(j) = store/stor1 250 continue c premultiply f2 by the transpoze of a. 260 k = 0 do 280 i=1,n store = 0. if(a(i,1).gt.tol) k = k+1 j1 = min0(i,m) kk = k ij = i+1 do 270 j=1,j1 ij = ij-1 if(a(ij,1).le.tol) go to 270 stor1 = a(ij,j) stor2 = ff(kk) store = store+stor1*stor2 kk = kk-1 270 continue c(i) = store 280 continue c add to the sum of squared residuals the contribution of putting c to zero the small diagonal elements of matrix (a). stor3 = 0. do 310 i=1,n if(a(i,1).gt.tol) go to 310 store = f(i) i1 = min0(n-i,m1) if(i1.eq.0) go to 300 do 290 j=1,i1 ij = i+j stor1 = c(ij) stor2 = a(i,j+1) store = store-stor1*stor2 290 continue 300 fac = a(i,1)*c(i) stor1 = a(i,1) stor2 = c(i) stor1 = stor1*stor2 stor3 = stor3+stor1*(stor1-store-store) 310 continue fac = stor3 sq = sq+fac return end spd-1.3.0/fitpack/fpadno.f0000644000175000017500000000330411633462460012266 00000000000000 subroutine fpadno(maxtr,up,left,right,info,count,merk,jbind, * n1,ier) c subroutine fpadno adds a branch of length n1 to the triply linked c tree,the information of which is kept in the arrays up,left,right c and info. the information field of the nodes of this new branch is c given in the array jbind. in linking the new branch fpadno takes c account of the property of the tree that c info(k) < info(right(k)) ; info(k) < info(left(k)) c if necessary the subroutine calls subroutine fpfrno to collect the c free nodes of the tree. if no computer words are available at that c moment, the error parameter ier is set to 1. c .. c ..scalar arguments.. integer maxtr,count,merk,n1,ier c ..array arguments.. integer up(maxtr),left(maxtr),right(maxtr),info(maxtr),jbind(n1) c ..local scalars.. integer k,niveau,point logical bool c ..subroutine references.. c fpfrno c .. point = 1 niveau = 1 10 k = left(point) bool = .true. 20 if(k.eq.0) go to 50 if(info(k)-jbind(niveau)) 30,40,50 30 point = k k = right(point) bool = .false. go to 20 40 point = k niveau = niveau+1 go to 10 50 if(niveau.gt.n1) go to 90 count = count+1 if(count.le.maxtr) go to 60 call fpfrno(maxtr,up,left,right,info,point,merk,n1,count,ier) if(ier.ne.0) go to 100 60 info(count) = jbind(niveau) left(count) = 0 right(count) = k if(bool) go to 70 bool = .true. right(point) = count up(count) = up(point) go to 80 70 up(count) = point left(point) = count 80 point = count niveau = niveau+1 k = 0 go to 50 90 ier = 0 100 return end spd-1.3.0/fitpack/fpader.f0000644000175000017500000000245211633462460012263 00000000000000 subroutine fpader(t,n,c,k1,x,l,d) c subroutine fpader calculates the derivatives c (j-1) c d(j) = s (x) , j=1,2,...,k1 c of a spline of order k1 at the point t(l)<=x s we will increase the number of knots and compute the c c corresponding least-squares curve until finally fp<=s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots equals nmax = m+2*k. c c if s > 0 and c c iopt=0 we first compute the least-squares polynomial curve of c c degree k; n = nmin = 2*k+2. since s(u) must be periodic we c c find that s(u) reduces to a fixed point. c c iopt=1 we start with the set of knots found at the last c c call of the routine, except for the case that s > fp0; then c c we compute directly the least-squares polynomial curve. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc m1 = m-1 kk = k kk1 = k1 k3 = 3*k+1 nmin = 2*k1 c determine the length of the period of the splines. per = u(m)-u(1) if(iopt.lt.0) go to 50 c calculation of acc, the absolute tolerance for the root of f(p)=s. acc = tol*s c determine nmax, the number of knots for periodic spline interpolation nmax = m+2*k if(s.gt.0. .or. nmax.eq.nmin) go to 30 c if s=0, s(u) is an interpolating curve. n = nmax c test whether the required storage space exceeds the available one. if(n.gt.nest) go to 620 c find the position of the interior knots in case of interpolation. 5 if((k/2)*2 .eq.k) go to 20 do 10 i=2,m1 j = i+k t(j) = u(i) 10 continue if(s.gt.0.) go to 50 kk = k-1 kk1 = k if(kk.gt.0) go to 50 t(1) = t(m)-per t(2) = u(1) t(m+1) = u(m) t(m+2) = t(3)+per jj = 0 do 15 i=1,m1 j = i do 12 j1=1,idim jj = jj+1 c(j) = x(jj) j = j+n 12 continue 15 continue jj = 1 j = m do 17 j1=1,idim c(j) = c(jj) j = j+n jj = jj+n 17 continue fp = 0. fpint(n) = fp0 fpint(n-1) = 0. nrdata(n) = 0 go to 630 20 do 25 i=2,m1 j = i+k t(j) = (u(i)+u(i-1))*half 25 continue go to 50 c if s > 0 our initial choice depends on the value of iopt. c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares c polynomial curve. (i.e. a constant point). c if iopt=1 and fp0>s we start computing the least-squares closed c curve according the set of knots found at the last call of the c routine. 30 if(iopt.eq.0) go to 35 if(n.eq.nmin) go to 35 fp0 = fpint(n) fpold = fpint(n-1) nplus = nrdata(n) if(fp0.gt.s) go to 50 c the case that s(u) is a fixed point is treated separetely. c fp0 denotes the corresponding sum of squared residuals. 35 fp0 = 0. d1 = 0. do 37 j=1,idim z(j) = 0. 37 continue jj = 0 do 45 it=1,m1 wi = w(it) call fpgivs(wi,d1,cos,sin) do 40 j=1,idim jj = jj+1 fac = wi*x(jj) call fprota(cos,sin,fac,z(j)) fp0 = fp0+fac**2 40 continue 45 continue do 47 j=1,idim z(j) = z(j)/d1 47 continue c test whether that fixed point is a solution of our problem. fpms = fp0-s if(fpms.lt.acc .or. nmax.eq.nmin) go to 640 fpold = fp0 c test whether the required storage space exceeds the available one. if(n.ge.nest) go to 620 c start computing the least-squares closed curve with one c interior knot. nplus = 1 n = nmin+1 mm = (m+1)/2 t(k2) = u(mm) nrdata(1) = mm-2 nrdata(2) = m1-mm c main loop for the different sets of knots. m is a save upper c bound for the number of trials. 50 do 340 iter=1,m c find nrint, the number of knot intervals. nrint = n-nmin+1 c find the position of the additional knots which are needed for c the b-spline representation of s(u). if we take c t(k+1) = u(1), t(n-k) = u(m) c t(k+1-j) = t(n-k-j) - per, j=1,2,...k c t(n-k+j) = t(k+1+j) + per, j=1,2,...k c then s(u) will be a smooth closed curve if the b-spline c coefficients satisfy the following conditions c c((i-1)*n+n7+j) = c((i-1)*n+j), j=1,...k,i=1,2,...,idim (**) c with n7=n-2*k-1. t(k1) = u(1) nk1 = n-k1 nk2 = nk1+1 t(nk2) = u(m) do 60 j=1,k i1 = nk2+j i2 = nk2-j j1 = k1+j j2 = k1-j t(i1) = t(j1)+per t(j2) = t(i2)-per 60 continue c compute the b-spline coefficients of the least-squares closed curve c sinf(u). the observation matrix a is built up row by row while c taking into account condition (**) and is reduced to triangular c form by givens transformations . c at the same time fp=f(p=inf) is computed. c the n7 x n7 triangularised upper matrix a has the form c ! a1 ' ! c a = ! ' a2 ! c ! 0 ' ! c with a2 a n7 x k matrix and a1 a n10 x n10 upper triangular c matrix of bandwith k+1 ( n10 = n7-k). c initialization. do 65 i=1,nc z(i) = 0. 65 continue do 70 i=1,nk1 do 70 j=1,kk1 a1(i,j) = 0. 70 continue n7 = nk1-k n10 = n7-kk jper = 0 fp = 0. l = k1 jj = 0 do 290 it=1,m1 c fetch the current data point u(it),x(it) ui = u(it) wi = w(it) do 75 j=1,idim jj = jj+1 xi(j) = x(jj)*wi 75 continue c search for knot interval t(l) <= ui < t(l+1). 80 if(ui.lt.t(l+1)) go to 85 l = l+1 go to 80 c evaluate the (k+1) non-zero b-splines at ui and store them in q. 85 call fpbspl(t,n,k,ui,l,h) do 90 i=1,k1 q(it,i) = h(i) h(i) = h(i)*wi 90 continue l5 = l-k1 c test whether the b-splines nj,k+1(u),j=1+n7,...nk1 are all zero at ui if(l5.lt.n10) go to 285 if(jper.ne.0) go to 160 c initialize the matrix a2. do 95 i=1,n7 do 95 j=1,kk a2(i,j) = 0. 95 continue jk = n10+1 do 110 i=1,kk ik = jk do 100 j=1,kk1 if(ik.le.0) go to 105 a2(ik,i) = a1(ik,j) ik = ik-1 100 continue 105 jk = jk+1 110 continue jper = 1 c if one of the b-splines nj,k+1(u),j=n7+1,...nk1 is not zero at ui c we take account of condition (**) for setting up the new row c of the observation matrix a. this row is stored in the arrays h1 c (the part with respect to a1) and h2 (the part with c respect to a2). 160 do 170 i=1,kk h1(i) = 0. h2(i) = 0. 170 continue h1(kk1) = 0. j = l5-n10 do 210 i=1,kk1 j = j+1 l0 = j 180 l1 = l0-kk if(l1.le.0) go to 200 if(l1.le.n10) go to 190 l0 = l1-n10 go to 180 190 h1(l1) = h(i) go to 210 200 h2(l0) = h2(l0)+h(i) 210 continue c rotate the new row of the observation matrix into triangle c by givens transformations. if(n10.le.0) go to 250 c rotation with the rows 1,2,...n10 of matrix a. do 240 j=1,n10 piv = h1(1) if(piv.ne.0.) go to 214 do 212 i=1,kk h1(i) = h1(i+1) 212 continue h1(kk1) = 0. go to 240 c calculate the parameters of the givens transformation. 214 call fpgivs(piv,a1(j,1),cos,sin) c transformation to the right hand side. j1 = j do 217 j2=1,idim call fprota(cos,sin,xi(j2),z(j1)) j1 = j1+n 217 continue c transformations to the left hand side with respect to a2. do 220 i=1,kk call fprota(cos,sin,h2(i),a2(j,i)) 220 continue if(j.eq.n10) go to 250 i2 = min0(n10-j,kk) c transformations to the left hand side with respect to a1. do 230 i=1,i2 i1 = i+1 call fprota(cos,sin,h1(i1),a1(j,i1)) h1(i) = h1(i1) 230 continue h1(i1) = 0. 240 continue c rotation with the rows n10+1,...n7 of matrix a. 250 do 270 j=1,kk ij = n10+j if(ij.le.0) go to 270 piv = h2(j) if(piv.eq.0.) go to 270 c calculate the parameters of the givens transformation. call fpgivs(piv,a2(ij,j),cos,sin) c transformations to right hand side. j1 = ij do 255 j2=1,idim call fprota(cos,sin,xi(j2),z(j1)) j1 = j1+n 255 continue if(j.eq.kk) go to 280 j1 = j+1 c transformations to left hand side. do 260 i=j1,kk call fprota(cos,sin,h2(i),a2(ij,i)) 260 continue 270 continue c add contribution of this row to the sum of squares of residual c right hand sides. 280 do 282 j2=1,idim fp = fp+xi(j2)**2 282 continue go to 290 c rotation of the new row of the observation matrix into c triangle in case the b-splines nj,k+1(u),j=n7+1,...n-k-1 are all zero c at ui. 285 j = l5 do 140 i=1,kk1 j = j+1 piv = h(i) if(piv.eq.0.) go to 140 c calculate the parameters of the givens transformation. call fpgivs(piv,a1(j,1),cos,sin) c transformations to right hand side. j1 = j do 125 j2=1,idim call fprota(cos,sin,xi(j2),z(j1)) j1 = j1+n 125 continue if(i.eq.kk1) go to 150 i2 = 1 i3 = i+1 c transformations to left hand side. do 130 i1=i3,kk1 i2 = i2+1 call fprota(cos,sin,h(i1),a1(j,i2)) 130 continue 140 continue c add contribution of this row to the sum of squares of residual c right hand sides. 150 do 155 j2=1,idim fp = fp+xi(j2)**2 155 continue 290 continue fpint(n) = fp0 fpint(n-1) = fpold nrdata(n) = nplus c backward substitution to obtain the b-spline coefficients . j1 = 1 do 292 j2=1,idim call fpbacp(a1,a2,z(j1),n7,kk,c(j1),kk1,nest) j1 = j1+n 292 continue c calculate from condition (**) the remaining coefficients. do 297 i=1,k j1 = i do 295 j=1,idim j2 = j1+n7 c(j2) = c(j1) j1 = j1+n 295 continue 297 continue if(iopt.lt.0) go to 660 c test whether the approximation sinf(u) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 660 c if f(p=inf) < s accept the choice of knots. if(fpms.lt.0.) go to 350 c if n=nmax, sinf(u) is an interpolating curve. if(n.eq.nmax) go to 630 c increase the number of knots. c if n=nest we cannot increase the number of knots because of the c storage capacity limitation. if(n.eq.nest) go to 620 c determine the number of knots nplus we are going to add. npl1 = nplus*2 rn = nplus if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) nplus = min0(nplus*2,max0(npl1,nplus/2,1)) fpold = fp c compute the sum of squared residuals for each knot interval c t(j+k) <= ui <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. fpart = 0. i = 1 l = k1 jj = 0 do 320 it=1,m1 if(u(it).lt.t(l)) go to 300 new = 1 l = l+1 300 term = 0. l0 = l-k2 do 310 j2=1,idim fac = 0. j1 = l0 do 305 j=1,k1 j1 = j1+1 fac = fac+c(j1)*q(it,j) 305 continue jj = jj+1 term = term+(w(it)*(fac-x(jj)))**2 l0 = l0+n 310 continue fpart = fpart+term if(new.eq.0) go to 320 if(l.gt.k2) go to 315 fpint(nrint) = term new = 0 go to 320 315 store = term*half fpint(i) = fpart-store i = i+1 fpart = store new = 0 320 continue fpint(nrint) = fpint(nrint)+fpart do 330 l=1,nplus c add a new knot call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1) c if n=nmax we locate the knots as for interpolation if(n.eq.nmax) go to 5 c test whether we cannot further increase the number of knots. if(n.eq.nest) go to 340 330 continue c restart the computations with the new set of knots. 340 continue cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing closed curve sp(u). c c ********************************************************** c c we have determined the number of knots and their position. c c we now compute the b-spline coefficients of the smoothing curve c c sp(u). the observation matrix a is extended by the rows of matrix c c b expressing that the kth derivative discontinuities of sp(u) at c c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c c ponding weights of these additional rows are set to 1/p. c c iteratively we then have to determine the value of p such that f(p),c c the sum of squared residuals be = s. we already know that the least-c c squares polynomial curve corresponds to p=0, and that the least- c c squares periodic spline curve corresponds to p=infinity. the c c iteration process which is proposed here, makes use of rational c c interpolation. since f(p) is a convex and strictly decreasing c c function of p, it can be approximated by a rational function c c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c c to calculate the new value of p such that r(p)=s. convergence is c c guaranteed by taking f1>0 and f3<0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c evaluate the discontinuity jump of the kth derivative of the c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. 350 call fpdisc(t,n,k2,b,nest) c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms n11 = n10-1 n8 = n7-1 p = 0. l = n7 do 352 i=1,k j = k+1-i p = p+a2(l,j) l = l-1 if(l.eq.0) go to 356 352 continue do 354 i=1,n10 p = p+a1(i,1) 354 continue 356 rn = n7 p = rn/p ich1 = 0 ich3 = 0 c iteration process to find the root of f(p) = s. do 595 iter=1,maxit c form the matrix g as the matrix a extended by the rows of matrix b. c the rows of matrix b with weight 1/p are rotated into c the triangularised observation matrix a. c after triangularisation our n7 x n7 matrix g takes the form c ! g1 ' ! c g = ! ' g2 ! c ! 0 ' ! c with g2 a n7 x (k+1) matrix and g1 a n11 x n11 upper triangular c matrix of bandwidth k+2. ( n11 = n7-k-1) pinv = one/p c store matrix a into g do 358 i=1,nc c(i) = z(i) 358 continue do 360 i=1,n7 g1(i,k1) = a1(i,k1) g1(i,k2) = 0. g2(i,1) = 0. do 360 j=1,k g1(i,j) = a1(i,j) g2(i,j+1) = a2(i,j) 360 continue l = n10 do 370 j=1,k1 if(l.le.0) go to 375 g2(l,1) = a1(l,j) l = l-1 370 continue 375 do 540 it=1,n8 c fetch a new row of matrix b and store it in the arrays h1 (the part c with respect to g1) and h2 (the part with respect to g2). do 380 j=1,idim xi(j) = 0. 380 continue do 385 i=1,k1 h1(i) = 0. h2(i) = 0. 385 continue h1(k2) = 0. if(it.gt.n11) go to 420 l = it l0 = it do 390 j=1,k2 if(l0.eq.n10) go to 400 h1(j) = b(it,j)*pinv l0 = l0+1 390 continue go to 470 400 l0 = 1 do 410 l1=j,k2 h2(l0) = b(it,l1)*pinv l0 = l0+1 410 continue go to 470 420 l = 1 i = it-n10 do 460 j=1,k2 i = i+1 l0 = i 430 l1 = l0-k1 if(l1.le.0) go to 450 if(l1.le.n11) go to 440 l0 = l1-n11 go to 430 440 h1(l1) = b(it,j)*pinv go to 460 450 h2(l0) = h2(l0)+b(it,j)*pinv 460 continue if(n11.le.0) go to 510 c rotate this row into triangle by givens transformations c rotation with the rows l,l+1,...n11. 470 do 500 j=l,n11 piv = h1(1) c calculate the parameters of the givens transformation. call fpgivs(piv,g1(j,1),cos,sin) c transformation to right hand side. j1 = j do 475 j2=1,idim call fprota(cos,sin,xi(j2),c(j1)) j1 = j1+n 475 continue c transformation to the left hand side with respect to g2. do 480 i=1,k1 call fprota(cos,sin,h2(i),g2(j,i)) 480 continue if(j.eq.n11) go to 510 i2 = min0(n11-j,k1) c transformation to the left hand side with respect to g1. do 490 i=1,i2 i1 = i+1 call fprota(cos,sin,h1(i1),g1(j,i1)) h1(i) = h1(i1) 490 continue h1(i1) = 0. 500 continue c rotation with the rows n11+1,...n7 510 do 530 j=1,k1 ij = n11+j if(ij.le.0) go to 530 piv = h2(j) c calculate the parameters of the givens transformation call fpgivs(piv,g2(ij,j),cos,sin) c transformation to the right hand side. j1 = ij do 515 j2=1,idim call fprota(cos,sin,xi(j2),c(j1)) j1 = j1+n 515 continue if(j.eq.k1) go to 540 j1 = j+1 c transformation to the left hand side. do 520 i=j1,k1 call fprota(cos,sin,h2(i),g2(ij,i)) 520 continue 530 continue 540 continue c backward substitution to obtain the b-spline coefficients j1 = 1 do 542 j2=1,idim call fpbacp(g1,g2,c(j1),n7,k1,c(j1),k2,nest) j1 = j1+n 542 continue c calculate from condition (**) the remaining b-spline coefficients. do 547 i=1,k j1 = i do 545 j=1,idim j2 = j1+n7 c(j2) = c(j1) j1 = j1+n 545 continue 547 continue c computation of f(p). fp = 0. l = k1 jj = 0 do 570 it=1,m1 if(u(it).lt.t(l)) go to 550 l = l+1 550 l0 = l-k2 term = 0. do 565 j2=1,idim fac = 0. j1 = l0 do 560 j=1,k1 j1 = j1+1 fac = fac+c(j1)*q(it,j) 560 continue jj = jj+1 term = term+(fac-x(jj))**2 l0 = l0+n 565 continue fp = fp+term*w(it)**2 570 continue c test whether the approximation sp(u) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 660 c test whether the maximal number of iterations is reached. if(iter.eq.maxit) go to 600 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 580 if((f2-f3) .gt. acc) go to 575 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 +p2*con1 go to 595 575 if(f2.lt.0.) ich3 = 1 580 if(ich1.ne.0) go to 590 if((f1-f2) .gt. acc) go to 585 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 595 if(p.ge.p3) p = p2*con1 +p3*con9 go to 595 585 if(f2.gt.0.) ich1 = 1 c test whether the iteration process proceeds as theoretically c expected. 590 if(f2.ge.f1 .or. f2.le.f3) go to 610 c find the new value for p. p = fprati(p1,f1,p2,f2,p3,f3) 595 continue c error codes and messages. 600 ier = 3 go to 660 610 ier = 2 go to 660 620 ier = 1 go to 660 630 ier = -1 go to 660 640 ier = -2 c the point (z(1),z(2),...,z(idim)) is a solution of our problem. c a constant function is a spline of degree k with all b-spline c coefficients equal to that constant. do 650 i=1,k1 rn = k1-i t(i) = u(1)-rn*per j = i+k1 rn = i-1 t(j) = u(m)+rn*per 650 continue n = nmin j1 = 0 do 658 j=1,idim fac = z(j) j2 = j1 do 654 i=1,k1 j2 = j2+1 c(j2) = fac 654 continue j1 = j1+n 658 continue fp = fp0 fpint(n) = fp0 fpint(n-1) = 0. nrdata(n) = 0 660 return end spd-1.3.0/fitpack/dblint.f0000644000175000017500000000614711633462460012303 00000000000000 real function dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk) c function dblint calculates the double integral c / xe / ye c | | s(x,y) dx dy c xb / yb / c with s(x,y) a bivariate spline of degrees kx and ky, given in the c b-spline representation. c c calling sequence: c aint = dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk) c c input parameters: c tx : real array, length nx, which contains the position of the c knots in the x-direction. c nx : integer, giving the total number of knots in the x-direction c ty : real array, length ny, which contains the position of the c knots in the y-direction. c ny : integer, giving the total number of knots in the y-direction c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the c b-spline coefficients. c kx,ky : integer values, giving the degrees of the spline. c xb,xe : real values, containing the boundaries of the integration c yb,ye domain. s(x,y) is considered to be identically zero out- c side the rectangle (tx(kx+1),tx(nx-kx))*(ty(ky+1),ty(ny-ky)) c c output parameters: c aint : real , containing the double integral of s(x,y). c wrk : real array of dimension at least (nx+ny-kx-ky-2). c used as working space. c on exit, wrk(i) will contain the integral c / xe c | ni,kx+1(x) dx , i=1,2,...,nx-kx-1 c xb / c with ni,kx+1(x) the normalized b-spline defined on c the knots tx(i),...,tx(i+kx+1) c wrk(j+nx-kx-1) will contain the integral c / ye c | nj,ky+1(y) dy , j=1,2,...,ny-ky-1 c yb / c with nj,ky+1(y) the normalized b-spline defined on c the knots ty(j),...,ty(j+ky+1) c c other subroutines required: fpintb c c references : c gaffney p.w. : the calculation of indefinite integrals of b-splines c j. inst. maths applics 17 (1976) 37-41. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1989 c c ..scalar arguments.. integer nx,ny,kx,ky real xb,xe,yb,ye c ..array arguments.. real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),wrk(nx+ny-kx-ky-2) c ..local scalars.. integer i,j,l,m,nkx1,nky1 real res c .. nkx1 = nx-kx-1 nky1 = ny-ky-1 c we calculate the integrals of the normalized b-splines ni,kx+1(x) call fpintb(tx,nx,wrk,nkx1,xb,xe) c we calculate the integrals of the normalized b-splines nj,ky+1(y) call fpintb(ty,ny,wrk(nkx1+1),nky1,yb,ye) c calculate the integral of s(x,y) dblint = 0. do 200 i=1,nkx1 res = wrk(i) if(res.eq.0.) go to 200 m = (i-1)*nky1 l = nkx1 do 100 j=1,nky1 m = m+1 l = l+1 dblint = dblint+res*wrk(l)*c(m) 100 continue 200 continue return end spd-1.3.0/fitpack/fpsuev.f0000644000175000017500000000352711633462461012337 00000000000000 subroutine fpsuev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,wu,wv,lu,lv) c ..scalar arguments.. integer idim,nu,nv,mu,mv c ..array arguments.. integer lu(mu),lv(mv) real tu(nu),tv(nv),c((nu-4)*(nv-4)*idim),u(mu),v(mv), * f(mu*mv*idim),wu(mu,4),wv(mv,4) c ..local scalars.. integer i,i1,j,j1,k,l,l1,l2,l3,m,nuv,nu4,nv4 real arg,sp,tb,te c ..local arrays.. real h(4) c ..subroutine references.. c fpbspl c .. nu4 = nu-4 tb = tu(4) te = tu(nu4+1) l = 4 l1 = l+1 do 40 i=1,mu arg = u(i) if(arg.lt.tb) arg = tb if(arg.gt.te) arg = te 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 20 l = l1 l1 = l+1 go to 10 20 call fpbspl(tu,nu,3,arg,l,h) lu(i) = l-4 do 30 j=1,4 wu(i,j) = h(j) 30 continue 40 continue nv4 = nv-4 tb = tv(4) te = tv(nv4+1) l = 4 l1 = l+1 do 80 i=1,mv arg = v(i) if(arg.lt.tb) arg = tb if(arg.gt.te) arg = te 50 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 60 l = l1 l1 = l+1 go to 50 60 call fpbspl(tv,nv,3,arg,l,h) lv(i) = l-4 do 70 j=1,4 wv(i,j) = h(j) 70 continue 80 continue m = 0 nuv = nu4*nv4 do 140 k=1,idim l3 = (k-1)*nuv do 130 i=1,mu l = lu(i)*nv4+l3 do 90 i1=1,4 h(i1) = wu(i,i1) 90 continue do 120 j=1,mv l1 = l+lv(j) sp = 0. do 110 i1=1,4 l2 = l1 do 100 j1=1,4 l2 = l2+1 sp = sp+c(l2)*h(i1)*wv(j,j1) 100 continue l1 = l1+nv4 110 continue m = m+1 f(m) = sp 120 continue 130 continue 140 continue return end spd-1.3.0/fitpack/parder.f0000644000175000017500000001340511633462460012277 00000000000000 subroutine parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z, * wrk,lwrk,iwrk,kwrk,ier) c subroutine parder evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... c ,my the partial derivative ( order nux,nuy) of a bivariate spline c s(x,y) of degrees kx and ky, given in the b-spline representation. c c calling sequence: c call parder(tx,nx,ty,ny,c,kx,ky,nux,nuy,x,mx,y,my,z,wrk,lwrk, c * iwrk,kwrk,ier) c c input parameters: c tx : real array, length nx, which contains the position of the c knots in the x-direction. c nx : integer, giving the total number of knots in the x-direction c ty : real array, length ny, which contains the position of the c knots in the y-direction. c ny : integer, giving the total number of knots in the y-direction c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the c b-spline coefficients. c kx,ky : integer values, giving the degrees of the spline. c nux : integer values, specifying the order of the partial c nuy derivative. 0<=nux=1. c y : real array of dimension (my). c before entry y(j) must be set to the y co-ordinate of the c j-th grid point along the y-axis. c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. c my : on entry my must specify the number of grid points along c the y-axis. my >=1. c wrk : real array of dimension lwrk. used as workspace. c lwrk : integer, specifying the dimension of wrk. c lwrk >= mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1) c iwrk : integer array of dimension kwrk. used as workspace. c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. c c output parameters: c z : real array of dimension (mx*my). c on succesful exit z(my*(i-1)+j) contains the value of the c specified partial derivative of s(x,y) at the point c (x(i),y(j)),i=1,...,mx;j=1,...,my. c ier : integer error flag c ier=0 : normal return c ier=10: invalid input data (see restrictions) c c restrictions: c mx >=1, my >=1, 0 <= nux < kx, 0 <= nuy < ky, kwrk>=mx+my c lwrk>=mx*(kx+1-nux)+my*(ky+1-nuy)+(nx-kx-1)*(ny-ky-1), c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my c c other subroutines required: c fpbisp,fpbspl c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1989 c c ..scalar arguments.. integer nx,ny,kx,ky,nux,nuy,mx,my,lwrk,kwrk,ier c ..array arguments.. integer iwrk(kwrk) real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), * wrk(lwrk) c ..local scalars.. integer i,iwx,iwy,j,kkx,kky,kx1,ky1,lx,ly,lwest,l1,l2,m,m0,m1, * nc,nkx1,nky1,nxx,nyy real ak,fac c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 kx1 = kx+1 ky1 = ky+1 nkx1 = nx-kx1 nky1 = ny-ky1 nc = nkx1*nky1 if(nux.lt.0 .or. nux.ge.kx) go to 400 if(nuy.lt.0 .or. nuy.ge.ky) go to 400 lwest = nc +(kx1-nux)*mx+(ky1-nuy)*my if(lwrk.lt.lwest) go to 400 if(kwrk.lt.(mx+my)) go to 400 if(mx-1) 400,30,10 10 do 20 i=2,mx if(x(i).lt.x(i-1)) go to 400 20 continue 30 if(my-1) 400,60,40 40 do 50 i=2,my if(y(i).lt.y(i-1)) go to 400 50 continue 60 ier = 0 nxx = nkx1 nyy = nky1 kkx = kx kky = ky c the partial derivative of order (nux,nuy) of a bivariate spline of c degrees kx,ky is a bivariate spline of degrees kx-nux,ky-nuy. c we calculate the b-spline coefficients of this spline do 70 i=1,nc wrk(i) = c(i) 70 continue if(nux.eq.0) go to 200 lx = 1 do 100 j=1,nux ak = kkx nxx = nxx-1 l1 = lx m0 = 1 do 90 i=1,nxx l1 = l1+1 l2 = l1+kkx fac = tx(l2)-tx(l1) if(fac.le.0.) go to 90 do 80 m=1,nyy m1 = m0+nyy wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac m0 = m0+1 80 continue 90 continue lx = lx+1 kkx = kkx-1 100 continue 200 if(nuy.eq.0) go to 300 ly = 1 do 230 j=1,nuy ak = kky nyy = nyy-1 l1 = ly do 220 i=1,nyy l1 = l1+1 l2 = l1+kky fac = ty(l2)-ty(l1) if(fac.le.0.) go to 220 m0 = i do 210 m=1,nxx m1 = m0+1 wrk(m0) = (wrk(m1)-wrk(m0))*ak/fac m0 = m0+nky1 210 continue 220 continue ly = ly+1 kky = kky-1 230 continue m0 = nyy m1 = nky1 do 250 m=2,nxx do 240 i=1,nyy m0 = m0+1 m1 = m1+1 wrk(m0) = wrk(m1) 240 continue m1 = m1+nuy 250 continue c we partition the working space and evaluate the partial derivative 300 iwx = 1+nxx*nyy iwy = iwx+mx*(kx1-nux) call fpbisp(tx(nux+1),nx-2*nux,ty(nuy+1),ny-2*nuy,wrk,kkx,kky, * x,mx,y,my,z,wrk(iwx),wrk(iwy),iwrk(1),iwrk(mx+1)) 400 return end spd-1.3.0/fitpack/splder.f0000644000175000017500000001013611633462461012312 00000000000000 subroutine splder(t,n,c,k,nu,x,y,m,wrk,ier) c subroutine splder evaluates in a number of points x(i),i=1,2,...,m c the derivative of order nu of a spline s(x) of degree k,given in c its b-spline representation. c c calling sequence: c call splder(t,n,c,k,nu,x,y,m,wrk,ier) c c input parameters: c t : array,length n, which contains the position of the knots. c n : integer, giving the total number of knots of s(x). c c : array,length n, which contains the b-spline coefficients. c k : integer, giving the degree of s(x). c nu : integer, specifying the order of the derivative. 0<=nu<=k c x : array,length m, which contains the points where the deriv- c ative of s(x) must be evaluated. c m : integer, giving the number of points where the derivative c of s(x) must be evaluated c wrk : real array of dimension n. used as working space. c c output parameters: c y : array,length m, giving the value of the derivative of s(x) c at the different points. c ier : error flag c ier = 0 : normal return c ier =10 : invalid input data (see restrictions) c c restrictions: c 0 <= nu <= k c m >= 1 c t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. c c other subroutines required: fpbspl c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer n,k,nu,m,ier c ..array arguments.. real t(n),c(n),x(m),y(m),wrk(n) c ..local scalars.. integer i,j,kk,k1,k2,l,ll,l1,l2,nk1,nk2,nn real ak,arg,fac,sp,tb,te c ..local arrays .. real h(6) c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 if(nu.lt.0 .or. nu.gt.k) go to 200 if(m-1) 200,30,10 10 do 20 i=2,m if(x(i).lt.x(i-1)) go to 200 20 continue 30 ier = 0 c fetch tb and te, the boundaries of the approximation interval. k1 = k+1 nk1 = n-k1 tb = t(k1) te = t(nk1+1) c the derivative of order nu of a spline of degree k is a spline of c degree k-nu,the b-spline coefficients wrk(i) of which can be found c using the recurrence scheme of de boor. l = 1 kk = k nn = n do 40 i=1,nk1 wrk(i) = c(i) 40 continue if(nu.eq.0) go to 100 nk2 = nk1 do 60 j=1,nu ak = kk nk2 = nk2-1 l1 = l do 50 i=1,nk2 l1 = l1+1 l2 = l1+kk fac = t(l2)-t(l1) if(fac.le.0.) go to 50 wrk(i) = ak*(wrk(i+1)-wrk(i))/fac 50 continue l = l+1 kk = kk-1 60 continue if(kk.ne.0) go to 100 c if nu=k the derivative is a piecewise constant function j = 1 do 90 i=1,m arg = x(i) 70 if(arg.lt.t(l+1) .or. l.eq.nk1) go to 80 l = l+1 j = j+1 go to 70 80 y(i) = wrk(j) 90 continue go to 200 100 l = k1 l1 = l+1 k2 = k1-nu c main loop for the different points. do 180 i=1,m c fetch a new x-value arg. arg = x(i) if(arg.lt.tb) arg = tb if(arg.gt.te) arg = te c search for knot interval t(l) <= arg < t(l+1) 140 if(arg.lt.t(l1) .or. l.eq.nk1) go to 150 l = l1 l1 = l+1 go to 140 c evaluate the non-zero b-splines of degree k-nu at arg. 150 call fpbspl(t,n,kk,arg,l,h) c find the value of the derivative at x=arg. sp = 0. ll = l-k1 do 160 j=1,k2 ll = ll+1 sp = sp+wrk(ll)*h(j) 160 continue y(i) = sp 180 continue 200 return end spd-1.3.0/fitpack/fprati.f0000644000175000017500000000152111633462460012303 00000000000000 real function fprati(p1,f1,p2,f2,p3,f3) c given three points (p1,f1),(p2,f2) and (p3,f3), function fprati c gives the value of p such that the rational interpolating function c of the form r(p) = (u*p+v)/(p+w) equals zero at p. c .. c ..scalar arguments.. real p1,f1,p2,f2,p3,f3 c ..local scalars.. real h1,h2,h3,p c .. if(p3.gt.0.) go to 10 c value of p in case p3 = infinity. p = (p1*(f1-f3)*f2-p2*(f2-f3)*f1)/((f1-f2)*f3) go to 20 c value of p in case p3 ^= infinity. 10 h1 = f1*(f2-f3) h2 = f2*(f3-f1) h3 = f3*(f1-f2) p = -(p1*p2*h3+p2*p3*h1+p3*p1*h2)/(p1*h1+p2*h2+p3*h3) c adjust the value of p1,f1,p3 and f3 such that f1 > 0 and f3 < 0. 20 if(f2.lt.0.) go to 30 p1 = p2 f1 = f2 go to 40 30 p3 = p2 f3 = f2 40 fprati = p return end spd-1.3.0/fitpack/polar.f0000644000175000017500000005451111633462460012142 00000000000000 subroutine polar(iopt,m,x,y,z,w,rad,s,nuest,nvest,eps,nu,tu, * nv,tv,u,v,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) c subroutine polar fits a smooth function f(x,y) to a set of data c points (x(i),y(i),z(i)) scattered arbitrarily over an approximation c domain x**2+y**2 <= rad(atan(y/x))**2. through the transformation c x = u*rad(v)*cos(v) , y = u*rad(v)*sin(v) c the approximation problem is reduced to the determination of a bi- c cubic spline s(u,v) fitting a corresponding set of data points c (u(i),v(i),z(i)) on the rectangle 0<=u<=1,-pi<=v<=pi. c in order to have continuous partial derivatives c i+j c d f(0,0) c g(i,j) = ---------- c i j c dx dy c c s(u,v)=f(x,y) must satisfy the following conditions c c (1) s(0,v) = g(0,0) -pi <=v<= pi. c c d s(0,v) c (2) -------- = rad(v)*(cos(v)*g(1,0)+sin(v)*g(0,1)) c d u c -pi <=v<= pi c 2 c d s(0,v) 2 2 2 c (3) -------- = rad(v)*(cos(v)*g(2,0)+sin(v)*g(0,2)+sin(2*v)*g(1,1)) c 2 c d u -pi <=v<= pi c c moreover, s(u,v) must be periodic in the variable v, i.e. c c j j c d s(u,-pi) d s(u,pi) c (4) ---------- = --------- 0 <=u<= 1, j=0,1,2 c j j c d v d v c c if iopt(1) < 0 circle calculates a weighted least-squares spline c according to a given set of knots in u- and v- direction. c if iopt(1) >=0, the number of knots in each direction and their pos- c ition tu(j),j=1,2,...,nu ; tv(j),j=1,2,...,nv are chosen automatical- c ly by the routine. the smoothness of s(u,v) is then achieved by mini- c malizing the discontinuity jumps of the derivatives of the spline c at the knots. the amount of smoothness of s(u,v) is determined by c the condition that fp = sum((w(i)*(z(i)-s(u(i),v(i))))**2) be <= s, c with s a given non-negative constant. c the bicubic spline is given in its standard b-spline representation c and the corresponding function f(x,y) can be evaluated by means of c function program evapol. c c calling sequence: c call polar(iopt,m,x,y,z,w,rad,s,nuest,nvest,eps,nu,tu, c * nv,tv,u,v,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) c c parameters: c iopt : integer array of dimension 3, specifying different options. c unchanged on exit. c iopt(1):on entry iopt(1) must specify whether a weighted c least-squares polar spline (iopt(1)=-1) or a smoothing c polar spline (iopt(1)=0 or 1) must be determined. c if iopt(1)=0 the routine will start with an initial set of c knots tu(i)=0,tu(i+4)=1,i=1,...,4;tv(i)=(2*i-9)*pi,i=1,...,8. c if iopt(1)=1 the routine will continue with the set of knots c found at the last call of the routine. c attention: a call with iopt(1)=1 must always be immediately c preceded by another call with iopt(1) = 1 or iopt(1) = 0. c iopt(2):on entry iopt(2) must specify the requested order of conti- c nuity for f(x,y) at the origin. c if iopt(2)=0 only condition (1) must be fulfilled, c if iopt(2)=1 conditions (1)+(2) must be fulfilled and c if iopt(2)=2 conditions (1)+(2)+(3) must be fulfilled. c iopt(3):on entry iopt(3) must specify whether (iopt(3)=1) or not c (iopt(3)=0) the approximation f(x,y) must vanish at the c boundary of the approximation domain. c m : integer. on entry m must specify the number of data points. c m >= 4-iopt(2)-iopt(3) unchanged on exit. c x : real array of dimension at least (m). c y : real array of dimension at least (m). c z : real array of dimension at least (m). c before entry, x(i),y(i),z(i) must be set to the co-ordinates c of the i-th data point, for i=1,...,m. the order of the data c points is immaterial. unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) must c be set to the i-th value in the set of weights. the w(i) must c be strictly positive. unchanged on exit. c rad : real function subprogram defining the boundary of the approx- c imation domain, i.e x = rad(v)*cos(v) , y = rad(v)*sin(v), c -pi <= v <= pi. c must be declared external in the calling (sub)program. c s : real. on entry (in case iopt(1) >=0) s must specify the c smoothing factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments c nuest : integer. unchanged on exit. c nvest : integer. unchanged on exit. c on entry, nuest and nvest must specify an upper bound for the c number of knots required in the u- and v-directions resp. c these numbers will also determine the storage space needed by c the routine. nuest >= 8, nvest >= 8. c in most practical situation nuest = nvest = 8+sqrt(m/2) will c be sufficient. see also further comments. c eps : real. c on entry, eps must specify a threshold for determining the c effective rank of an over-determined linear system of equat- c ions. 0 < eps < 1. if the number of decimal digits in the c computer representation of a real number is q, then 10**(-q) c is a suitable value for eps in most practical applications. c unchanged on exit. c nu : integer. c unless ier=10 (in case iopt(1) >=0),nu will contain the total c number of knots with respect to the u-variable, of the spline c approximation returned. if the computation mode iopt(1)=1 c is used, the value of nu should be left unchanged between c subsequent calls. c in case iopt(1)=-1,the value of nu must be specified on entry c tu : real array of dimension at least nuest. c on succesful exit, this array will contain the knots of the c spline with respect to the u-variable, i.e. the position c of the interior knots tu(5),...,tu(nu-4) as well as the c position of the additional knots tu(1)=...=tu(4)=0 and c tu(nu-3)=...=tu(nu)=1 needed for the b-spline representation c if the computation mode iopt(1)=1 is used,the values of c tu(1),...,tu(nu) should be left unchanged between subsequent c calls. if the computation mode iopt(1)=-1 is used,the values c tu(5),...tu(nu-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c nv : integer. c unless ier=10 (in case iopt(1)>=0), nv will contain the total c number of knots with respect to the v-variable, of the spline c approximation returned. if the computation mode iopt(1)=1 c is used, the value of nv should be left unchanged between c subsequent calls. in case iopt(1)=-1, the value of nv should c be specified on entry. c tv : real array of dimension at least nvest. c on succesful exit, this array will contain the knots of the c spline with respect to the v-variable, i.e. the position of c the interior knots tv(5),...,tv(nv-4) as well as the position c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., c tv(nv) needed for the b-spline representation. c if the computation mode iopt(1)=1 is used, the values of c tv(1),...,tv(nv) should be left unchanged between subsequent c calls. if the computation mode iopt(1)=-1 is used,the values c tv(5),...tv(nv-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c u : real array of dimension at least (m). c v : real array of dimension at least (m). c on succesful exit, u(i),v(i) contains the co-ordinates of c the i-th data point with respect to the transformed rectan- c gular approximation domain, for i=1,2,...,m. c if the computation mode iopt(1)=1 is used the values of c u(i),v(i) should be left unchanged between subsequent calls. c c : real array of dimension at least (nuest-4)*(nvest-4). c on succesful exit, c contains the coefficients of the spline c approximation s(u,v). c fp : real. unless ier=10, fp contains the weighted sum of c squared residuals of the spline approximation returned. c wrk1 : real array of dimension (lwrk1). used as workspace. c if the computation mode iopt(1)=1 is used the value of c wrk1(1) should be left unchanged between subsequent calls. c on exit wrk1(2),wrk1(3),...,wrk1(1+ncof) will contain the c values d(i)/max(d(i)),i=1,...,ncof=1+iopt(2)*(iopt(2)+3)/2+ c (nv-7)*(nu-5-iopt(2)-iopt(3)) with d(i) the i-th diagonal el- c ement of the triangular matrix for calculating the b-spline c coefficients.it includes those elements whose square is < eps c which are treated as 0 in the case of rank deficiency(ier=-2) c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of c the array wrk1 as declared in the calling (sub)program. c lwrk1 must not be too small. let c k = nuest-7, l = nvest-7, p = 1+iopt(2)*(iopt(2)+3)/2, c q = k+2-iopt(2)-iopt(3) then c lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m c wrk2 : real array of dimension (lwrk2). used as workspace, but c only in the case a rank deficient system is encountered. c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of c the array wrk2 as declared in the calling (sub)program. c lwrk2 > 0 . a save upper bound for lwrk2 = (p+l*q+1)*(4*l+p) c +p+l*q where p,l,q are as above. if there are enough data c points, scattered uniformly over the approximation domain c and if the smoothing factor s is not too small, there is a c good chance that this extra workspace is not needed. a lot c of memory might therefore be saved by setting lwrk2=1. c (see also ier > 10) c iwrk : integer array of dimension (kwrk). used as workspace. c kwrk : integer. on entry kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. c kwrk >= m+(nuest-7)*(nvest-7). c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is an interpolating c spline (fp=0). c ier=-2 : normal return. the spline returned is the weighted least- c squares constrained polynomial . in this extreme case c fp gives the upper bound for the smoothing factor s. c ier<-2 : warning. the coefficients of the spline returned have been c computed as the minimal norm least-squares solution of a c (numerically) rank deficient system. (-ier) gives the rank. c especially if the rank deficiency which can be computed as c 1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2)-iopt(3))+ier c is large the results may be inaccurate. c they could also seriously depend on the value of eps. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameters nuest and c nvest. c probably causes : nuest or nvest too small. if these param- c eters are already large, it may also indicate that s is c too small c the approximation returned is the weighted least-squares c polar spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small or badly chosen eps. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=4 : error. no more knots can be added because the dimension c of the spline 1+iopt(2)*(iopt(2)+3)/2+(nv-7)*(nu-5-iopt(2) c -iopt(3)) already exceeds the number of data points m. c probably causes : either s or m too small. c the approximation returned is the weighted least-squares c polar spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=5 : error. no more knots can be added because the additional c knot would (quasi) coincide with an old one. c probably causes : s too small or too large a weight to an c inaccurate data point. c the approximation returned is the weighted least-squares c polar spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt(1)<=1 , 0<=iopt(2)<=2 , 0<=iopt(3)<=1 , c m>=4-iopt(2)-iopt(3) , nuest>=8 ,nvest >=8, 00, i=1,...,m c lwrk1 >= 129+10*k+21*l+k*l+(p+l*q)*(1+8*l+p)+8*m c kwrk >= m+(nuest-7)*(nvest-7) c if iopt(1)=-1:9<=nu<=nuest,9+iopt(2)*(iopt(2)+1)<=nv<=nvest c 0=0: s>=0 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c ier>10 : error. lwrk2 is too small, i.e. there is not enough work- c space for computing the minimal least-squares solution of c a rank deficient system of linear equations. ier gives the c requested value for lwrk2. there is no approximation re- c turned but, having saved the information contained in nu, c nv,tu,tv,wrk1,u,v and having adjusted the value of lwrk2 c and the dimension of the array wrk2 accordingly, the user c can continue at the point the program was left, by calling c polar with iopt(1)=1. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating spline if c s=0 and the constrained weighted least-squares polynomial if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c z(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in z(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the least-squares c polynomial and the corresponding upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximation shows more detail) to obtain closer fits. c to choose s very small is strongly discouraged. this considerably c increases computation time and memory requirements. it may also c cause rank-deficiency (ier<-2) and endager numerical stability. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt(1)=0. c if iopt(1)=1 the program will continue with the set of knots found c at the last call of the routine. this will save a lot of computation c time if polar is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. if the computation mode iopt(1)=1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt(1)=1,the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c polar once more with the selected value for s but now with iopt(1)=0 c indeed, polar may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c the number of knots may also depend on the upper bounds nuest and c nvest. indeed, if at a certain stage in polar the number of knots c in one direction (say nu) has reached the value of its upper bound c (nuest), then from that moment on all subsequent knots are added c in the other (v) direction. this may indicate that the value of c nuest is too small. on the other hand, it gives the user the option c of limiting the number of knots the routine locates in any direction c c other subroutines required: c fpback,fpbspl,fppola,fpdisc,fpgivs,fprank,fprati,fprota,fporde, c fprppo c c references: c dierckx p.: an algorithm for fitting data over a circle using tensor c product splines,j.comp.appl.maths 15 (1986) 161-173. c dierckx p.: an algorithm for fitting data on a circle using tensor c product splines, report tw68, dept. computer science, c k.u.leuven, 1984. c dierckx p.: curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : june 1984 c latest update : march 1989 c c .. c ..scalar arguments.. real s,eps,fp integer m,nuest,nvest,nu,nv,lwrk1,lwrk2,kwrk,ier c ..array arguments.. real x(m),y(m),z(m),w(m),tu(nuest),tv(nvest),u(m),v(m), * c((nuest-4)*(nvest-4)),wrk1(lwrk1),wrk2(lwrk2) integer iopt(3),iwrk(kwrk) c ..user specified function real rad c ..local scalars.. real tol,pi,dist,r,one integer i,ib1,ib3,ki,kn,kwest,la,lbu,lcc,lcs,lro,j * lbv,lco,lf,lff,lfp,lh,lq,lsu,lsv,lwest,maxit,ncest,ncc,nuu, * nvv,nreg,nrint,nu4,nv4,iopt1,iopt2,iopt3,ipar,nvmin c ..function references.. real atan2,sqrt external rad c ..subroutine references.. c fppola c .. c set up constants one = 1 c we set up the parameters tol and maxit. maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid,control is immediately repassed to the calling program. ier = 10 if(eps.le.0. .or. eps.ge.1.) go to 60 iopt1 = iopt(1) if(iopt1.lt.(-1) .or. iopt1.gt.1) go to 60 iopt2 = iopt(2) if(iopt2.lt.0 .or. iopt2.gt.2) go to 60 iopt3 = iopt(3) if(iopt3.lt.0 .or. iopt3.gt.1) go to 60 if(m.lt.(4-iopt2-iopt3)) go to 60 if(nuest.lt.8 .or. nvest.lt.8) go to 60 nu4 = nuest-4 nv4 = nvest-4 ncest = nu4*nv4 nuu = nuest-7 nvv = nvest-7 ipar = 1+iopt2*(iopt2+3)/2 ncc = ipar+nvv*(nuest-5-iopt2-iopt3) nrint = nuu+nvv nreg = nuu*nvv ib1 = 4*nvv ib3 = ib1+ipar lwest = ncc*(1+ib1+ib3)+2*nrint+ncest+m*8+ib3+5*nuest+12*nvest kwest = m+nreg if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 60 if(iopt1.gt.0) go to 40 do 10 i=1,m if(w(i).le.0.) go to 60 dist = x(i)**2+y(i)**2 u(i) = 0. v(i) = 0. if(dist.le.0.) go to 10 v(i) = atan2(y(i),x(i)) r = rad(v(i)) if(r.le.0.) go to 60 u(i) = sqrt(dist)/r if(u(i).gt.one) go to 60 10 continue if(iopt1.eq.0) go to 40 nuu = nu-8 if(nuu.lt.1 .or. nu.gt.nuest) go to 60 tu(4) = 0. do 20 i=1,nuu j = i+4 if(tu(j).le.tu(j-1) .or. tu(j).ge.one) go to 60 20 continue nvv = nv-8 nvmin = 9+iopt2*(iopt2+1) if(nv.lt.nvmin .or. nv.gt.nvest) go to 60 pi = atan2(0.,-one) tv(4) = -pi do 30 i=1,nvv j = i+4 if(tv(j).le.tv(j-1) .or. tv(j).ge.pi) go to 60 30 continue go to 50 40 if(s.lt.0.) go to 60 50 ier = 0 c we partition the working space and determine the spline approximation kn = 1 ki = kn+m lq = 2 la = lq+ncc*ib3 lf = la+ncc*ib1 lff = lf+ncc lfp = lff+ncest lco = lfp+nrint lh = lco+nrint lbu = lh+ib3 lbv = lbu+5*nuest lro = lbv+5*nvest lcc = lro+nvest lcs = lcc+nvest lsu = lcs+nvest*5 lsv = lsu+m*4 call fppola(iopt1,iopt2,iopt3,m,u,v,z,w,rad,s,nuest,nvest,eps,tol, * maxit,ib1,ib3,ncest,ncc,nrint,nreg,nu,tu,nv,tv,c,fp,wrk1(1), * wrk1(lfp),wrk1(lco),wrk1(lf),wrk1(lff),wrk1(lro),wrk1(lcc), * wrk1(lcs),wrk1(la),wrk1(lq),wrk1(lbu),wrk1(lbv),wrk1(lsu), * wrk1(lsv),wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier) 60 return end spd-1.3.0/fitpack/fpsphe.f0000644000175000017500000006045311633462460012314 00000000000000 subroutine fpsphe(iopt,m,teta,phi,r,w,s,ntest,npest,eta,tol,maxit, * ib1,ib3,nc,ncc,intest,nrest,nt,tt,np,tp,c,fp,sup,fpint,coord,f, * ff,row,coco,cosi,a,q,bt,bp,spt,spp,h,index,nummer,wrk,lwrk,ier) c .. c ..scalar arguments.. integer iopt,m,ntest,npest,maxit,ib1,ib3,nc,ncc,intest,nrest, * nt,np,lwrk,ier real s,eta,tol,fp,sup c ..array arguments.. real teta(m),phi(m),r(m),w(m),tt(ntest),tp(npest),c(nc), * fpint(intest),coord(intest),f(ncc),ff(nc),row(npest),coco(npest), * cosi(npest),a(ncc,ib1),q(ncc,ib3),bt(ntest,5),bp(npest,5), * spt(m,4),spp(m,4),h(ib3),wrk(lwrk) integer index(nrest),nummer(m) c ..local scalars.. real aa,acc,arg,cn,co,c1,dmax,d1,d2,eps,facc,facs,fac1,fac2,fn, * fpmax,fpms,f1,f2,f3,hti,htj,p,pi,pinv,piv,pi2,p1,p2,p3,ri,si, * sigma,sq,store,wi,rn,one,con1,con9,con4,half,ten integer i,iband,iband1,iband3,iband4,ich1,ich3,ii,ij,il,in,irot, * iter,i1,i2,i3,j,jlt,jrot,j1,j2,l,la,lf,lh,ll,lp,lt,lwest,l1,l2, * l3,l4,ncof,ncoff,npp,np4,nreg,nrint,nrr,nr1,ntt,nt4,nt6,num, * num1,rank c ..local arrays.. real ht(4),hp(4) c ..function references.. real abs,atan,fprati,sqrt,cos,sin integer min0 c ..subroutine references.. c fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota,fprpsp c .. c set constants one = 0.1e+01 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 half = 0.5e0 ten = 0.1e+02 pi = atan(one)*4 pi2 = pi+pi eps = sqrt(eta) if(iopt.lt.0) go to 70 c calculation of acc, the absolute tolerance for the root of f(p)=s. acc = tol*s if(iopt.eq.0) go to 10 if(s.lt.sup) if(np-11) 60,70,70 c if iopt=0 we begin by computing the weighted least-squares polynomial c of the form c s(teta,phi) = c1*f1(teta) + cn*fn(teta) c where f1(teta) and fn(teta) are the cubic polynomials satisfying c f1(0) = 1, f1(pi) = f1'(0) = f1'(pi) = 0 ; fn(teta) = 1-f1(teta). c the corresponding weighted sum of squared residuals gives the upper c bound sup for the smoothing factor s. 10 sup = 0. d1 = 0. d2 = 0. c1 = 0. cn = 0. fac1 = pi*(one + half) fac2 = (one + one)/pi**3 aa = 0. do 40 i=1,m wi = w(i) ri = r(i)*wi arg = teta(i) fn = fac2*arg*arg*(fac1-arg) f1 = (one-fn)*wi fn = fn*wi if(fn.eq.0.) go to 20 call fpgivs(fn,d1,co,si) call fprota(co,si,f1,aa) call fprota(co,si,ri,cn) 20 if(f1.eq.0.) go to 30 call fpgivs(f1,d2,co,si) call fprota(co,si,ri,c1) 30 sup = sup+ri*ri 40 continue if(d2.ne.0.) c1 = c1/d2 if(d1.ne.0.) cn = (cn-aa*c1)/d1 c find the b-spline representation of this least-squares polynomial nt = 8 np = 8 do 50 i=1,4 c(i) = c1 c(i+4) = c1 c(i+8) = cn c(i+12) = cn tt(i) = 0. tt(i+4) = pi tp(i) = 0. tp(i+4) = pi2 50 continue fp = sup c test whether the least-squares polynomial is an acceptable solution fpms = sup-s if(fpms.lt.acc) go to 960 c test whether we cannot further increase the number of knots. 60 if(npest.lt.11 .or. ntest.lt.9) go to 950 c find the initial set of interior knots of the spherical spline in c case iopt = 0. np = 11 tp(5) = pi*half tp(6) = pi tp(7) = tp(5)+pi nt = 9 tt(5) = tp(5) cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1 : computation of least-squares spherical splines. c c ******************************************************** c c if iopt < 0 we compute the least-squares spherical spline according c c to the given set of knots. c c if iopt >=0 we compute least-squares spherical splines with increas-c c ing numbers of knots until the corresponding sum f(p=inf)<=s. c c the initial set of knots then depends on the value of iopt: c c if iopt=0 we start with one interior knot in the teta-direction c c (pi/2) and three in the phi-direction (pi/2,pi,3*pi/2). c c if iopt>0 we start with the set of knots found at the last call c c of the routine. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c main loop for the different sets of knots. m is a save upper bound c for the number of trials. 70 do 570 iter=1,m c find the position of the additional knots which are needed for the c b-spline representation of s(teta,phi). l1 = 4 l2 = l1 l3 = np-3 l4 = l3 tp(l2) = 0. tp(l3) = pi2 do 80 i=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tp(l2) = tp(l4)-pi2 tp(l3) = tp(l1)+pi2 80 continue l = nt do 90 i=1,4 tt(i) = 0. tt(l) = pi l = l-1 90 continue c find nrint, the total number of knot intervals and nreg, the number c of panels in which the approximation domain is subdivided by the c intersection of knots. ntt = nt-7 npp = np-7 nrr = npp/2 nr1 = nrr+1 nrint = ntt+npp nreg = ntt*npp c arrange the data points according to the panel they belong to. call fporde(teta,phi,m,3,3,tt,nt,tp,np,nummer,index,nreg) c find the b-spline coefficients coco and cosi of the cubic spline c approximations sc(phi) and ss(phi) for cos(phi) and sin(phi). do 100 i=1,npp coco(i) = 0. cosi(i) = 0. do 100 j=1,npp a(i,j) = 0. 100 continue c the coefficients coco and cosi are obtained from the conditions c sc(tp(i))=cos(tp(i)),resp. ss(tp(i))=sin(tp(i)),i=4,5,...np-4. do 150 i=1,npp l2 = i+3 arg = tp(l2) call fpbspl(tp,np,3,arg,l2,hp) do 110 j=1,npp row(j) = 0. 110 continue ll = i do 120 j=1,3 if(ll.gt.npp) ll= 1 row(ll) = row(ll)+hp(j) ll = ll+1 120 continue facc = cos(arg) facs = sin(arg) do 140 j=1,npp piv = row(j) if(piv.eq.0.) go to 140 call fpgivs(piv,a(j,1),co,si) call fprota(co,si,facc,coco(j)) call fprota(co,si,facs,cosi(j)) if(j.eq.npp) go to 150 j1 = j+1 i2 = 1 do 130 l=j1,npp i2 = i2+1 call fprota(co,si,row(l),a(j,i2)) 130 continue 140 continue 150 continue call fpback(a,coco,npp,npp,coco,ncc) call fpback(a,cosi,npp,npp,cosi,ncc) c find ncof, the dimension of the spherical spline and ncoff, the c number of coefficients in the standard b-spline representation. nt4 = nt-4 np4 = np-4 ncoff = nt4*np4 ncof = 6+npp*(ntt-1) c find the bandwidth of the observation matrix a. iband = 4*npp if(ntt.eq.4) iband = 3*(npp+1) if(ntt.lt.4) iband = ncof iband1 = iband-1 c initialize the observation matrix a. do 160 i=1,ncof f(i) = 0. do 160 j=1,iband a(i,j) = 0. 160 continue c initialize the sum of squared residuals. fp = 0. c fetch the data points in the new order. main loop for the c different panels. do 340 num=1,nreg c fix certain constants for the current panel; jrot records the column c number of the first non-zero element in a row of the observation c matrix according to a data point of the panel. num1 = num-1 lt = num1/npp l1 = lt+4 lp = num1-lt*npp+1 l2 = lp+3 lt = lt+1 jrot = 0 if(lt.gt.2) jrot = 3+(lt-3)*npp c test whether there are still data points in the current panel. in = index(num) 170 if(in.eq.0) go to 340 c fetch a new data point. wi = w(in) ri = r(in)*wi c evaluate for the teta-direction, the 4 non-zero b-splines at teta(in) call fpbspl(tt,nt,3,teta(in),l1,ht) c evaluate for the phi-direction, the 4 non-zero b-splines at phi(in) call fpbspl(tp,np,3,phi(in),l2,hp) c store the value of these b-splines in spt and spp resp. do 180 i=1,4 spp(in,i) = hp(i) spt(in,i) = ht(i) 180 continue c initialize the new row of observation matrix. do 190 i=1,iband h(i) = 0. 190 continue c calculate the non-zero elements of the new row by making the cross c products of the non-zero b-splines in teta- and phi-direction and c by taking into account the conditions of the spherical splines. do 200 i=1,npp row(i) = 0. 200 continue c take into account the condition (3) of the spherical splines. ll = lp do 210 i=1,4 if(ll.gt.npp) ll=1 row(ll) = row(ll)+hp(i) ll = ll+1 210 continue c take into account the other conditions of the spherical splines. if(lt.gt.2 .and. lt.lt.(ntt-1)) go to 230 facc = 0. facs = 0. do 220 i=1,npp facc = facc+row(i)*coco(i) facs = facs+row(i)*cosi(i) 220 continue c fill in the non-zero elements of the new row. 230 j1 = 0 do 280 j =1,4 jlt = j+lt htj = ht(j) if(jlt.gt.2 .and. jlt.le.nt4) go to 240 j1 = j1+1 h(j1) = h(j1)+htj go to 280 240 if(jlt.eq.3 .or. jlt.eq.nt4) go to 260 do 250 i=1,npp j1 = j1+1 h(j1) = row(i)*htj 250 continue go to 280 260 if(jlt.eq.3) go to 270 h(j1+1) = facc*htj h(j1+2) = facs*htj h(j1+3) = htj j1 = j1+2 go to 280 270 h(1) = h(1)+htj h(2) = facc*htj h(3) = facs*htj j1 = 3 280 continue do 290 i=1,iband h(i) = h(i)*wi 290 continue c rotate the row into triangle by givens transformations. irot = jrot do 310 i=1,iband irot = irot+1 piv = h(i) if(piv.eq.0.) go to 310 c calculate the parameters of the givens transformation. call fpgivs(piv,a(irot,1),co,si) c apply that transformation to the right hand side. call fprota(co,si,ri,f(irot)) if(i.eq.iband) go to 320 c apply that transformation to the left hand side. i2 = 1 i3 = i+1 do 300 j=i3,iband i2 = i2+1 call fprota(co,si,h(j),a(irot,i2)) 300 continue 310 continue c add the contribution of the row to the sum of squares of residual c right hand sides. 320 fp = fp+ri**2 c find the number of the next data point in the panel. 330 in = nummer(in) go to 170 340 continue c find dmax, the maximum value for the diagonal elements in the reduced c triangle. dmax = 0. do 350 i=1,ncof if(a(i,1).le.dmax) go to 350 dmax = a(i,1) 350 continue c check whether the observation matrix is rank deficient. sigma = eps*dmax do 360 i=1,ncof if(a(i,1).le.sigma) go to 370 360 continue c backward substitution in case of full rank. call fpback(a,f,ncof,iband,c,ncc) rank = ncof do 365 i=1,ncof q(i,1) = a(i,1)/dmax 365 continue go to 390 c in case of rank deficiency, find the minimum norm solution. 370 lwest = ncof*iband+ncof+iband if(lwrk.lt.lwest) go to 925 lf = 1 lh = lf+ncof la = lh+iband do 380 i=1,ncof ff(i) = f(i) do 380 j=1,iband q(i,j) = a(i,j) 380 continue call fprank(q,ff,ncof,iband,ncc,sigma,c,sq,rank,wrk(la), * wrk(lf),wrk(lh)) do 385 i=1,ncof q(i,1) = q(i,1)/dmax 385 continue c add to the sum of squared residuals, the contribution of reducing c the rank. fp = fp+sq c find the coefficients in the standard b-spline representation of c the spherical spline. 390 call fprpsp(nt,np,coco,cosi,c,ff,ncoff) c test whether the least-squares spline is an acceptable solution. if(iopt.lt.0) if(fp) 970,970,980 fpms = fp-s if(abs(fpms).le.acc) if(fp) 970,970,980 c if f(p=inf) < s, accept the choice of knots. if(fpms.lt.0.) go to 580 c test whether we cannot further increase the number of knots. if(ncof.gt.m) go to 935 c search where to add a new knot. c find for each interval the sum of squared residuals fpint for the c data points having the coordinate belonging to that knot interval. c calculate also coord which is the same sum, weighted by the position c of the data points considered. 440 do 450 i=1,nrint fpint(i) = 0. coord(i) = 0. 450 continue do 490 num=1,nreg num1 = num-1 lt = num1/npp l1 = lt+1 lp = num1-lt*npp l2 = lp+1+ntt jrot = lt*np4+lp in = index(num) 460 if(in.eq.0) go to 490 store = 0. i1 = jrot do 480 i=1,4 hti = spt(in,i) j1 = i1 do 470 j=1,4 j1 = j1+1 store = store+hti*spp(in,j)*c(j1) 470 continue i1 = i1+np4 480 continue store = (w(in)*(r(in)-store))**2 fpint(l1) = fpint(l1)+store coord(l1) = coord(l1)+store*teta(in) fpint(l2) = fpint(l2)+store coord(l2) = coord(l2)+store*phi(in) in = nummer(in) go to 460 490 continue c find the interval for which fpint is maximal on the condition that c there still can be added a knot. l1 = 1 l2 = nrint if(ntest.lt.nt+1) l1=ntt+1 if(npest.lt.np+2) l2=ntt c test whether we cannot further increase the number of knots. if(l1.gt.l2) go to 950 500 fpmax = 0. l = 0 do 510 i=l1,l2 if(fpmax.ge.fpint(i)) go to 510 l = i fpmax = fpint(i) 510 continue if(l.eq.0) go to 930 c calculate the position of the new knot. arg = coord(l)/fpint(l) c test in what direction the new knot is going to be added. if(l.gt.ntt) go to 530 c addition in the teta-direction l4 = l+4 fpint(l) = 0. fac1 = tt(l4)-arg fac2 = arg-tt(l4-1) if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 j = nt do 520 i=l4,nt tt(j+1) = tt(j) j = j-1 520 continue tt(l4) = arg nt = nt+1 go to 570 c addition in the phi-direction 530 l4 = l+4-ntt if(arg.lt.pi) go to 540 arg = arg-pi l4 = l4-nrr 540 fpint(l) = 0. fac1 = tp(l4)-arg fac2 = arg-tp(l4-1) if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 ll = nrr+4 j = ll do 550 i=l4,ll tp(j+1) = tp(j) j = j-1 550 continue tp(l4) = arg np = np+2 nrr = nrr+1 do 560 i=5,ll j = i+nrr tp(j) = tp(i)+pi 560 continue c restart the computations with the new set of knots. 570 continue cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spherical spline. c c ******************************************************** c c we have determined the number of knots and their position. we now c c compute the coefficients of the smoothing spline sp(teta,phi). c c the observation matrix a is extended by the rows of a matrix, expres-c c sing that sp(teta,phi) must be a constant function in the variable c c phi and a cubic polynomial in the variable teta. the corresponding c c weights of these additional rows are set to 1/(p). iteratively c c we than have to determine the value of p such that f(p) = sum((w(i)* c c (r(i)-sp(teta(i),phi(i))))**2) be = s. c c we already know that the least-squares polynomial corresponds to p=0,c c and that the least-squares spherical spline corresponds to p=infin. c c the iteration process makes use of rational interpolation. since f(p)c c is a convex and strictly decreasing function of p, it can be approx- c c imated by a rational function of the form r(p) = (u*p+v)/(p+w). c c three values of p (p1,p2,p3) with corresponding values of f(p) (f1= c c f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the new value c c of p such that r(p)=s. convergence is guaranteed by taking f1>0,f3<0.c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c evaluate the discontinuity jumps of the 3-th order derivative of c the b-splines at the knots tt(l),l=5,...,nt-4. 580 call fpdisc(tt,nt,5,bt,ntest) c evaluate the discontinuity jumps of the 3-th order derivative of c the b-splines at the knots tp(l),l=5,...,np-4. call fpdisc(tp,np,5,bp,npest) c initial value for p. p1 = 0. f1 = sup-s p3 = -one f3 = fpms p = 0. do 585 i=1,ncof p = p+a(i,1) 585 continue rn = ncof p = rn/p c find the bandwidth of the extended observation matrix. iband4 = iband+3 if(ntt.le.4) iband4 = ncof iband3 = iband4 -1 ich1 = 0 ich3 = 0 c iteration process to find the root of f(p)=s. do 920 iter=1,maxit pinv = one/p c store the triangularized observation matrix into q. do 600 i=1,ncof ff(i) = f(i) do 590 j=1,iband4 q(i,j) = 0. 590 continue do 600 j=1,iband q(i,j) = a(i,j) 600 continue c extend the observation matrix with the rows of a matrix, expressing c that for teta=cst. sp(teta,phi) must be a constant function. nt6 = nt-6 do 720 i=5,np4 ii = i-4 do 610 l=1,npp row(l) = 0. 610 continue ll = ii do 620 l=1,5 if(ll.gt.npp) ll=1 row(ll) = row(ll)+bp(ii,l) ll = ll+1 620 continue facc = 0. facs = 0. do 630 l=1,npp facc = facc+row(l)*coco(l) facs = facs+row(l)*cosi(l) 630 continue do 720 j=1,nt6 c initialize the new row. do 640 l=1,iband h(l) = 0. 640 continue c fill in the non-zero elements of the row. jrot records the column c number of the first non-zero element in the row. jrot = 4+(j-2)*npp if(j.gt.1 .and. j.lt.nt6) go to 650 h(1) = facc h(2) = facs if(j.eq.1) jrot = 2 go to 670 650 do 660 l=1,npp h(l)=row(l) 660 continue 670 do 675 l=1,iband h(l) = h(l)*pinv 675 continue ri = 0. c rotate the new row into triangle by givens transformations. do 710 irot=jrot,ncof piv = h(1) i2 = min0(iband1,ncof-irot) if(piv.eq.0.) if(i2) 720,720,690 c calculate the parameters of the givens transformation. call fpgivs(piv,q(irot,1),co,si) c apply that givens transformation to the right hand side. call fprota(co,si,ri,ff(irot)) if(i2.eq.0) go to 720 c apply that givens transformation to the left hand side. do 680 l=1,i2 l1 = l+1 call fprota(co,si,h(l1),q(irot,l1)) 680 continue 690 do 700 l=1,i2 h(l) = h(l+1) 700 continue h(i2+1) = 0. 710 continue 720 continue c extend the observation matrix with the rows of a matrix expressing c that for phi=cst. sp(teta,phi) must be a cubic polynomial. do 810 i=5,nt4 ii = i-4 do 810 j=1,npp c initialize the new row do 730 l=1,iband4 h(l) = 0. 730 continue c fill in the non-zero elements of the row. jrot records the column c number of the first non-zero element in the row. j1 = 1 do 760 l=1,5 il = ii+l ij = npp if(il.ne.3 .and. il.ne.nt4) go to 750 j1 = j1+3-j j2 = j1-2 ij = 0 if(il.ne.3) go to 740 j1 = 1 j2 = 2 ij = j+2 740 h(j2) = bt(ii,l)*coco(j) h(j2+1) = bt(ii,l)*cosi(j) 750 h(j1) = h(j1)+bt(ii,l) j1 = j1+ij 760 continue do 765 l=1,iband4 h(l) = h(l)*pinv 765 continue ri = 0. jrot = 1 if(ii.gt.2) jrot = 3+j+(ii-3)*npp c rotate the new row into triangle by givens transformations. do 800 irot=jrot,ncof piv = h(1) i2 = min0(iband3,ncof-irot) if(piv.eq.0.) if(i2) 810,810,780 c calculate the parameters of the givens transformation. call fpgivs(piv,q(irot,1),co,si) c apply that givens transformation to the right hand side. call fprota(co,si,ri,ff(irot)) if(i2.eq.0) go to 810 c apply that givens transformation to the left hand side. do 770 l=1,i2 l1 = l+1 call fprota(co,si,h(l1),q(irot,l1)) 770 continue 780 do 790 l=1,i2 h(l) = h(l+1) 790 continue h(i2+1) = 0. 800 continue 810 continue c find dmax, the maximum value for the diagonal elements in the c reduced triangle. dmax = 0. do 820 i=1,ncof if(q(i,1).le.dmax) go to 820 dmax = q(i,1) 820 continue c check whether the matrix is rank deficient. sigma = eps*dmax do 830 i=1,ncof if(q(i,1).le.sigma) go to 840 830 continue c backward substitution in case of full rank. call fpback(q,ff,ncof,iband4,c,ncc) rank = ncof go to 845 c in case of rank deficiency, find the minimum norm solution. 840 lwest = ncof*iband4+ncof+iband4 if(lwrk.lt.lwest) go to 925 lf = 1 lh = lf+ncof la = lh+iband4 call fprank(q,ff,ncof,iband4,ncc,sigma,c,sq,rank,wrk(la), * wrk(lf),wrk(lh)) 845 do 850 i=1,ncof q(i,1) = q(i,1)/dmax 850 continue c find the coefficients in the standard b-spline representation of c the spherical spline. call fprpsp(nt,np,coco,cosi,c,ff,ncoff) c compute f(p). fp = 0. do 890 num = 1,nreg num1 = num-1 lt = num1/npp lp = num1-lt*npp jrot = lt*np4+lp in = index(num) 860 if(in.eq.0) go to 890 store = 0. i1 = jrot do 880 i=1,4 hti = spt(in,i) j1 = i1 do 870 j=1,4 j1 = j1+1 store = store+hti*spp(in,j)*c(j1) 870 continue i1 = i1+np4 880 continue fp = fp+(w(in)*(r(in)-store))**2 in = nummer(in) go to 860 890 continue c test whether the approximation sp(teta,phi) is an acceptable solution fpms = fp-s if(abs(fpms).le.acc) go to 980 c test whether the maximum allowable number of iterations has been c reached. if(iter.eq.maxit) go to 940 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 900 if((f2-f3).gt.acc) go to 895 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 + p2*con1 go to 920 895 if(f2.lt.0.) ich3 = 1 900 if(ich1.ne.0) go to 910 if((f1-f2).gt.acc) go to 905 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 920 if(p.ge.p3) p = p2*con1 +p3*con9 go to 920 905 if(f2.gt.0.) ich1 = 1 c test whether the iteration process proceeds as theoretically c expected. 910 if(f2.ge.f1 .or. f2.le.f3) go to 945 c find the new value of p. p = fprati(p1,f1,p2,f2,p3,f3) 920 continue c error codes and messages. 925 ier = lwest go to 990 930 ier = 5 go to 990 935 ier = 4 go to 990 940 ier = 3 go to 990 945 ier = 2 go to 990 950 ier = 1 go to 990 960 ier = -2 go to 990 970 ier = -1 fp = 0. 980 if(ncof.ne.rank) ier = -rank 990 return end spd-1.3.0/fitpack/fpgrpa.f0000644000175000017500000002256111633462460012304 00000000000000 subroutine fpgrpa(ifsu,ifsv,ifbu,ifbv,idim,ipar,u,mu,v,mv,z,mz, * tu,nu,tv,nv,p,c,nc,fp,fpu,fpv,mm,mvnu,spu,spv,right,q,au,au1, * av,av1,bu,bv,nru,nrv) c .. c ..scalar arguments.. real p,fp integer ifsu,ifsv,ifbu,ifbv,idim,mu,mv,mz,nu,nv,nc,mm,mvnu c ..array arguments.. real u(mu),v(mv),z(mz*idim),tu(nu),tv(nv),c(nc*idim),fpu(nu), * fpv(nv),spu(mu,4),spv(mv,4),right(mm*idim),q(mvnu),au(nu,5), * au1(nu,4),av(nv,5),av1(nv,4),bu(nu,5),bv(nv,5) integer ipar(2),nru(mu),nrv(mv) c ..local scalars.. real arg,fac,term,one,half,value integer i,id,ii,it,iz,i1,i2,j,jz,k,k1,k2,l,l1,l2,mvv,k0,muu, * ncof,nroldu,nroldv,number,nmd,numu,numu1,numv,numv1,nuu,nvv, * nu4,nu7,nu8,nv4,nv7,nv8 c ..local arrays.. real h(5) c ..subroutine references.. c fpback,fpbspl,fpdisc,fpbacp,fptrnp,fptrpe c .. c let c | (spu) | | (spv) | c (au) = | ---------- | (av) = | ---------- | c | (1/p) (bu) | | (1/p) (bv) | c c | z ' 0 | c q = | ------ | c | 0 ' 0 | c c with c : the (nu-4) x (nv-4) matrix which contains the b-spline c coefficients. c z : the mu x mv matrix which contains the function values. c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices c according to the least-squares problems in the u-,resp. c v-direction. c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices c containing the discontinuity jumps of the derivatives c of the b-splines in the u-,resp.v-variable at the knots c the b-spline coefficients of the smoothing spline are then calculated c as the least-squares solution of the following over-determined linear c system of equations c c (1) (av) c (au)' = q c c subject to the constraints c c (2) c(nu-3+i,j) = c(i,j), i=1,2,3 ; j=1,2,...,nv-4 c if(ipar(1).ne.0) c c (3) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4 c if(ipar(2).ne.0) c c set constants one = 1 half = 0.5 c initialization nu4 = nu-4 nu7 = nu-7 nu8 = nu-8 nv4 = nv-4 nv7 = nv-7 nv8 = nv-8 muu = mu if(ipar(1).ne.0) muu = mu-1 mvv = mv if(ipar(2).ne.0) mvv = mv-1 c it depends on the value of the flags ifsu,ifsv,ifbu and ibvand c on the value of p whether the matrices (spu), (spv), (bu) and (bv) c still must be determined. if(ifsu.ne.0) go to 50 c calculate the non-zero elements of the matrix (spu) which is the ob- c servation matrix according to the least-squares spline approximation c problem in the u-direction. l = 4 l1 = 5 number = 0 do 40 it=1,muu arg = u(it) 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 20 l = l1 l1 = l+1 number = number+1 go to 10 20 call fpbspl(tu,nu,3,arg,l,h) do 30 i=1,4 spu(it,i) = h(i) 30 continue nru(it) = number 40 continue ifsu = 1 c calculate the non-zero elements of the matrix (spv) which is the ob- c servation matrix according to the least-squares spline approximation c problem in the v-direction. 50 if(ifsv.ne.0) go to 100 l = 4 l1 = 5 number = 0 do 90 it=1,mvv arg = v(it) 60 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 70 l = l1 l1 = l+1 number = number+1 go to 60 70 call fpbspl(tv,nv,3,arg,l,h) do 80 i=1,4 spv(it,i) = h(i) 80 continue nrv(it) = number 90 continue ifsv = 1 100 if(p.le.0.) go to 150 c calculate the non-zero elements of the matrix (bu). if(ifbu.ne.0 .or. nu8.eq.0) go to 110 call fpdisc(tu,nu,5,bu,nu) ifbu = 1 c calculate the non-zero elements of the matrix (bv). 110 if(ifbv.ne.0 .or. nv8.eq.0) go to 150 call fpdisc(tv,nv,5,bv,nv) ifbv = 1 c substituting (2) and (3) into (1), we obtain the overdetermined c system c (4) (avv) (cr) (auu)' = (qq) c from which the nuu*nvv remaining coefficients c c(i,j) , i=1,...,nu-4-3*ipar(1) ; j=1,...,nv-4-3*ipar(2) , c the elements of (cr), are then determined in the least-squares sense. c we first determine the matrices (auu) and (qq). then we reduce the c matrix (auu) to upper triangular form (ru) using givens rotations. c we apply the same transformations to the rows of matrix qq to obtain c the (mv) x nuu matrix g. c we store matrix (ru) into au (and au1 if ipar(1)=1) and g into q. 150 if(ipar(1).ne.0) go to 160 nuu = nu4 call fptrnp(mu,mv,idim,nu,nru,spu,p,bu,z,au,q,right) go to 180 160 nuu = nu7 call fptrpe(mu,mv,idim,nu,nru,spu,p,bu,z,au,au1,q,right) c we determine the matrix (avv) and then we reduce this matrix to c upper triangular form (rv) using givens rotations. c we apply the same transformations to the columns of matrix c g to obtain the (nvv) x (nuu) matrix h. c we store matrix (rv) into av (and av1 if ipar(2)=1) and h into c. 180 if(ipar(2).ne.0) go to 190 nvv = nv4 call fptrnp(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,c,right) go to 200 190 nvv = nv7 call fptrpe(mv,nuu,idim,nv,nrv,spv,p,bv,q,av,av1,c,right) c backward substitution to obtain the b-spline coefficients as the c solution of the linear system (rv) (cr) (ru)' = h. c first step: solve the system (rv) (c1) = h. 200 ncof = nuu*nvv k = 1 if(ipar(2).ne.0) go to 240 do 220 ii=1,idim do 220 i=1,nuu call fpback(av,c(k),nvv,5,c(k),nv) k = k+nvv 220 continue go to 300 240 do 260 ii=1,idim do 260 i=1,nuu call fpbacp(av,av1,c(k),nvv,4,c(k),5,nv) k = k+nvv 260 continue c second step: solve the system (cr) (ru)' = (c1). 300 if(ipar(1).ne.0) go to 400 do 360 ii=1,idim k = (ii-1)*ncof do 360 j=1,nvv k = k+1 l = k do 320 i=1,nuu right(i) = c(l) l = l+nvv 320 continue call fpback(au,right,nuu,5,right,nu) l = k do 340 i=1,nuu c(l) = right(i) l = l+nvv 340 continue 360 continue go to 500 400 do 460 ii=1,idim k = (ii-1)*ncof do 460 j=1,nvv k = k+1 l = k do 420 i=1,nuu right(i) = c(l) l = l+nvv 420 continue call fpbacp(au,au1,right,nuu,4,right,5,nu) l = k do 440 i=1,nuu c(l) = right(i) l = l+nvv 440 continue 460 continue c calculate from the conditions (2)-(3), the remaining b-spline c coefficients. 500 if(ipar(2).eq.0) go to 600 i = 0 j = 0 do 560 id=1,idim do 560 l=1,nuu ii = i do 520 k=1,nvv i = i+1 j = j+1 q(i) = c(j) 520 continue do 540 k=1,3 ii = ii+1 i = i+1 q(i) = q(ii) 540 continue 560 continue ncof = nv4*nuu nmd = ncof*idim do 580 i=1,nmd c(i) = q(i) 580 continue 600 if(ipar(1).eq.0) go to 700 i = 0 j = 0 n33 = 3*nv4 do 660 id=1,idim ii = i do 620 k=1,ncof i = i+1 j = j+1 q(i) = c(j) 620 continue do 640 k=1,n33 ii = ii+1 i = i+1 q(i) = q(ii) 640 continue 660 continue ncof = nv4*nu4 nmd = ncof*idim do 680 i=1,nmd c(i) = q(i) 680 continue c calculate the quantities c res(i,j) = (z(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv c fp = sumi=1,mu(sumj=1,mv(res(i,j))) c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7 c tu(r+3) <= u(i) <= tu(r+4) c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7 c tv(r+3) <= v(j) <= tv(r+4) 700 fp = 0. do 720 i=1,nu fpu(i) = 0. 720 continue do 740 i=1,nv fpv(i) = 0. 740 continue nroldu = 0 c main loop for the different grid points. do 860 i1=1,muu numu = nru(i1) numu1 = numu+1 nroldv = 0 iz = (i1-1)*mv do 840 i2=1,mvv numv = nrv(i2) numv1 = numv+1 iz = iz+1 c evaluate s(u,v) at the current grid point by making the sum of the c cross products of the non-zero b-splines at (u,v), multiplied with c the appropiate b-spline coefficients. term = 0. k0 = numu*nv4+numv jz = iz do 800 id=1,idim k1 = k0 value = 0. do 780 l1=1,4 k2 = k1 fac = spu(i1,l1) do 760 l2=1,4 k2 = k2+1 value = value+fac*spv(i2,l2)*c(k2) 760 continue k1 = k1+nv4 780 continue c calculate the squared residual at the current grid point. term = term+(z(jz)-value)**2 jz = jz+mz k0 = k0+ncof 800 continue c adjust the different parameters. fp = fp+term fpu(numu1) = fpu(numu1)+term fpv(numv1) = fpv(numv1)+term fac = term*half if(numv.eq.nroldv) go to 820 fpv(numv1) = fpv(numv1)-fac fpv(numv) = fpv(numv)+fac 820 nroldv = numv if(numu.eq.nroldu) go to 840 fpu(numu1) = fpu(numu1)-fac fpu(numu) = fpu(numu)+fac 840 continue nroldu = numu 860 continue return end spd-1.3.0/fitpack/fpcoco.f0000644000175000017500000001210611633462461012271 00000000000000 subroutine fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx, * bind,e,wrk,lwrk,iwrk,kwrk,ier) c ..scalar arguments.. real s,sq integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier c ..array arguments.. integer iwrk(kwrk) real x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),e(nest),wrk(lwrk) logical bind(nest) c ..local scalars.. integer i,ia,ib,ic,iq,iu,iz,izz,i1,j,k,l,l1,m1,nmax,nr,n4,n6,n8, * ji,jib,jjb,jl,jr,ju,mb,nm real sql,sqmax,term,tj,xi,half c ..subroutine references.. c fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno c .. c set constant half = 0.5e0 c determine the maximal admissible number of knots. nmax = m+4 c the initial choice of knots depends on the value of iopt. c if iopt=0 the program starts with the minimal number of knots c so that can be guarantied that the concavity/convexity constraints c will be satisfied. c if iopt = 1 the program will continue from the point on where she c left at the foregoing call. if(iopt.gt.0) go to 80 c find the minimal number of knots. c a knot is located at the data point x(i), i=2,3,...m-1 if c 1) v(i) ^= 0 and c 2) v(i)*v(i-1) <= 0 or v(i)*v(i+1) <= 0. m1 = m-1 n = 4 do 20 i=2,m1 if(v(i).eq.0. .or. (v(i)*v(i-1).gt.0. .and. * v(i)*v(i+1).gt.0.)) go to 20 n = n+1 c test whether the required storage space exceeds the available one. if(n+4.gt.nest) go to 200 t(n) = x(i) 20 continue c find the position of the knots t(1),...t(4) and t(n-3),...t(n) which c are needed for the b-spline representation of s(x). do 30 i=1,4 t(i) = x(1) n = n+1 t(n) = x(m) 30 continue c test whether the minimum number of knots exceeds the maximum number. if(n.gt.nmax) go to 210 c main loop for the different sets of knots. c find corresponding values e(j) to the knots t(j+3),j=1,2,...n-6 c e(j) will take the value -1,1, or 0 according to the requirement c that s(x) must be locally convex or concave at t(j+3) or that the c sign of s''(x) is unrestricted at that point. 40 i= 1 xi = x(1) j = 4 tj = t(4) n6 = n-6 do 70 l=1,n6 50 if(xi.eq.tj) go to 60 i = i+1 xi = x(i) go to 50 60 e(l) = v(i) j = j+1 tj = t(j) 70 continue c we partition the working space nm = n+maxbin mb = maxbin+1 ia = 1 ib = ia+4*n ic = ib+nm*maxbin iz = ic+n izz = iz+n iu = izz+n iq = iu+maxbin ji = 1 ju = ji+maxtr jl = ju+maxtr jr = jl+maxtr jjb = jr+maxtr jib = jjb+mb c given the set of knots t(j),j=1,2,...n, find the least-squares cubic c spline which satisfies the imposed concavity/convexity constraints. call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia), * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji), * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier) c if sq <= s or in case of abnormal exit from fpcosp, control is c repassed to the driver program. if(sq.le.s .or. ier.gt.0) go to 300 c calculate for each knot interval t(l-1) <= xi <= t(l) the c sum((wi*(yi-s(xi)))**2). c find the interval t(k-1) <= x <= t(k) for which this sum is maximal c on the condition that this interval contains at least one interior c data point x(nr) and that s(x) is not given there by a straight line. 80 sqmax = 0. sql = 0. l = 5 nr = 0 i1 = 1 n4 = n-4 do 110 i=1,m term = (w(i)*(sx(i)-y(i)))**2 if(x(i).lt.t(l) .or. l.gt.n4) go to 100 term = term*half sql = sql+term if(i-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 90 if(sql.le.sqmax) go to 90 k = l sqmax = sql nr = i1+(i-i1)/2 90 l = l+1 i1 = i sql = 0. 100 sql = sql+term 110 continue if(m-i1.le.1 .or. (bind(l-4).and.bind(l-3))) go to 120 if(sql.le.sqmax) go to 120 k = l nr = i1+(m-i1)/2 c if no such interval is found, control is repassed to the driver c program (ier = -1). 120 if(nr.eq.0) go to 190 c if s(x) is given by the same straight line in two succeeding knot c intervals t(l-1) <= x <= t(l) and t(l) <= x <= t(l+1),delete t(l) n8 = n-8 l1 = 0 if(n8.le.0) go to 150 do 140 i=1,n8 if(.not. (bind(i).and.bind(i+1).and.bind(i+2))) go to 140 l = i+4-l1 if(k.gt.l) k = k-1 n = n-1 l1 = l1+1 do 130 j=l,n t(j) = t(j+1) 130 continue 140 continue c test whether we cannot further increase the number of knots. 150 if(n.eq.nmax) go to 180 if(n.eq.nest) go to 170 c locate an additional knot at the point x(nr). j = n do 160 i=k,n t(j+1) = t(j) j = j-1 160 continue t(k) = x(nr) n = n+1 c restart the computations with the new set of knots. go to 40 c error codes and messages. 170 ier = -3 go to 300 180 ier = -2 go to 300 190 ier = -1 go to 300 200 ier = 4 go to 300 210 ier = 5 300 return end spd-1.3.0/fitpack/fpcyt2.f0000644000175000017500000000140111633462461012223 00000000000000 subroutine fpcyt2(a,n,b,c,nn) c subroutine fpcyt2 solves a linear n x n system c a * c = b c where matrix a is a cyclic tridiagonal matrix, decomposed c using subroutine fpsyt1. c .. c ..scalar arguments.. integer n,nn c ..array arguments.. real a(nn,6),b(n),c(n) c ..local scalars.. real cc,sum integer i,j,j1,n1 c .. c(1) = b(1)*a(1,4) sum = c(1)*a(1,5) n1 = n-1 do 10 i=2,n1 c(i) = (b(i)-a(i,1)*c(i-1))*a(i,4) sum = sum+c(i)*a(i,5) 10 continue cc = (b(n)-sum)*a(n,4) c(n) = cc c(n1) = c(n1)-cc*a(n1,6) j = n1 do 20 i=3,n j1 = j-1 c(j1) = c(j1)-c(j)*a(j1,3)*a(j1,4)-cc*a(j1,6) j = j1 20 continue return end spd-1.3.0/fitpack/bispev.f0000644000175000017500000000762011633462460012314 00000000000000 subroutine bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk, * iwrk,kwrk,ier) c subroutine bispev evaluates on a grid (x(i),y(j)),i=1,...,mx; j=1,... c ,my a bivariate spline s(x,y) of degrees kx and ky, given in the c b-spline representation. c c calling sequence: c call bispev(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk,lwrk, c * iwrk,kwrk,ier) c c input parameters: c tx : real array, length nx, which contains the position of the c knots in the x-direction. c nx : integer, giving the total number of knots in the x-direction c ty : real array, length ny, which contains the position of the c knots in the y-direction. c ny : integer, giving the total number of knots in the y-direction c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the c b-spline coefficients. c kx,ky : integer values, giving the degrees of the spline. c x : real array of dimension (mx). c before entry x(i) must be set to the x co-ordinate of the c i-th grid point along the x-axis. c tx(kx+1)<=x(i-1)<=x(i)<=tx(nx-kx), i=2,...,mx. c mx : on entry mx must specify the number of grid points along c the x-axis. mx >=1. c y : real array of dimension (my). c before entry y(j) must be set to the y co-ordinate of the c j-th grid point along the y-axis. c ty(ky+1)<=y(j-1)<=y(j)<=ty(ny-ky), j=2,...,my. c my : on entry my must specify the number of grid points along c the y-axis. my >=1. c wrk : real array of dimension lwrk. used as workspace. c lwrk : integer, specifying the dimension of wrk. c lwrk >= mx*(kx+1)+my*(ky+1) c iwrk : integer array of dimension kwrk. used as workspace. c kwrk : integer, specifying the dimension of iwrk. kwrk >= mx+my. c c output parameters: c z : real array of dimension (mx*my). c on succesful exit z(my*(i-1)+j) contains the value of s(x,y) c at the point (x(i),y(j)),i=1,...,mx;j=1,...,my. c ier : integer error flag c ier=0 : normal return c ier=10: invalid input data (see restrictions) c c restrictions: c mx >=1, my >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my c tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx c ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my c c other subroutines required: c fpbisp,fpbspl c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer nx,ny,kx,ky,mx,my,lwrk,kwrk,ier c ..array arguments.. integer iwrk(kwrk) real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), * wrk(lwrk) c ..local scalars.. integer i,iw,lwest c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 lwest = (kx+1)*mx+(ky+1)*my If (lwrk .Lt. lwest) Then Write (*, '(''Error: lwrk too small'')') go to 100 End If If (kwrk .lt. (mx+my)) Then Write (*, '(''Error: kwrk too small'')') go to 100 End If If(mx-1) 100,30,10 10 do 20 i=2,mx if(x(i).lt.x(i-1)) go to 100 20 continue 30 if(my-1) 100,60,40 40 do 50 i=2,my if(y(i).lt.y(i-1)) go to 100 50 continue 60 ier = 0 iw = mx*(kx+1)+1 call fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wrk(1),wrk(iw), * iwrk(1),iwrk(mx+1)) 100 return end spd-1.3.0/fitpack/fptrnp.f0000644000175000017500000000561111633462461012334 00000000000000 subroutine fptrnp(m,mm,idim,n,nr,sp,p,b,z,a,q,right) c subroutine fptrnp reduces the (m+n-7) x (n-4) matrix a to upper c triangular form and applies the same givens transformations to c the (m) x (mm) x (idim) matrix z to obtain the (n-4) x (mm) x c (idim) matrix q c .. c ..scalar arguments.. real p integer m,mm,idim,n c ..array arguments.. real sp(m,4),b(n,5),z(m*mm*idim),a(n,5),q((n-4)*mm*idim), * right(mm*idim) integer nr(m) c ..local scalars.. real cos,pinv,piv,sin,one integer i,iband,irot,it,ii,i2,i3,j,jj,l,mid,nmd,m2,m3, * nrold,n4,number,n1 c ..local arrays.. real h(7) c ..subroutine references.. c fpgivs,fprota c .. one = 1 if(p.gt.0.) pinv = one/p n4 = n-4 mid = mm*idim m2 = m*mm m3 = n4*mm c reduce the matrix (a) to upper triangular form (r) using givens c rotations. apply the same transformations to the rows of matrix z c to obtain the mm x (n-4) matrix g. c store matrix (r) into (a) and g into q. c initialization. nmd = n4*mid do 50 i=1,nmd q(i) = 0. 50 continue do 100 i=1,n4 do 100 j=1,5 a(i,j) = 0. 100 continue nrold = 0 c iband denotes the bandwidth of the matrices (a) and (r). iband = 4 do 750 it=1,m number = nr(it) 150 if(nrold.eq.number) go to 300 if(p.le.0.) go to 700 iband = 5 c fetch a new row of matrix (b). n1 = nrold+1 do 200 j=1,5 h(j) = b(n1,j)*pinv 200 continue c find the appropriate column of q. do 250 j=1,mid right(j) = 0. 250 continue irot = nrold go to 450 c fetch a new row of matrix (sp). 300 h(iband) = 0. do 350 j=1,4 h(j) = sp(it,j) 350 continue c find the appropriate column of q. j = 0 do 400 ii=1,idim l = (ii-1)*m2+(it-1)*mm do 400 jj=1,mm j = j+1 l = l+1 right(j) = z(l) 400 continue irot = number c rotate the new row of matrix (a) into triangle. 450 do 600 i=1,iband irot = irot+1 piv = h(i) if(piv.eq.0.) go to 600 c calculate the parameters of the givens transformation. call fpgivs(piv,a(irot,1),cos,sin) c apply that transformation to the rows of matrix q. j = 0 do 500 ii=1,idim l = (ii-1)*m3+irot do 500 jj=1,mm j = j+1 call fprota(cos,sin,right(j),q(l)) l = l+n4 500 continue c apply that transformation to the columns of (a). if(i.eq.iband) go to 650 i2 = 1 i3 = i+1 do 550 j=i3,iband i2 = i2+1 call fprota(cos,sin,h(j),a(irot,i2)) 550 continue 600 continue 650 if(nrold.eq.number) go to 750 700 nrold = nrold+1 go to 150 750 continue return end spd-1.3.0/fitpack/concon.f0000644000175000017500000002665011633462460012307 00000000000000 subroutine concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq, * sx,bind,wrk,lwrk,iwrk,kwrk,ier) c given the set of data points (x(i),y(i)) and the set of positive c numbers w(i), i=1,2,...,m,subroutine concon determines a cubic spline c approximation s(x) which satisfies the following local convexity c constraints s''(x(i))*v(i) <= 0, i=1,2,...,m. c the number of knots n and the position t(j),j=1,2,...n is chosen c automatically by the routine in a way that c sq = sum((w(i)*(y(i)-s(x(i))))**2) be <= s. c the fit is given in the b-spline representation (b-spline coef- c ficients c(j),j=1,2,...n-4) and can be evaluated by means of c subroutine splev. c c calling sequence: c c call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq, c * sx,bind,wrk,lwrk,iwrk,kwrk,ier) c c parameters: c iopt: integer flag. c if iopt=0, the routine will start with the minimal number of c knots to guarantee that the convexity conditions will be c satisfied. if iopt=1, the routine will continue with the set c of knots found at the last call of the routine. c attention: a call with iopt=1 must always be immediately c preceded by another call with iopt=1 or iopt=0. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m > 3. unchanged on exit. c x : real array of dimension at least (m). before entry, x(i) c must be set to the i-th value of the independent variable x, c for i=1,2,...,m. these values must be supplied in strictly c ascending order. unchanged on exit. c y : real array of dimension at least (m). before entry, y(i) c must be set to the i-th value of the dependent variable y, c for i=1,2,...,m. unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) c must be set to the i-th value in the set of weights. the c w(i) must be strictly positive. unchanged on exit. c v : real array of dimension at least (m). before entry, v(i) c must be set to 1 if s(x) must be locally concave at x(i), c to (-1) if s(x) must be locally convex at x(i) and to 0 c if no convexity constraint is imposed at x(i). c s : real. on entry s must specify an over-estimate for the c the weighted sum of squared residuals sq of the requested c spline. s >=0. unchanged on exit. c nest : integer. on entry nest must contain an over-estimate of the c total number of knots of the spline returned, to indicate c the storage space available to the routine. nest >=8. c in most practical situation nest=m/2 will be sufficient. c always large enough is nest=m+4. unchanged on exit. c maxtr : integer. on entry maxtr must contain an over-estimate of the c total number of records in the used tree structure, to indic- c ate the storage space available to the routine. maxtr >=1 c in most practical situation maxtr=100 will be sufficient. c always large enough is c nest-5 nest-6 c maxtr = ( ) + ( ) with l the greatest c l l+1 c integer <= (nest-6)/2 . unchanged on exit. c maxbin: integer. on entry maxbin must contain an over-estimate of the c number of knots where s(x) will have a zero second derivative c maxbin >=1. in most practical situation maxbin = 10 will be c sufficient. always large enough is maxbin=nest-6. c unchanged on exit. c n : integer. c on exit with ier <=0, n will contain the total number of c knots of the spline approximation returned. if the comput- c ation mode iopt=1 is used this value of n should be left c unchanged between subsequent calls. c t : real array of dimension at least (nest). c on exit with ier<=0, this array will contain the knots of the c spline,i.e. the position of the interior knots t(5),t(6),..., c t(n-4) as well as the position of the additional knots c t(1)=t(2)=t(3)=t(4)=x(1) and t(n-3)=t(n-2)=t(n-1)=t(n)=x(m) c needed for the the b-spline representation. c if the computation mode iopt=1 is used, the values of t(1), c t(2),...,t(n) should be left unchanged between subsequent c calls. c c : real array of dimension at least (nest). c on succesful exit, this array will contain the coefficients c c(1),c(2),..,c(n-4) in the b-spline representation of s(x) c sq : real. unless ier>0 , sq contains the weighted sum of c squared residuals of the spline approximation returned. c sx : real array of dimension at least m. on exit with ier<=0 c this array will contain the spline values s(x(i)),i=1,...,m c if the computation mode iopt=1 is used, the values of sx(1), c sx(2),...,sx(m) should be left unchanged between subsequent c calls. c bind: logical array of dimension at least nest. on exit with ier<=0 c this array will indicate the knots where s''(x)=0, i.e. c s''(t(j+3)) .eq. 0 if bind(j) = .true. c s''(t(j+3)) .ne. 0 if bind(j) = .false., j=1,2,...,n-6 c if the computation mode iopt=1 is used, the values of bind(1) c ,...,bind(n-6) should be left unchanged between subsequent c calls. c wrk : real array of dimension at least (m*4+nest*8+maxbin*(maxbin+ c nest+1)). used as working space. c lwrk : integer. on entry,lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program.lwrk c must not be too small (see wrk). unchanged on exit. c iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1)) c used as working space. c kwrk : integer. on entry,kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. kwrk c must not be too small (see iwrk). unchanged on exit. c ier : integer. error flag c ier=0 : normal return, s(x) satisfies the concavity/convexity c constraints and sq <= s. c ier<0 : abnormal termination: s(x) satisfies the concavity/ c convexity constraints but sq > s. c ier=-3 : the requested storage space exceeds the available c storage space as specified by the parameter nest. c probably causes: nest too small. if nest is already c large (say nest > m/2), it may also indicate that s c is too small. c the approximation returned is the least-squares cubic c spline according to the knots t(1),...,t(n) (n=nest) c which satisfies the convexity constraints. c ier=-2 : the maximal number of knots n=m+4 has been reached. c probably causes: s too small. c ier=-1 : the number of knots n is less than the maximal number c m+4 but concon finds that adding one or more knots c will not further reduce the value of sq. c probably causes : s too small. c ier>0 : abnormal termination: no approximation is returned c ier=1 : the number of knots where s''(x)=0 exceeds maxbin. c probably causes : maxbin too small. c ier=2 : the number of records in the tree structure exceeds c maxtr. c probably causes : maxtr too small. c ier=3 : the algoritm finds no solution to the posed quadratic c programming problem. c probably causes : rounding errors. c ier=4 : the minimum number of knots (given by n) to guarantee c that the concavity/convexity conditions will be c satisfied is greater than nest. c probably causes: nest too small. c ier=5 : the minimum number of knots (given by n) to guarantee c that the concavity/convexity conditions will be c satisfied is greater than m+4. c probably causes: strongly alternating convexity and c concavity conditions. normally the situation can be c coped with by adding n-m-4 extra data points (found c by linear interpolation e.g.) with a small weight w(i) c and a v(i) number equal to zero. c ier=10 : on entry, the input data are controlled on validity. c the following restrictions must be satisfied c 0<=iopt<=1, m>3, nest>=8, s>=0, maxtr>=1, maxbin>=1, c kwrk>=maxtr*4+2*(maxbin+1), w(i)>0, x(i) < x(i+1), c lwrk>=m*4+nest*8+maxbin*(maxbin+nest+1) c if one of these restrictions is found to be violated c control is immediately repassed to the calling program c c further comments: c as an example of the use of the computation mode iopt=1, the c following program segment will cause concon to return control c each time a spline with a new set of knots has been computed. c ............. c iopt = 0 c s = 0.1e+60 (s very large) c do 10 i=1,m c call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx, c * bind,wrk,lwrk,iwrk,kwrk,ier) c ...... c s = sq c iopt=1 c 10 continue c ............. c c other subroutines required: c fpcoco,fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno c c references: c dierckx p. : an algorithm for cubic spline fitting with convexity c constraints, computing 24 (1980) 349-371. c dierckx p. : an algorithm for least-squares cubic spline fitting c with convexity and concavity constraints, report tw39, c dept. computer science, k.u.leuven, 1978. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p. dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : march 1978 c latest update : march 1987. c c .. c ..scalar arguments.. real s,sq integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier c ..array arguments.. real x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),wrk(lwrk) integer iwrk(kwrk) logical bind(nest) c ..local scalars.. integer i,lwest,kwest,ie,iw,lww real one c .. c set constant one = 0.1e+01 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(iopt.lt.0 .or. iopt.gt.1) go to 30 if(m.lt.4 .or. nest.lt.8) go to 30 if(s.lt.0.) go to 30 if(maxtr.lt.1 .or. maxbin.lt.1) go to 30 lwest = 8*nest+m*4+maxbin*(1+nest+maxbin) kwest = 4*maxtr+2*(maxbin+1) if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 30 if(iopt.gt.0) go to 20 if(w(1).le.0.) go to 30 if(v(1).gt.0.) v(1) = one if(v(1).lt.0.) v(1) = -one do 10 i=2,m if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 30 if(v(i).gt.0.) v(i) = one if(v(i).lt.0.) v(i) = -one 10 continue 20 ier = 0 c we partition the working space and determine the spline approximation ie = 1 iw = ie+nest lww = lwrk-nest call fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx, * bind,wrk(ie),wrk(iw),lww,iwrk,kwrk,ier) 30 return end spd-1.3.0/fitpack/fprpsp.f0000644000175000017500000000236511633462460012337 00000000000000 subroutine fprpsp(nt,np,co,si,c,f,ncoff) c given the coefficients of a spherical spline function, subroutine c fprpsp calculates the coefficients in the standard b-spline re- c presentation of this bicubic spline. c .. c ..scalar arguments integer nt,np,ncoff c ..array arguments real co(np),si(np),c(ncoff),f(ncoff) c ..local scalars real cn,c1,c2,c3 integer i,ii,j,k,l,ncof,npp,np4,nt4 c .. nt4 = nt-4 np4 = np-4 npp = np4-3 ncof = 6+npp*(nt4-4) c1 = c(1) cn = c(ncof) j = ncoff do 10 i=1,np4 f(i) = c1 f(j) = cn j = j-1 10 continue i = np4 j=1 do 70 l=3,nt4 ii = i if(l.eq.3 .or. l.eq.nt4) go to 30 do 20 k=1,npp i = i+1 j = j+1 f(i) = c(j) 20 continue go to 50 30 if(l.eq.nt4) c1 = cn c2 = c(j+1) c3 = c(j+2) j = j+2 do 40 k=1,npp i = i+1 f(i) = c1+c2*co(k)+c3*si(k) 40 continue 50 do 60 k=1,3 ii = ii+1 i = i+1 f(i) = f(ii) 60 continue 70 continue do 80 i=1,ncoff c(i) = f(i) 80 continue return end spd-1.3.0/fitpack/surev.f0000644000175000017500000000760511633462461012174 00000000000000 subroutine surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,mf,wrk,lwrk, * iwrk,kwrk,ier) c subroutine surev evaluates on a grid (u(i),v(j)),i=1,...,mu; j=1,... c ,mv a bicubic spline surface of dimension idim, given in the c b-spline representation. c c calling sequence: c call surev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,mf,wrk,lwrk, c * iwrk,kwrk,ier) c c input parameters: c idim : integer, specifying the dimension of the spline surface. c tu : real array, length nu, which contains the position of the c knots in the u-direction. c nu : integer, giving the total number of knots in the u-direction c tv : real array, length nv, which contains the position of the c knots in the v-direction. c nv : integer, giving the total number of knots in the v-direction c c : real array, length (nu-4)*(nv-4)*idim, which contains the c b-spline coefficients. c u : real array of dimension (mu). c before entry u(i) must be set to the u co-ordinate of the c i-th grid point along the u-axis. c tu(4)<=u(i-1)<=u(i)<=tu(nu-3), i=2,...,mu. c mu : on entry mu must specify the number of grid points along c the u-axis. mu >=1. c v : real array of dimension (mv). c before entry v(j) must be set to the v co-ordinate of the c j-th grid point along the v-axis. c tv(4)<=v(j-1)<=v(j)<=tv(nv-3), j=2,...,mv. c mv : on entry mv must specify the number of grid points along c the v-axis. mv >=1. c mf : on entry, mf must specify the dimension of the array f. c mf >= mu*mv*idim c wrk : real array of dimension lwrk. used as workspace. c lwrk : integer, specifying the dimension of wrk. c lwrk >= 4*(mu+mv) c iwrk : integer array of dimension kwrk. used as workspace. c kwrk : integer, specifying the dimension of iwrk. kwrk >= mu+mv. c c output parameters: c f : real array of dimension (mf). c on succesful exit f(mu*mv*(l-1)+mv*(i-1)+j) contains the c l-th co-ordinate of the bicubic spline surface at the c point (u(i),v(j)),l=1,...,idim,i=1,...,mu;j=1,...,mv. c ier : integer error flag c ier=0 : normal return c ier=10: invalid input data (see restrictions) c c restrictions: c mu >=1, mv >=1, lwrk>=4*(mu+mv), kwrk>=mu+mv , mf>=mu*mv*idim c tu(4) <= u(i-1) <= u(i) <= tu(nu-3), i=2,...,mu c tv(4) <= v(j-1) <= v(j) <= tv(nv-3), j=2,...,mv c c other subroutines required: c fpsuev,fpbspl c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer idim,nu,nv,mu,mv,mf,lwrk,kwrk,ier c ..array arguments.. integer iwrk(kwrk) real tu(nu),tv(nv),c((nu-4)*(nv-4)*idim),u(mu),v(mv),f(mf), * wrk(lwrk) c ..local scalars.. integer i,muv c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 if(mf.lt.mu*mv*idim) go to 100 muv = mu+mv if(lwrk.lt.4*muv) go to 100 if(kwrk.lt.muv) go to 100 if(mu-1) 100,30,10 10 do 20 i=2,mu if(u(i).lt.u(i-1)) go to 100 20 continue 30 if(mv-1) 100,60,40 40 do 50 i=2,mv if(v(i).lt.v(i-1)) go to 100 50 continue 60 ier = 0 call fpsuev(idim,tu,nu,tv,nv,c,u,mu,v,mv,f,wrk(1),wrk(4*mu+1), * iwrk(1),iwrk(mu+1)) 100 return end spd-1.3.0/fitpack/fpched.f0000644000175000017500000000417211633462460012254 00000000000000 subroutine fpched(x,m,t,n,k,ib,ie,ier) c subroutine fpched verifies the number and the position of the knots c t(j),j=1,2,...,n of a spline of degree k,with ib derative constraints c at x(1) and ie constraints at x(m), in relation to the number and c the position of the data points x(i),i=1,2,...,m. if all of the c following conditions are fulfilled, the error parameter ier is set c to zero. if one of the conditions is violated ier is set to ten. c 1) k+1 <= n-k-1 <= m + max(0,ib-1) + max(0,ie-1) c 2) t(1) <= t(2) <= ... <= t(k+1) c t(n-k) <= t(n-k+1) <= ... <= t(n) c 3) t(k+1) < t(k+2) < ... < t(n-k) c 4) t(k+1) <= x(i) <= t(n-k) c 5) the conditions specified by schoenberg and whitney must hold c for at least one subset of data points, i.e. there must be a c subset of data points y(j) such that c t(j) < y(j) < t(j+k+1), j=1+ib1,2+ib1,...,n-k-1-ie1 c with ib1 = max(0,ib-1), ie1 = max(0,ie-1) c .. c ..scalar arguments.. integer m,n,k,ib,ie,ier c ..array arguments.. real x(m),t(n) c ..local scalars.. integer i,ib1,ie1,j,jj,k1,k2,l,nk1,nk2,nk3 real tj,tl c .. k1 = k+1 k2 = k1+1 nk1 = n-k1 nk2 = nk1+1 ib1 = ib-1 if(ib1.lt.0) ib1 = 0 ie1 = ie-1 if(ie1.lt.0) ie1 = 0 ier = 10 c check condition no 1 if(nk1.lt.k1 .or. nk1.gt.(m+ib1+ie1)) go to 80 c check condition no 2 j = n do 20 i=1,k if(t(i).gt.t(i+1)) go to 80 if(t(j).lt.t(j-1)) go to 80 j = j-1 20 continue c check condition no 3 do 30 i=k2,nk2 if(t(i).le.t(i-1)) go to 80 30 continue c check condition no 4 if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 80 c check condition no 5 if(x(1).ge.t(k2) .or. x(m).le.t(nk1)) go to 80 i = 1 jj = 2+ib1 l = jj+k nk3 = nk1-1-ie1 if(nk3.lt.jj) go to 70 do 60 j=jj,nk3 tj = t(j) l = l+1 tl = t(l) 40 i = i+1 if(i.ge.m) go to 80 if(x(i).le.tj) go to 40 if(x(i).ge.tl) go to 80 60 continue 70 ier = 0 80 return end spd-1.3.0/fitpack/clocur.f0000644000175000017500000004160311633462460012312 00000000000000 subroutine clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,c,fp, * wrk,lwrk,iwrk,ier) c given the ordered set of m points x(i) in the idim-dimensional space c with x(1)=x(m), and given also a corresponding set of strictly in- c creasing values u(i) and the set of positive numbers w(i),i=1,2,...,m c subroutine clocur determines a smooth approximating closed spline c curve s(u), i.e. c x1 = s1(u) c x2 = s2(u) u(1) <= u <= u(m) c ......... c xidim = sidim(u) c with sj(u),j=1,2,...,idim periodic spline functions of degree k with c common knots t(j),j=1,2,...,n. c if ipar=1 the values u(i),i=1,2,...,m must be supplied by the user. c if ipar=0 these values are chosen automatically by clocur as c v(1) = 0 c v(i) = v(i-1) + dist(x(i),x(i-1)) ,i=2,3,...,m c u(i) = v(i)/v(m) ,i=1,2,...,m c if iopt=-1 clocur calculates the weighted least-squares closed spline c curve according to a given set of knots. c if iopt>=0 the number of knots of the splines sj(u) and the position c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- c ness of s(u) is then achieved by minimalizing the discontinuity c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,..., c n-k-1. the amount of smoothness is determined by the condition that c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non- c negative constant, called the smoothing factor. c the fit s(u) is given in the b-spline representation and can be c evaluated by means of subroutine curev. c c calling sequence: c call clocur(iopt,ipar,idim,m,u,mx,x,w,k,s,nest,n,t,nc,c, c * fp,wrk,lwrk,iwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a weighted c least-squares closed spline curve (iopt=-1) or a smoothing c closed spline curve (iopt=0 or 1) must be determined. if c iopt=0 the routine will start with an initial set of knots c t(i)=u(1)+(u(m)-u(1))*(i-k-1),i=1,2,...,2*k+2. if iopt=1 the c routine will continue with the knots found at the last call. c attention: a call with iopt=1 must always be immediately c preceded by another call with iopt=1 or iopt=0. c unchanged on exit. c ipar : integer flag. on entry ipar must specify whether (ipar=1) c the user will supply the parameter values u(i),or whether c (ipar=0) these values are to be calculated by clocur. c unchanged on exit. c idim : integer. on entry idim must specify the dimension of the c curve. 0 < idim < 11. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m > 1. unchanged on exit. c u : real array of dimension at least (m). in case ipar=1,before c entry, u(i) must be set to the i-th value of the parameter c variable u for i=1,2,...,m. these values must then be c supplied in strictly ascending order and will be unchanged c on exit. in case ipar=0, on exit,the array will contain the c values u(i) as determined by clocur. c mx : integer. on entry mx must specify the actual dimension of c the array x as declared in the calling (sub)program. mx must c not be too small (see x). unchanged on exit. c x : real array of dimension at least idim*m. c before entry, x(idim*(i-1)+j) must contain the j-th coord- c inate of the i-th data point for i=1,2,...,m and j=1,2,..., c idim. since first and last data point must coincide it c means that x(j)=x(idim*(m-1)+j),j=1,2,...,idim. c unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) c must be set to the i-th value in the set of weights. the c w(i) must be strictly positive. w(m) is not used. c unchanged on exit. see also further comments. c k : integer. on entry k must specify the degree of the splines. c 1<=k<=5. it is recommended to use cubic splines (k=3). c the user is strongly dissuaded from choosing k even,together c with a small s-value. unchanged on exit. c s : real.on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments. c nest : integer. on entry nest must contain an over-estimate of the c total number of knots of the splines returned, to indicate c the storage space available to the routine. nest >=2*k+2. c in most practical situation nest=m/2 will be sufficient. c always large enough is nest=m+2*k, the number of knots c needed for interpolation (s=0). unchanged on exit. c n : integer. c unless ier = 10 (in case iopt >=0), n will contain the c total number of knots of the smoothing spline curve returned c if the computation mode iopt=1 is used this value of n c should be left unchanged between subsequent calls. c in case iopt=-1, the value of n must be specified on entry. c t : real array of dimension at least (nest). c on succesful exit, this array will contain the knots of the c spline curve,i.e. the position of the interior knots t(k+2), c t(k+3),..,t(n-k-1) as well as the position of the additional c t(1),t(2),..,t(k+1)=u(1) and u(m)=t(n-k),...,t(n) needed for c the b-spline representation. c if the computation mode iopt=1 is used, the values of t(1), c t(2),...,t(n) should be left unchanged between subsequent c calls. if the computation mode iopt=-1 is used, the values c t(k+2),...,t(n-k-1) must be supplied by the user, before c entry. see also the restrictions (ier=10). c nc : integer. on entry nc must specify the actual dimension of c the array c as declared in the calling (sub)program. nc c must not be too small (see c). unchanged on exit. c c : real array of dimension at least (nest*idim). c on succesful exit, this array will contain the coefficients c in the b-spline representation of the spline curve s(u),i.e. c the b-spline coefficients of the spline sj(u) will be given c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim. c fp : real. unless ier = 10, fp contains the weighted sum of c squared residuals of the spline curve returned. c wrk : real array of dimension at least m*(k+1)+nest*(7+idim+5*k). c used as working space. if the computation mode iopt=1 is c used, the values wrk(1),...,wrk(n) should be left unchanged c between subsequent calls. c lwrk : integer. on entry,lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. lwrk c must not be too small (see wrk). unchanged on exit. c iwrk : integer array of dimension at least (nest). c used as working space. if the computation mode iopt=1 is c used,the values iwrk(1),...,iwrk(n) should be left unchanged c between subsequent calls. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the close curve returned has a residual c sum of squares fp such that abs(fp-s)/s <= tol with tol a c relative tolerance set to 0.001 by the program. c ier=-1 : normal return. the curve returned is an interpolating c spline curve (fp=0). c ier=-2 : normal return. the curve returned is the weighted least- c squares point,i.e. each spline sj(u) is a constant. in c this extreme case fp gives the upper bound fp0 for the c smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameter nest. c probably causes : nest too small. if nest is already c large (say nest > m/2), it may also indicate that s is c too small c the approximation returned is the least-squares closed c curve according to the knots t(1),t(2),...,t(n). (n=nest) c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing curve with c fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing curve c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, 1<=k<=5, m>1, nest>2*k+2, w(i)>0,i=1,2,...,m c 0<=ipar<=1, 0=(k+1)*m+nest*(7+idim+5*k), c nc>=nest*idim, x(j)=x(idim*(m-1)+j), j=1,2,...,idim c if ipar=0: sum j=1,idim (x(i*idim+j)-x((i-1)*idim+j))**2>0 c i=1,2,...,m-1. c if ipar=1: u(1)=0: s>=0 c if s=0 : nest >= m+2*k c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the curve will be too smooth and signal will be c lost ; if s is too small the curve will pick up too much noise. in c the extreme cases the program will return an interpolating curve if c s=0 and the weighted least-squares point if s is very large. c between these extremes, a properly chosen s will result in a good c compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in x(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the weighted c least-squares point and the upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximating curve shows more detail) to obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if clocur is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c curve underlying the data. but, if the computation mode iopt=1 is c used, the knots returned may also depend on the s-values at previous c calls (if these were smaller). therefore, if after a number of c trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c clocur once more with the selected value for s but now with iopt=0. c indeed, clocur may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c c the form of the approximating curve can strongly be affected by c the choice of the parameter values u(i). if there is no physical c reason for choosing a particular parameter u, often good results c will be obtained with the choice of clocur(in case ipar=0), i.e. c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m c where c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 ) c other possibilities for q(i) are c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2 c q(i)= sum j=1,idim abs(xj(i)-xj(i-1)) c q(i)= max j=1,idim abs(xj(i)-xj(i-1)) c q(i)= 1 c c c other subroutines required: c fpbacp,fpbspl,fpchep,fpclos,fpdisc,fpgivs,fpknot,fprati,fprota c c references: c dierckx p. : algorithms for smoothing data with periodic and c parametric splines, computer graphics and image c processing 20 (1982) 171-184. c dierckx p. : algorithms for smoothing data with periodic and param- c etric splines, report tw55, dept. computer science, c k.u.leuven, 1981. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : may 1979 c latest update : march 1987 c c .. c ..scalar arguments.. real s,fp integer iopt,ipar,idim,m,mx,k,nest,n,nc,lwrk,ier c ..array arguments.. real u(m),x(mx),w(m),t(nest),c(nc),wrk(lwrk) integer iwrk(nest) c ..local scalars.. real per,tol,dist integer i,ia1,ia2,ib,ifp,ig1,ig2,iq,iz,i1,i2,j1,j2,k1,k2,lwest, * maxit,m1,nmin,ncc,j c ..function references.. real sqrt c we set up the parameters tol and maxit maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(iopt.lt.(-1) .or. iopt.gt.1) go to 90 if(ipar.lt.0 .or. ipar.gt.1) go to 90 if(idim.le.0 .or. idim.gt.10) go to 90 if(k.le.0 .or. k.gt.5) go to 90 k1 = k+1 k2 = k1+1 nmin = 2*k1 if(m.lt.2 .or. nest.lt.nmin) go to 90 ncc = nest*idim if(mx.lt.m*idim .or. nc.lt.ncc) go to 90 lwest = m*k1+nest*(7+idim+5*k) if(lwrk.lt.lwest) go to 90 i1 = idim i2 = m*idim do 5 j=1,idim if(x(i1).ne.x(i2)) go to 90 i1 = i1-1 i2 = i2-1 5 continue if(ipar.ne.0 .or. iopt.gt.0) go to 40 i1 = 0 i2 = idim u(1) = 0. do 20 i=2,m dist = 0. do 10 j1=1,idim i1 = i1+1 i2 = i2+1 dist = dist+(x(i2)-x(i1))**2 10 continue u(i) = u(i-1)+sqrt(dist) 20 continue if(u(m).le.0.) go to 90 do 30 i=2,m u(i) = u(i)/u(m) 30 continue u(m) = 0.1e+01 40 if(w(1).le.0.) go to 90 m1 = m-1 do 50 i=1,m1 if(u(i).ge.u(i+1) .or. w(i).le.0.) go to 90 50 continue if(iopt.ge.0) go to 70 if(n.le.nmin .or. n.gt.nest) go to 90 per = u(m)-u(1) j1 = k1 t(j1) = u(1) i1 = n-k t(i1) = u(m) j2 = j1 i2 = i1 do 60 i=1,k i1 = i1+1 i2 = i2-1 j1 = j1+1 j2 = j2-1 t(j2) = t(i2)-per t(i1) = t(j1)+per 60 continue call fpchep(u,m,t,n,k,ier) if(ier) 90,80,90 70 if(s.lt.0.) go to 90 if(s.eq.0. .and. nest.lt.(m+2*k)) go to 90 ier = 0 c we partition the working space and determine the spline approximation. 80 ifp = 1 iz = ifp+nest ia1 = iz+ncc ia2 = ia1+nest*k1 ib = ia2+nest*k ig1 = ib+nest*k2 ig2 = ig1+nest*k2 iq = ig2+nest*k1 call fpclos(iopt,idim,m,u,mx,x,w,k,s,nest,tol,maxit,k1,k2,n,t, * ncc,c,fp,wrk(ifp),wrk(iz),wrk(ia1),wrk(ia2),wrk(ib),wrk(ig1), * wrk(ig2),wrk(iq),iwrk,ier) 90 return end spd-1.3.0/fitpack/concur.f0000644000175000017500000004466711633462461012332 00000000000000 subroutine concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s, * nest,n,t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier) c given the ordered set of m points x(i) in the idim-dimensional space c and given also a corresponding set of strictly increasing values u(i) c and the set of positive numbers w(i),i=1,2,...,m, subroutine concur c determines a smooth approximating spline curve s(u), i.e. c x1 = s1(u) c x2 = s2(u) ub = u(1) <= u <= u(m) = ue c ......... c xidim = sidim(u) c with sj(u),j=1,2,...,idim spline functions of odd degree k with c common knots t(j),j=1,2,...,n. c in addition these splines will satisfy the following boundary c constraints (l) c if ib > 0 : sj (u(1)) = db(idim*l+j) ,l=0,1,...,ib-1 c and (l) c if ie > 0 : sj (u(m)) = de(idim*l+j) ,l=0,1,...,ie-1. c if iopt=-1 concur calculates the weighted least-squares spline curve c according to a given set of knots. c if iopt>=0 the number of knots of the splines sj(u) and the position c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- c ness of s(u) is then achieved by minimalizing the discontinuity c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,..., c n-k-1. the amount of smoothness is determined by the condition that c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non- c negative constant, called the smoothing factor. c the fit s(u) is given in the b-spline representation and can be c evaluated by means of subroutine curev. c c calling sequence: c call concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s,nest,n, c * t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a weighted c least-squares spline curve (iopt=-1) or a smoothing spline c curve (iopt=0 or 1) must be determined.if iopt=0 the routine c will start with an initial set of knots t(i)=ub,t(i+k+1)=ue, c i=1,2,...,k+1. if iopt=1 the routine will continue with the c knots found at the last call of the routine. c attention: a call with iopt=1 must always be immediately c preceded by another call with iopt=1 or iopt=0. c unchanged on exit. c idim : integer. on entry idim must specify the dimension of the c curve. 0 < idim < 11. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m > k-max(ib-1,0)-max(ie-1,0). unchanged on exit. c u : real array of dimension at least (m). before entry, c u(i) must be set to the i-th value of the parameter variable c u for i=1,2,...,m. these values must be supplied in c strictly ascending order and will be unchanged on exit. c mx : integer. on entry mx must specify the actual dimension of c the arrays x and xx as declared in the calling (sub)program c mx must not be too small (see x). unchanged on exit. c x : real array of dimension at least idim*m. c before entry, x(idim*(i-1)+j) must contain the j-th coord- c inate of the i-th data point for i=1,2,...,m and j=1,2,..., c idim. unchanged on exit. c xx : real array of dimension at least idim*m. c used as working space. on exit xx contains the coordinates c of the data points to which a spline curve with zero deriv- c ative constraints has been determined. c if the computation mode iopt =1 is used xx should be left c unchanged between calls. c w : real array of dimension at least (m). before entry, w(i) c must be set to the i-th value in the set of weights. the c w(i) must be strictly positive. unchanged on exit. c see also further comments. c ib : integer. on entry ib must specify the number of derivative c constraints for the curve at the begin point. 0<=ib<=(k+1)/2 c unchanged on exit. c db : real array of dimension nb. before entry db(idim*l+j) must c contain the l-th order derivative of sj(u) at u=u(1) for c j=1,2,...,idim and l=0,1,...,ib-1 (if ib>0). c unchanged on exit. c nb : integer, specifying the dimension of db. nb>=max(1,idim*ib) c unchanged on exit. c ie : integer. on entry ie must specify the number of derivative c constraints for the curve at the end point. 0<=ie<=(k+1)/2 c unchanged on exit. c de : real array of dimension ne. before entry de(idim*l+j) must c contain the l-th order derivative of sj(u) at u=u(m) for c j=1,2,...,idim and l=0,1,...,ie-1 (if ie>0). c unchanged on exit. c ne : integer, specifying the dimension of de. ne>=max(1,idim*ie) c unchanged on exit. c k : integer. on entry k must specify the degree of the splines. c k=1,3 or 5. c unchanged on exit. c s : real.on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments. c nest : integer. on entry nest must contain an over-estimate of the c total number of knots of the splines returned, to indicate c the storage space available to the routine. nest >=2*k+2. c in most practical situation nest=m/2 will be sufficient. c always large enough is nest=m+k+1+max(0,ib-1)+max(0,ie-1), c the number of knots needed for interpolation (s=0). c unchanged on exit. c n : integer. c unless ier = 10 (in case iopt >=0), n will contain the c total number of knots of the smoothing spline curve returned c if the computation mode iopt=1 is used this value of n c should be left unchanged between subsequent calls. c in case iopt=-1, the value of n must be specified on entry. c t : real array of dimension at least (nest). c on succesful exit, this array will contain the knots of the c spline curve,i.e. the position of the interior knots t(k+2), c t(k+3),..,t(n-k-1) as well as the position of the additional c t(1)=t(2)=...=t(k+1)=ub and t(n-k)=...=t(n)=ue needed for c the b-spline representation. c if the computation mode iopt=1 is used, the values of t(1), c t(2),...,t(n) should be left unchanged between subsequent c calls. if the computation mode iopt=-1 is used, the values c t(k+2),...,t(n-k-1) must be supplied by the user, before c entry. see also the restrictions (ier=10). c nc : integer. on entry nc must specify the actual dimension of c the array c as declared in the calling (sub)program. nc c must not be too small (see c). unchanged on exit. c c : real array of dimension at least (nest*idim). c on succesful exit, this array will contain the coefficients c in the b-spline representation of the spline curve s(u),i.e. c the b-spline coefficients of the spline sj(u) will be given c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim. c cp : real array of dimension at least 2*(k+1)*idim. c on exit cp will contain the b-spline coefficients of a c polynomial curve which satisfies the boundary constraints. c if the computation mode iopt =1 is used cp should be left c unchanged between calls. c np : integer. on entry np must specify the actual dimension of c the array cp as declared in the calling (sub)program. np c must not be too small (see cp). unchanged on exit. c fp : real. unless ier = 10, fp contains the weighted sum of c squared residuals of the spline curve returned. c wrk : real array of dimension at least m*(k+1)+nest*(6+idim+3*k). c used as working space. if the computation mode iopt=1 is c used, the values wrk(1),...,wrk(n) should be left unchanged c between subsequent calls. c lwrk : integer. on entry,lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. lwrk c must not be too small (see wrk). unchanged on exit. c iwrk : integer array of dimension at least (nest). c used as working space. if the computation mode iopt=1 is c used,the values iwrk(1),...,iwrk(n) should be left unchanged c between subsequent calls. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the curve returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the curve returned is an interpolating c spline curve, satisfying the constraints (fp=0). c ier=-2 : normal return. the curve returned is the weighted least- c squares polynomial curve of degree k, satisfying the c constraints. in this extreme case fp gives the upper c bound fp0 for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameter nest. c probably causes : nest too small. if nest is already c large (say nest > m/2), it may also indicate that s is c too small c the approximation returned is the least-squares spline c curve according to the knots t(1),t(2),...,t(n). (n=nest) c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline curve c with fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing curve c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, k = 1,3 or 5, m>k-max(0,ib-1)-max(0,ie-1), c nest>=2k+2, 0=(k+1)*m+nest*(6+idim+3*k), c nc >=nest*idim ,u(1)0 i=1,2,...,m, c mx>=idim*m,0<=ib<=(k+1)/2,0<=ie<=(k+1)/2,nb>=1,ne>=1, c nb>=ib*idim,ne>=ib*idim,np>=2*(k+1)*idim, c if iopt=-1:2*k+2<=n<=min(nest,mmax) with mmax = m+k+1+ c max(0,ib-1)+max(0,ie-1) c u(1)=0: s>=0 c if s=0 : nest >=mmax (see above) c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the curve will be too smooth and signal will be c lost ; if s is too small the curve will pick up too much noise. in c the extreme cases the program will return an interpolating curve if c s=0 and the least-squares polynomial curve of degree k if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in x(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the least-squares c polynomial curve and the upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximating curve shows more detail) to obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if concur is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c curve underlying the data. but, if the computation mode iopt=1 is c used, the knots returned may also depend on the s-values at previous c calls (if these were smaller). therefore, if after a number of c trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c concur once more with the selected value for s but now with iopt=0. c indeed, concur may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c c the form of the approximating curve can strongly be affected by c the choice of the parameter values u(i). if there is no physical c reason for choosing a particular parameter u, often good results c will be obtained with the choice c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m c where c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 ) c other possibilities for q(i) are c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2 c q(i)= sum j=1,idim abs(xj(i)-xj(i-1)) c q(i)= max j=1,idim abs(xj(i)-xj(i-1)) c q(i)= 1 c c other subroutines required: c fpback,fpbspl,fpched,fpcons,fpdisc,fpgivs,fpknot,fprati,fprota c curev,fppocu,fpadpo,fpinst c c references: c dierckx p. : algorithms for smoothing data with periodic and c parametric splines, computer graphics and image c processing 20 (1982) 171-184. c dierckx p. : algorithms for smoothing data with periodic and param- c etric splines, report tw55, dept. computer science, c k.u.leuven, 1981. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : may 1979 c latest update : march 1987 c c .. c ..scalar arguments.. real s,fp integer iopt,idim,m,mx,ib,nb,ie,ne,k,nest,n,nc,np,lwrk,ier c ..array arguments.. real u(m),x(mx),xx(mx),db(nb),de(ne),w(m),t(nest),c(nc),wrk(lwrk) real cp(np) integer iwrk(nest) c ..local scalars.. real tol,dist integer i,ib1,ie1,ja,jb,jfp,jg,jq,jz,j,k1,k2,lwest,maxit,nmin, * ncc,kk,mmin,nmax,mxx c ..function references integer max0 c .. c we set up the parameters tol and maxit maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(iopt.lt.(-1) .or. iopt.gt.1) go to 90 if(idim.le.0 .or. idim.gt.10) go to 90 if(k.le.0 .or. k.gt.5) go to 90 k1 = k+1 kk = k1/2 if(kk*2.ne.k1) go to 90 k2 = k1+1 if(ib.lt.0 .or. ib.gt.kk) go to 90 if(ie.lt.0 .or. ie.gt.kk) go to 90 nmin = 2*k1 ib1 = max0(0,ib-1) ie1 = max0(0,ie-1) mmin = k1-ib1-ie1 if(m.lt.mmin .or. nest.lt.nmin) go to 90 if(nb.lt.(idim*ib) .or. ne.lt.(idim*ie)) go to 90 if(np.lt.(2*k1*idim)) go to 90 mxx = m*idim ncc = nest*idim if(mx.lt.mxx .or. nc.lt.ncc) go to 90 lwest = m*k1+nest*(6+idim+3*k) if(lwrk.lt.lwest) go to 90 if(w(1).le.0.) go to 90 do 10 i=2,m if(u(i-1).ge.u(i) .or. w(i).le.0.) go to 90 10 continue if(iopt.ge.0) go to 30 if(n.lt.nmin .or. n.gt.nest) go to 90 j = n do 20 i=1,k1 t(i) = u(1) t(j) = u(m) j = j-1 20 continue call fpched(u,m,t,n,k,ib,ie,ier) if(ier) 90,40,90 30 if(s.lt.0.) go to 90 nmax = m+k1+ib1+ie1 if(s.eq.0. .and. nest.lt.nmax) go to 90 ier = 0 if(iopt.gt.0) go to 70 c we determine a polynomial curve satisfying the boundary constraints. 40 call fppocu(idim,k,u(1),u(m),ib,db,nb,ie,de,ne,cp,np) c we generate new data points which will be approximated by a spline c with zero derivative constraints. j = nmin do 50 i=1,k1 wrk(i) = u(1) wrk(j) = u(m) j = j-1 50 continue c evaluate the polynomial curve call curev(idim,wrk,nmin,cp,np,k,u,m,xx,mxx,ier) c substract from the old data, the values of the polynomial curve do 60 i=1,mxx xx(i) = x(i)-xx(i) 60 continue c we partition the working space and determine the spline curve. 70 jfp = 1 jz = jfp+nest ja = jz+ncc jb = ja+nest*k1 jg = jb+nest*k2 jq = jg+nest*k2 call fpcons(iopt,idim,m,u,mxx,xx,w,ib,ie,k,s,nest,tol,maxit,k1, * k2,n,t,ncc,c,fp,wrk(jfp),wrk(jz),wrk(ja),wrk(jb),wrk(jg),wrk(jq), * iwrk,ier) c add the polynomial curve to the calculated spline. call fpadpo(idim,t,n,c,ncc,k,cp,np,wrk(jz),wrk(ja),wrk(jb)) 90 return end spd-1.3.0/fitpack/fpsysy.f0000644000175000017500000000257711633462460012367 00000000000000 subroutine fpsysy(a,n,g) c subroutine fpsysy solves a linear n x n symmetric system c (a) * (b) = (g) c on input, vector g contains the right hand side ; on output it will c contain the solution (b). c .. c ..scalar arguments.. integer n c ..array arguments.. real a(6,6),g(6) c ..local scalars.. real fac integer i,i1,j,k c .. g(1) = g(1)/a(1,1) if(n.eq.1) return c decomposition of the symmetric matrix (a) = (l) * (d) *(l)' c with (l) a unit lower triangular matrix and (d) a diagonal c matrix do 10 k=2,n a(k,1) = a(k,1)/a(1,1) 10 continue do 40 i=2,n i1 = i-1 do 30 k=i,n fac = a(k,i) do 20 j=1,i1 fac = fac-a(j,j)*a(k,j)*a(i,j) 20 continue a(k,i) = fac if(k.gt.i) a(k,i) = fac/a(i,i) 30 continue 40 continue c solve the system (l)*(d)*(l)'*(b) = (g). c first step : solve (l)*(d)*(c) = (g). do 60 i=2,n i1 = i-1 fac = g(i) do 50 j=1,i1 fac = fac-g(j)*a(j,j)*a(i,j) 50 continue g(i) = fac/a(i,i) 60 continue c second step : solve (l)'*(b) = (c) i = n do 80 j=2,n i1 = i i = i-1 fac = g(i) do 70 k=i1,n fac = fac-g(k)*a(k,i) 70 continue g(i) = fac 80 continue return end spd-1.3.0/fitpack/cocosp.f0000644000175000017500000002013311633462460012304 00000000000000 subroutine cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,wrk, * lwrk,iwrk,kwrk,ier) c given the set of data points (x(i),y(i)) and the set of positive c numbers w(i),i=1,2,...,m, subroutine cocosp determines the weighted c least-squares cubic spline s(x) with given knots t(j),j=1,2,...,n c which satisfies the following concavity/convexity conditions c s''(t(j+3))*e(j) <= 0, j=1,2,...n-6 c the fit is given in the b-spline representation( b-spline coef- c ficients c(j),j=1,2,...n-4) and can be evaluated by means of c subroutine splev. c c calling sequence: c call cocosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,wrk, c * lwrk,iwrk,kwrk,ier) c c parameters: c m : integer. on entry m must specify the number of data points. c m > 3. unchanged on exit. c x : real array of dimension at least (m). before entry, x(i) c must be set to the i-th value of the independent variable x, c for i=1,2,...,m. these values must be supplied in strictly c ascending order. unchanged on exit. c y : real array of dimension at least (m). before entry, y(i) c must be set to the i-th value of the dependent variable y, c for i=1,2,...,m. unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) c must be set to the i-th value in the set of weights. the c w(i) must be strictly positive. unchanged on exit. c n : integer. on entry n must contain the total number of knots c of the cubic spline. m+4>=n>=8. unchanged on exit. c t : real array of dimension at least (n). before entry, this c array must contain the knots of the spline, i.e. the position c of the interior knots t(5),t(6),...,t(n-4) as well as the c position of the boundary knots t(1),t(2),t(3),t(4) and t(n-3) c t(n-2),t(n-1),t(n) needed for the b-spline representation. c unchanged on exit. see also the restrictions (ier=10). c e : real array of dimension at least (n). before entry, e(j) c must be set to 1 if s(x) must be locally concave at t(j+3), c to (-1) if s(x) must be locally convex at t(j+3) and to 0 c if no convexity constraint is imposed at t(j+3),j=1,2,..,n-6. c e(n-5),...,e(n) are not used. unchanged on exit. c maxtr : integer. on entry maxtr must contain an over-estimate of the c total number of records in the used tree structure, to indic- c ate the storage space available to the routine. maxtr >=1 c in most practical situation maxtr=100 will be sufficient. c always large enough is c n-5 n-6 c maxtr = ( ) + ( ) with l the greatest c l l+1 c integer <= (n-6)/2 . unchanged on exit. c maxbin: integer. on entry maxbin must contain an over-estimate of the c number of knots where s(x) will have a zero second derivative c maxbin >=1. in most practical situation maxbin = 10 will be c sufficient. always large enough is maxbin=n-6. c unchanged on exit. c c : real array of dimension at least (n). c on succesful exit, this array will contain the coefficients c c(1),c(2),..,c(n-4) in the b-spline representation of s(x) c sq : real. on succesful exit, sq contains the weighted sum of c squared residuals of the spline approximation returned. c sx : real array of dimension at least m. on succesful exit c this array will contain the spline values s(x(i)),i=1,...,m c bind : logical array of dimension at least (n). on succesful exit c this array will indicate the knots where s''(x)=0, i.e. c s''(t(j+3)) .eq. 0 if bind(j) = .true. c s''(t(j+3)) .ne. 0 if bind(j) = .false., j=1,2,...,n-6 c wrk : real array of dimension at least m*4+n*7+maxbin*(maxbin+n+1) c used as working space. c lwrk : integer. on entry,lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program.lwrk c must not be too small (see wrk). unchanged on exit. c iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1)) c used as working space. c kwrk : integer. on entry,kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. kwrk c must not be too small (see iwrk). unchanged on exit. c ier : integer. error flag c ier=0 : succesful exit. c ier>0 : abnormal termination: no approximation is returned c ier=1 : the number of knots where s''(x)=0 exceeds maxbin. c probably causes : maxbin too small. c ier=2 : the number of records in the tree structure exceeds c maxtr. c probably causes : maxtr too small. c ier=3 : the algoritm finds no solution to the posed quadratic c programming problem. c probably causes : rounding errors. c ier=10 : on entry, the input data are controlled on validity. c the following restrictions must be satisfied c m>3, maxtr>=1, maxbin>=1, 8<=n<=m+4,w(i) > 0, c x(1)=maxtr*4+2*(maxbin+1), c lwrk>=m*4+n*7+maxbin*(maxbin+n+1), c the schoenberg-whitney conditions, i.e. there must c be a subset of data points xx(j) such that c t(j) < xx(j) < t(j+4), j=1,2,...,n-4 c if one of these restrictions is found to be violated c control is immediately repassed to the calling program c c c other subroutines required: c fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno,fpchec c c references: c dierckx p. : an algorithm for cubic spline fitting with convexity c constraints, computing 24 (1980) 349-371. c dierckx p. : an algorithm for least-squares cubic spline fitting c with convexity and concavity constraints, report tw39, c dept. computer science, k.u.leuven, 1978. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p. dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : march 1978 c latest update : march 1987. c c .. c ..scalar arguments.. real sq integer m,n,maxtr,maxbin,lwrk,kwrk,ier c ..array arguments.. real x(m),y(m),w(m),t(n),e(n),c(n),sx(m),wrk(lwrk) integer iwrk(kwrk) logical bind(n) c ..local scalars.. integer i,ia,ib,ic,iq,iu,iz,izz,ji,jib,jjb,jl,jr,ju,kwest, * lwest,mb,nm,n6 real one c .. c set constant one = 0.1e+01 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(m.lt.4 .or. n.lt.8) go to 40 if(maxtr.lt.1 .or. maxbin.lt.1) go to 40 lwest = 7*n+m*4+maxbin*(1+n+maxbin) kwest = 4*maxtr+2*(maxbin+1) if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 40 if(w(1).le.0.) go to 40 do 10 i=2,m if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 40 10 continue call fpchec(x,m,t,n,3,ier) if(ier) 40,20,40 c set numbers e(i) 20 n6 = n-6 do 30 i=1,n6 if(e(i).gt.0.) e(i) = one if(e(i).lt.0.) e(i) = -one 30 continue c we partition the working space and determine the spline approximation nm = n+maxbin mb = maxbin+1 ia = 1 ib = ia+4*n ic = ib+nm*maxbin iz = ic+n izz = iz+n iu = izz+n iq = iu+maxbin ji = 1 ju = ji+maxtr jl = ju+maxtr jr = jl+maxtr jjb = jr+maxtr jib = jjb+mb call fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,wrk(ia), * wrk(ib),wrk(ic),wrk(iz),wrk(izz),wrk(iu),wrk(iq),iwrk(ji), * iwrk(ju),iwrk(jl),iwrk(jr),iwrk(jjb),iwrk(jib),ier) 40 return end spd-1.3.0/fitpack/Makefile.in0000644000175000017500000003315011650556154012722 00000000000000# Makefile.in generated by automake 1.11.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, # 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, # Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : subdir = fitpack DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = LIBRARIES = $(noinst_LIBRARIES) AR = ar ARFLAGS = cru libfitpack_a_AR = $(AR) $(ARFLAGS) libfitpack_a_LIBADD = am_libfitpack_a_OBJECTS = evapol.$(OBJEXT) fpclos.$(OBJEXT) \ fpgrdi.$(OBJEXT) fppocu.$(OBJEXT) fpsurf.$(OBJEXT) \ fourco.$(OBJEXT) fpcoco.$(OBJEXT) fpgrpa.$(OBJEXT) \ fppogr.$(OBJEXT) fpsysy.$(OBJEXT) regrid.$(OBJEXT) \ fpader.$(OBJEXT) fpcons.$(OBJEXT) fpgrre.$(OBJEXT) \ fppola.$(OBJEXT) fptrnp.$(OBJEXT) spalde.$(OBJEXT) \ bispev.$(OBJEXT) fpadno.$(OBJEXT) fpcosp.$(OBJEXT) \ fpgrsp.$(OBJEXT) fprank.$(OBJEXT) fptrpe.$(OBJEXT) \ spgrid.$(OBJEXT) clocur.$(OBJEXT) fpadpo.$(OBJEXT) \ fpcsin.$(OBJEXT) fpinst.$(OBJEXT) fprati.$(OBJEXT) \ sphere.$(OBJEXT) cocosp.$(OBJEXT) fpback.$(OBJEXT) \ fpcurf.$(OBJEXT) fpintb.$(OBJEXT) fpregr.$(OBJEXT) \ insert.$(OBJEXT) splder.$(OBJEXT) concon.$(OBJEXT) \ fpbacp.$(OBJEXT) fpcuro.$(OBJEXT) fpknot.$(OBJEXT) \ fprota.$(OBJEXT) parcur.$(OBJEXT) splev.$(OBJEXT) \ concur.$(OBJEXT) fpbfout.$(OBJEXT) fpcyt1.$(OBJEXT) \ fpopdi.$(OBJEXT) fprppo.$(OBJEXT) parder.$(OBJEXT) \ splint.$(OBJEXT) cualde.$(OBJEXT) fpbisp.$(OBJEXT) \ fpcyt2.$(OBJEXT) fpopsp.$(OBJEXT) fprpsp.$(OBJEXT) \ parsur.$(OBJEXT) sproot.$(OBJEXT) curev.$(OBJEXT) \ fpbspl.$(OBJEXT) fpdeno.$(OBJEXT) fporde.$(OBJEXT) \ fpseno.$(OBJEXT) percur.$(OBJEXT) surev.$(OBJEXT) \ curfit.$(OBJEXT) fpchec.$(OBJEXT) fpdisc.$(OBJEXT) \ fppara.$(OBJEXT) fpspgr.$(OBJEXT) pogrid.$(OBJEXT) \ surfit.$(OBJEXT) dblint.$(OBJEXT) fpched.$(OBJEXT) \ fpfrno.$(OBJEXT) fppasu.$(OBJEXT) fpsphe.$(OBJEXT) \ polar.$(OBJEXT) fpchep.$(OBJEXT) fpgivs.$(OBJEXT) \ fpperi.$(OBJEXT) fpsuev.$(OBJEXT) profil.$(OBJEXT) libfitpack_a_OBJECTS = $(am_libfitpack_a_OBJECTS) DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) F77COMPILE = $(F77) $(AM_FFLAGS) $(FFLAGS) F77LD = $(F77) F77LINK = $(F77LD) $(AM_FFLAGS) $(FFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o \ $@ SOURCES = $(libfitpack_a_SOURCES) DIST_SOURCES = $(libfitpack_a_SOURCES) ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ F77 = @F77@ FFLAGS = @FFLAGS@ FLIBS = @FLIBS@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ OBJEXT = @OBJEXT@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ POW_LIB = @POW_LIB@ RANLIB = @RANLIB@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ ac_ct_F77 = @ac_ct_F77@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build_alias = @build_alias@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host_alias = @host_alias@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ noinst_LIBRARIES = libfitpack.a libfitpack_a_SOURCES = evapol.f fpclos.f fpgrdi.f fppocu.f fpsurf.f\ fourco.f fpcoco.f fpgrpa.f fppogr.f fpsysy.f regrid.f \ fpader.f fpcons.f fpgrre.f fppola.f fptrnp.f spalde.f \ bispev.f fpadno.f fpcosp.f fpgrsp.f fprank.f fptrpe.f spgrid.f \ clocur.f fpadpo.f fpcsin.f fpinst.f fprati.f sphere.f \ cocosp.f fpback.f fpcurf.f fpintb.f fpregr.f insert.f splder.f \ concon.f fpbacp.f fpcuro.f fpknot.f fprota.f parcur.f splev.f \ concur.f fpbfout.f fpcyt1.f fpopdi.f fprppo.f parder.f splint.f \ cualde.f fpbisp.f fpcyt2.f fpopsp.f fprpsp.f parsur.f sproot.f \ curev.f fpbspl.f fpdeno.f fporde.f fpseno.f percur.f surev.f \ curfit.f fpchec.f fpdisc.f fppara.f fpspgr.f pogrid.f surfit.f \ dblint.f fpched.f fpfrno.f fppasu.f fpsphe.f polar.f \ fpchep.f fpgivs.f fpperi.f fpsuev.f profil.f all: all-am .SUFFIXES: .SUFFIXES: .f .o .obj $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu fitpack/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu fitpack/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): clean-noinstLIBRARIES: -test -z "$(noinst_LIBRARIES)" || rm -f $(noinst_LIBRARIES) libfitpack.a: $(libfitpack_a_OBJECTS) $(libfitpack_a_DEPENDENCIES) -rm -f libfitpack.a $(libfitpack_a_AR) libfitpack.a $(libfitpack_a_OBJECTS) $(libfitpack_a_LIBADD) $(RANLIB) libfitpack.a mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c .f.o: $(F77COMPILE) -c -o $@ $< .f.obj: $(F77COMPILE) -c -o $@ `$(CYGPATH_W) '$<'` ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ mkid -fID $$unique tags: TAGS TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) set x; \ here=`pwd`; \ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: CTAGS CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(LIBRARIES) installdirs: install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ `test -z '$(STRIP)' || \ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic clean-noinstLIBRARIES mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: .MAKE: install-am install-strip .PHONY: CTAGS GTAGS all all-am check check-am clean clean-generic \ clean-noinstLIBRARIES ctags distclean distclean-compile \ distclean-generic distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic pdf pdf-am ps ps-am tags uninstall \ uninstall-am # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: spd-1.3.0/fitpack/fpcuro.f0000644000175000017500000000467011633462460012324 00000000000000 subroutine fpcuro(a,b,c,d,x,n) c subroutine fpcuro finds the real zeros of a cubic polynomial c p(x) = a*x**3+b*x**2+c*x+d. c c calling sequence: c call fpcuro(a,b,c,d,x,n) c c input parameters: c a,b,c,d: real values, containing the coefficients of p(x). c c output parameters: c x : real array,length 3, which contains the real zeros of p(x) c n : integer, giving the number of real zeros of p(x). c .. c ..scalar arguments.. real a,b,c,d integer n c ..array argument.. real x(3) c ..local scalars.. integer i real a1,b1,c1,df,disc,d1,e3,f,four,half,ovfl,pi3,p3,q,r, * step,tent,three,two,u,u1,u2,y c ..function references.. real abs,amax1,atan,atan2,cos,sign,sqrt c set constants two = 0.2e+01 three = 0.3e+01 four = 0.4e+01 ovfl =0.1e+05 half = 0.5e+0 tent = 0.1e+0 e3 = tent/0.3e0 pi3 = atan(0.1e+01)/0.75e0 a1 = abs(a) b1 = abs(b) c1 = abs(c) d1 = abs(d) c test whether p(x) is a third degree polynomial. if(amax1(b1,c1,d1).lt.a1*ovfl) go to 300 c test whether p(x) is a second degree polynomial. if(amax1(c1,d1).lt.b1*ovfl) go to 200 c test whether p(x) is a first degree polynomial. if(d1.lt.c1*ovfl) go to 100 c p(x) is a constant function. n = 0 go to 800 c p(x) is a first degree polynomial. 100 n = 1 x(1) = -d/c go to 500 c p(x) is a second degree polynomial. 200 disc = c*c-four*b*d n = 0 if(disc.lt.0.) go to 800 n = 2 u = sqrt(disc) b1 = b+b x(1) = (-c+u)/b1 x(2) = (-c-u)/b1 go to 500 c p(x) is a third degree polynomial. 300 b1 = b/a*e3 c1 = c/a d1 = d/a q = c1*e3-b1*b1 r = b1*b1*b1+(d1-b1*c1)*half disc = q*q*q+r*r if(disc.gt.0.) go to 400 u = sqrt(abs(q)) if(r.lt.0.) u = -u p3 = atan2(sqrt(-disc),abs(r))*e3 u2 = u+u n = 3 x(1) = -u2*cos(p3)-b1 x(2) = u2*cos(pi3-p3)-b1 x(3) = u2*cos(pi3+p3)-b1 go to 500 400 u = sqrt(disc) u1 = -r+u u2 = -r-u n = 1 x(1) = sign(abs(u1)**e3,u1)+sign(abs(u2)**e3,u2)-b1 c apply a newton iteration to improve the accuracy of the roots. 500 do 700 i=1,n y = x(i) f = ((a*y+b)*y+c)*y+d df = (three*a*y+two*b)*y+c step = 0. if(abs(f).lt.abs(df)*tent) step = f/df x(i) = y-step 700 continue 800 return end spd-1.3.0/fitpack/fpknot.f0000644000175000017500000000400711633462460012321 00000000000000 subroutine fpknot(x,m,t,n,fpint,nrdata,nrint,nest,istart) c subroutine fpknot locates an additional knot for a spline of degree c k and adjusts the corresponding parameters,i.e. c t : the position of the knots. c n : the number of knots. c nrint : the number of knotintervals. c fpint : the sum of squares of residual right hand sides c for each knot interval. c nrdata: the number of data points inside each knot interval. c istart indicates that the smallest data point at which the new knot c may be added is x(istart+1) c .. c ..scalar arguments.. integer m,n,nrint,nest,istart c ..array arguments.. real x(m),t(nest),fpint(nest) integer nrdata(nest) c ..local scalars.. real an,am,fpmax integer ihalf,j,jbegin,jj,jk,jpoint,k,maxbeg,maxpt, * next,nrx,number c .. k = (n-nrint-1)/2 c search for knot interval t(number+k) <= x <= t(number+k+1) where c fpint(number) is maximal on the condition that nrdata(number) c not equals zero. fpmax = 0. jbegin = istart do 20 j=1,nrint jpoint = nrdata(j) if(fpmax.ge.fpint(j) .or. jpoint.eq.0) go to 10 fpmax = fpint(j) number = j maxpt = jpoint maxbeg = jbegin 10 jbegin = jbegin+jpoint+1 20 continue c let coincide the new knot t(number+k+1) with a data point x(nrx) c inside the old knot interval t(number+k) <= x <= t(number+k+1). ihalf = maxpt/2+1 nrx = maxbeg+ihalf next = number+1 if(next.gt.nrint) go to 40 c adjust the different parameters. do 30 j=next,nrint jj = next+nrint-j fpint(jj+1) = fpint(jj) nrdata(jj+1) = nrdata(jj) jk = jj+k t(jk+1) = t(jk) 30 continue 40 nrdata(number) = ihalf-1 nrdata(next) = maxpt-ihalf am = maxpt an = nrdata(number) fpint(number) = fpmax*an/am an = nrdata(next) fpint(next) = fpmax*an/am jk = next+k t(jk) = x(nrx) n = n+1 nrint = nrint+1 return end spd-1.3.0/fitpack/fpdeno.f0000644000175000017500000000253111633462460012273 00000000000000 subroutine fpdeno(maxtr,up,left,right,nbind,merk) c subroutine fpdeno frees the nodes of all branches of a triply linked c tree with length < nbind by putting to zero their up field. c on exit the parameter merk points to the terminal node of the c most left branch of length nbind or takes the value 1 if there c is no such branch. c .. c ..scalar arguments.. integer maxtr,nbind,merk c ..array arguments.. integer up(maxtr),left(maxtr),right(maxtr) c ..local scalars .. integer i,j,k,l,niveau,point c .. i = 1 niveau = 0 10 point = i i = left(point) if(i.eq.0) go to 20 niveau = niveau+1 go to 10 20 if(niveau.eq.nbind) go to 70 30 i = right(point) j = up(point) up(point) = 0 k = left(j) if(point.ne.k) go to 50 if(i.ne.0) go to 40 niveau = niveau-1 if(niveau.eq.0) go to 80 point = j go to 30 40 left(j) = i go to 10 50 l = right(k) if(point.eq.l) go to 60 k = l go to 50 60 right(k) = i point = k 70 i = right(point) if(i.ne.0) go to 10 i = up(point) niveau = niveau-1 if(niveau.eq.0) go to 80 point = i go to 70 80 k = 1 l = left(k) if(up(l).eq.0) return 90 merk = k k = left(k) if(k.ne.0) go to 90 return end spd-1.3.0/fitpack/fpfrno.f0000644000175000017500000000315711633462461012320 00000000000000 subroutine fpfrno(maxtr,up,left,right,info,point,merk,n1, * count,ier) c subroutine fpfrno collects the free nodes (up field zero) of the c triply linked tree the information of which is kept in the arrays c up,left,right and info. the maximal length of the branches of the c tree is given by n1. if no free nodes are found, the error flag c ier is set to 1. c .. c ..scalar arguments.. integer maxtr,point,merk,n1,count,ier c ..array arguments.. integer up(maxtr),left(maxtr),right(maxtr),info(maxtr) c ..local scalars integer i,j,k,l,n,niveau c .. ier = 1 if(n1.eq.2) go to 140 niveau = 1 count = 2 10 j = 0 i = 1 20 if(j.eq.niveau) go to 30 k = 0 l = left(i) if(l.eq.0) go to 110 i = l j = j+1 go to 20 30 if(i-count) 110,100,40 40 if(up(count).eq.0) go to 50 count = count+1 go to 30 50 up(count) = up(i) left(count) = left(i) right(count) = right(i) info(count) = info(i) if(merk.eq.i) merk = count if(point.eq.i) point = count if(k.eq.0) go to 60 right(k) = count go to 70 60 n = up(i) left(n) = count 70 l = left(i) 80 if(l.eq.0) go to 90 up(l) = count l = right(l) go to 80 90 up(i) = 0 i = count 100 count = count+1 110 l = right(i) k = i if(l.eq.0) go to 120 i = l go to 20 120 l = up(i) j = j-1 if(j.eq.0) go to 130 i = l go to 110 130 niveau = niveau+1 if(niveau.le.n1) go to 10 if(count.gt.maxtr) go to 140 ier = 0 140 return end spd-1.3.0/fitpack/fppogr.f0000644000175000017500000003342311633462460012321 00000000000000 subroutine fppogr(iopt,ider,u,mu,v,mv,z,mz,z0,r,s,nuest,nvest, * tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu,reducv,fpintu, * fpintv,dz,step,lastdi,nplusu,nplusv,lasttu,nru,nrv,nrdatu, * nrdatv,wrk,lwrk,ier) c .. c ..scalar arguments.. integer mu,mv,mz,nuest,nvest,maxit,nc,nu,nv,lastdi,nplusu,nplusv, * lasttu,lwrk,ier real z0,r,s,tol,fp,fp0,fpold,reducu,reducv,step c ..array arguments.. integer iopt(3),ider(2),nrdatu(nuest),nrdatv(nvest),nru(mu), * nrv(mv) real u(mu),v(mv),z(mz),tu(nuest),tv(nvest),c(nc),fpintu(nuest), * fpintv(nvest),dz(3),wrk(lwrk) c ..local scalars.. real acc,fpms,f1,f2,f3,p,per,pi,p1,p2,p3,vb,ve,zmax,zmin,rn,one, * con1,con4,con9 integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,istart,iter,i1,i2,j,ju, * ktu,l,l1,l2,l3,l4,mpm,mumin,mu0,mu1,nn,nplu,nplv,npl1,nrintu, * nrintv,nue,numax,nve,nvmax c ..local arrays.. integer idd(2) real dzz(3) c ..function references.. real abs,atan2,fprati integer max0,min0 c ..subroutine references.. c fpknot,fpopdi c .. c set constants one = 1 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 c initialization ifsu = 0 ifsv = 0 ifbu = 0 ifbv = 0 p = -one mumin = 4-iopt(3) if(ider(1).ge.0) mumin = mumin-1 if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1 pi = atan2(0.,-one) per = pi+pi vb = v(1) ve = vb+per cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position. c c **************************************************************** c c given a set of knots we compute the least-squares spline sinf(u,v) c c and the corresponding sum of squared residuals fp = f(p=inf). c c if iopt(1)=-1 sinf(u,v) is the requested approximation. c c if iopt(1)>=0 we check whether we can accept the knots: c c if fp <= s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares spline until finally fp <= s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots in the u-direction equals nu=numax=mu+5+iopt(2)+iopt(3) c c and in the v-direction nv=nvmax=mv+7. c c if s>0 and c c iopt(1)=0 we first compute the least-squares polynomial,i.e. a c c spline without interior knots : nu=8 ; nv=8. c c iopt(1)=1 we start with the set of knots found at the last call c c of the routine, except for the case that s > fp0; then we c c compute the least-squares polynomial directly. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iopt(1).lt.0) go to 120 c acc denotes the absolute tolerance for the root of f(p)=s. acc = tol*s c numax and nvmax denote the number of knots needed for interpolation. numax = mu+5+iopt(2)+iopt(3) nvmax = mv+7 nue = min0(numax,nuest) nve = min0(nvmax,nvest) if(s.gt.0.) go to 100 c if s = 0, s(u,v) is an interpolating spline. nu = numax nv = nvmax c test whether the required storage space exceeds the available one. if(nu.gt.nuest .or. nv.gt.nvest) go to 420 c find the position of the knots in the v-direction. do 10 l=1,mv tv(l+3) = v(l) 10 continue tv(mv+4) = ve l1 = mv-2 l2 = mv+5 do 20 i=1,3 tv(i) = v(l1)-per tv(l2) = v(i+1)+per l1 = l1+1 l2 = l2+1 20 continue c if not all the derivative values g(i,j) are given, we will first c estimate these values by computing a least-squares spline idd(1) = ider(1) if(idd(1).eq.0) idd(1) = 1 if(idd(1).gt.0) dz(1) = z0 idd(2) = ider(2) if(ider(1).lt.0) go to 30 if(iopt(2).eq.0 .or. ider(2).ne.0) go to 70 c we set up the knots in the u-direction for computing the least-squares c spline. 30 i1 = 3 i2 = mu-2 nu = 4 do 40 i=1,mu if(i1.gt.i2) go to 50 nu = nu+1 tu(nu) = u(i1) i1 = i1+2 40 continue 50 do 60 i=1,4 tu(i) = 0. nu = nu+1 tu(nu) = r 60 continue c we compute the least-squares spline for estimating the derivatives. call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd, * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, * wrk,lwrk) ifsu = 0 c if all the derivatives at the origin are known, we compute the c interpolating spline. c we set up the knots in the u-direction, needed for interpolation. 70 nn = numax-8 if(nn.eq.0) go to 95 ju = 2-iopt(2) do 80 l=1,nn tu(l+4) = u(ju) ju = ju+1 80 continue nu = numax l = nu do 90 i=1,4 tu(i) = 0. tu(l) = r l = l-1 90 continue c we compute the interpolating spline. 95 call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd, * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, * wrk,lwrk) go to 430 c if s>0 our initial choice of knots depends on the value of iopt(1). 100 ier = 0 if(iopt(1).eq.0) go to 115 step = -step if(fp0.le.s) go to 115 c if iopt(1)=1 and fp0 > s we start computing the least-squares spline c according to the set of knots found at the last call of the routine. c we determine the number of grid coordinates u(i) inside each knot c interval (tu(l),tu(l+1)). l = 5 j = 1 nrdatu(1) = 0 mu0 = 2-iopt(2) mu1 = mu-2+iopt(3) do 105 i=mu0,mu1 nrdatu(j) = nrdatu(j)+1 if(u(i).lt.tu(l)) go to 105 nrdatu(j) = nrdatu(j)-1 l = l+1 j = j+1 nrdatu(j) = 0 105 continue c we determine the number of grid coordinates v(i) inside each knot c interval (tv(l),tv(l+1)). l = 5 j = 1 nrdatv(1) = 0 do 110 i=2,mv nrdatv(j) = nrdatv(j)+1 if(v(i).lt.tv(l)) go to 110 nrdatv(j) = nrdatv(j)-1 l = l+1 j = j+1 nrdatv(j) = 0 110 continue idd(1) = ider(1) idd(2) = ider(2) go to 120 c if iopt(1)=0 or iopt(1)=1 and s >= fp0,we start computing the least- c squares polynomial (which is a spline without interior knots). 115 ier = -2 idd(1) = ider(1) idd(2) = 1 nu = 8 nv = 8 nrdatu(1) = mu-3+iopt(2)+iopt(3) nrdatv(1) = mv-1 lastdi = 0 nplusu = 0 nplusv = 0 fp0 = 0. fpold = 0. reducu = 0. reducv = 0. c main loop for the different sets of knots.mpm=mu+mv is a save upper c bound for the number of trials. 120 mpm = mu+mv do 270 iter=1,mpm c find nrintu (nrintv) which is the number of knot intervals in the c u-direction (v-direction). nrintu = nu-7 nrintv = nv-7 c find the position of the additional knots which are needed for the c b-spline representation of s(u,v). i = nu do 130 j=1,4 tu(j) = 0. tu(i) = r i = i-1 130 continue l1 = 4 l2 = l1 l3 = nv-3 l4 = l3 tv(l2) = vb tv(l3) = ve do 140 j=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tv(l2) = tv(l4)-per tv(l3) = tv(l1)+per 140 continue c find an estimate of the range of possible values for the optimal c derivatives at the origin. ktu = nrdatu(1)+2-iopt(2) if(nrintu.eq.1) ktu = mu if(ktu.lt.mumin) ktu = mumin if(ktu.eq.lasttu) go to 150 zmin = z0 zmax = z0 l = mv*ktu do 145 i=1,l if(z(i).lt.zmin) zmin = z(i) if(z(i).gt.zmax) zmax = z(i) 145 continue step = zmax-zmin lasttu = ktu c find the least-squares spline sinf(u,v). 150 call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,iopt,idd, * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, * wrk,lwrk) if(step.lt.0.) step = -step if(ier.eq.(-2)) fp0 = fp c test whether the least-squares spline is an acceptable solution. if(iopt(1).lt.0) go to 440 fpms = fp-s if(abs(fpms) .lt. acc) go to 440 c if f(p=inf) < s, we accept the choice of knots. if(fpms.lt.0.) go to 300 c if nu=numax and nv=nvmax, sinf(u,v) is an interpolating spline if(nu.eq.numax .and. nv.eq.nvmax) go to 430 c increase the number of knots. c if nu=nue and nv=nve we cannot further increase the number of knots c because of the storage capacity limitation. if(nu.eq.nue .and. nv.eq.nve) go to 420 if(ider(1).eq.0) fpintu(1) = fpintu(1)+(z0-c(1))**2 ier = 0 c adjust the parameter reducu or reducv according to the direction c in which the last added knots were located. if(lastdi) 160,155,170 155 nplv = 3 idd(2) = ider(2) fpold = fp go to 230 160 reducu = fpold-fp go to 175 170 reducv = fpold-fp c store the sum of squared residuals for the current set of knots. 175 fpold = fp c find nplu, the number of knots we should add in the u-direction. nplu = 1 if(nu.eq.8) go to 180 npl1 = nplusu*2 rn = nplusu if(reducu.gt.acc) npl1 = rn*fpms/reducu nplu = min0(nplusu*2,max0(npl1,nplusu/2,1)) c find nplv, the number of knots we should add in the v-direction. 180 nplv = 3 if(nv.eq.8) go to 190 npl1 = nplusv*2 rn = nplusv if(reducv.gt.acc) npl1 = rn*fpms/reducv nplv = min0(nplusv*2,max0(npl1,nplusv/2,1)) c test whether we are going to add knots in the u- or v-direction. 190 if(nplu-nplv) 210,200,230 200 if(lastdi.lt.0) go to 230 210 if(nu.eq.nue) go to 230 c addition in the u-direction. lastdi = -1 nplusu = nplu ifsu = 0 istart = 0 if(iopt(2).eq.0) istart = 1 do 220 l=1,nplusu c add a new knot in the u-direction call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,istart) c test whether we cannot further increase the number of knots in the c u-direction. if(nu.eq.nue) go to 270 220 continue go to 270 230 if(nv.eq.nve) go to 210 c addition in the v-direction. lastdi = 1 nplusv = nplv ifsv = 0 do 240 l=1,nplusv c add a new knot in the v-direction. call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1) c test whether we cannot further increase the number of knots in the c v-direction. if(nv.eq.nve) go to 270 240 continue c restart the computations with the new set of knots. 270 continue c test whether the least-squares polynomial is a solution of our c approximation problem. 300 if(ier.eq.(-2)) go to 440 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline sp(u,v) c c ***************************************************** c c we have determined the number of knots and their position. we now c c compute the b-spline coefficients of the smoothing spline sp(u,v). c c this smoothing spline depends on the parameter p in such a way that c c f(p) = sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) c c is a continuous, strictly decreasing function of p. moreover the c c least-squares polynomial corresponds to p=0 and the least-squares c c spline to p=infinity. then iteratively we have to determine the c c positive value of p such that f(p)=s. the process which is proposed c c here makes use of rational interpolation. f(p) is approximated by a c c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c c are used to calculate the new value of p such that r(p)=s. c c convergence is guaranteed by taking f1 > 0 and f3 < 0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = one dzz(1) = dz(1) dzz(2) = dz(2) dzz(3) = dz(3) ich1 = 0 ich3 = 0 c iteration process to find the root of f(p)=s. do 350 iter = 1,maxit c find the smoothing spline sp(u,v) and the corresponding sum f(p). call fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dzz,iopt,idd, * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, * wrk,lwrk) c test whether the approximation sp(u,v) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 440 c test whether the maximum allowable number of iterations has been c reached. if(iter.eq.maxit) go to 400 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 320 if((f2-f3).gt.acc) go to 310 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 + p2*con1 go to 350 310 if(f2.lt.0.) ich3 = 1 320 if(ich1.ne.0) go to 340 if((f1-f2).gt.acc) go to 330 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 350 if(p.ge.p3) p = p2*con1 + p3*con9 go to 350 c test whether the iteration process proceeds as theoretically c expected. 330 if(f2.gt.0.) ich1 = 1 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 c find the new value of p. p = fprati(p1,f1,p2,f2,p3,f3) 350 continue c error codes and messages. 400 ier = 3 go to 440 410 ier = 2 go to 440 420 ier = 1 go to 440 430 ier = -1 fp = 0. 440 return end spd-1.3.0/fitpack/parcur.f0000644000175000017500000004101311633462460012312 00000000000000 subroutine parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s,nest,n,t, * nc,c,fp,wrk,lwrk,iwrk,ier) c given the ordered set of m points x(i) in the idim-dimensional space c and given also a corresponding set of strictly increasing values u(i) c and the set of positive numbers w(i),i=1,2,...,m, subroutine parcur c determines a smooth approximating spline curve s(u), i.e. c x1 = s1(u) c x2 = s2(u) ub <= u <= ue c ......... c xidim = sidim(u) c with sj(u),j=1,2,...,idim spline functions of degree k with common c knots t(j),j=1,2,...,n. c if ipar=1 the values ub,ue and u(i),i=1,2,...,m must be supplied by c the user. if ipar=0 these values are chosen automatically by parcur c as v(1) = 0 c v(i) = v(i-1) + dist(x(i),x(i-1)) ,i=2,3,...,m c u(i) = v(i)/v(m) ,i=1,2,...,m c ub = u(1) = 0, ue = u(m) = 1. c if iopt=-1 parcur calculates the weighted least-squares spline curve c according to a given set of knots. c if iopt>=0 the number of knots of the splines sj(u) and the position c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- c ness of s(u) is then achieved by minimalizing the discontinuity c jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,..., c n-k-1. the amount of smoothness is determined by the condition that c f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non- c negative constant, called the smoothing factor. c the fit s(u) is given in the b-spline representation and can be c evaluated by means of subroutine curev. c c calling sequence: c call parcur(iopt,ipar,idim,m,u,mx,x,w,ub,ue,k,s,nest,n,t,nc,c, c * fp,wrk,lwrk,iwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a weighted c least-squares spline curve (iopt=-1) or a smoothing spline c curve (iopt=0 or 1) must be determined.if iopt=0 the routine c will start with an initial set of knots t(i)=ub,t(i+k+1)=ue, c i=1,2,...,k+1. if iopt=1 the routine will continue with the c knots found at the last call of the routine. c attention: a call with iopt=1 must always be immediately c preceded by another call with iopt=1 or iopt=0. c unchanged on exit. c ipar : integer flag. on entry ipar must specify whether (ipar=1) c the user will supply the parameter values u(i),ub and ue c or whether (ipar=0) these values are to be calculated by c parcur. unchanged on exit. c idim : integer. on entry idim must specify the dimension of the c curve. 0 < idim < 11. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m > k. unchanged on exit. c u : real array of dimension at least (m). in case ipar=1,before c entry, u(i) must be set to the i-th value of the parameter c variable u for i=1,2,...,m. these values must then be c supplied in strictly ascending order and will be unchanged c on exit. in case ipar=0, on exit,array u will contain the c values u(i) as determined by parcur. c mx : integer. on entry mx must specify the actual dimension of c the array x as declared in the calling (sub)program. mx must c not be too small (see x). unchanged on exit. c x : real array of dimension at least idim*m. c before entry, x(idim*(i-1)+j) must contain the j-th coord- c inate of the i-th data point for i=1,2,...,m and j=1,2,..., c idim. unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) c must be set to the i-th value in the set of weights. the c w(i) must be strictly positive. unchanged on exit. c see also further comments. c ub,ue : real values. on entry (in case ipar=1) ub and ue must c contain the lower and upper bound for the parameter u. c ub <=u(1), ue>= u(m). if ipar = 0 these values will c automatically be set to 0 and 1 by parcur. c k : integer. on entry k must specify the degree of the splines. c 1<=k<=5. it is recommended to use cubic splines (k=3). c the user is strongly dissuaded from choosing k even,together c with a small s-value. unchanged on exit. c s : real.on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments. c nest : integer. on entry nest must contain an over-estimate of the c total number of knots of the splines returned, to indicate c the storage space available to the routine. nest >=2*k+2. c in most practical situation nest=m/2 will be sufficient. c always large enough is nest=m+k+1, the number of knots c needed for interpolation (s=0). unchanged on exit. c n : integer. c unless ier = 10 (in case iopt >=0), n will contain the c total number of knots of the smoothing spline curve returned c if the computation mode iopt=1 is used this value of n c should be left unchanged between subsequent calls. c in case iopt=-1, the value of n must be specified on entry. c t : real array of dimension at least (nest). c on succesful exit, this array will contain the knots of the c spline curve,i.e. the position of the interior knots t(k+2), c t(k+3),..,t(n-k-1) as well as the position of the additional c t(1)=t(2)=...=t(k+1)=ub and t(n-k)=...=t(n)=ue needed for c the b-spline representation. c if the computation mode iopt=1 is used, the values of t(1), c t(2),...,t(n) should be left unchanged between subsequent c calls. if the computation mode iopt=-1 is used, the values c t(k+2),...,t(n-k-1) must be supplied by the user, before c entry. see also the restrictions (ier=10). c nc : integer. on entry nc must specify the actual dimension of c the array c as declared in the calling (sub)program. nc c must not be too small (see c). unchanged on exit. c c : real array of dimension at least (nest*idim). c on succesful exit, this array will contain the coefficients c in the b-spline representation of the spline curve s(u),i.e. c the b-spline coefficients of the spline sj(u) will be given c in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim. c fp : real. unless ier = 10, fp contains the weighted sum of c squared residuals of the spline curve returned. c wrk : real array of dimension at least m*(k+1)+nest*(6+idim+3*k). c used as working space. if the computation mode iopt=1 is c used, the values wrk(1),...,wrk(n) should be left unchanged c between subsequent calls. c lwrk : integer. on entry,lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. lwrk c must not be too small (see wrk). unchanged on exit. c iwrk : integer array of dimension at least (nest). c used as working space. if the computation mode iopt=1 is c used,the values iwrk(1),...,iwrk(n) should be left unchanged c between subsequent calls. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the curve returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the curve returned is an interpolating c spline curve (fp=0). c ier=-2 : normal return. the curve returned is the weighted least- c squares polynomial curve of degree k.in this extreme case c fp gives the upper bound fp0 for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameter nest. c probably causes : nest too small. if nest is already c large (say nest > m/2), it may also indicate that s is c too small c the approximation returned is the least-squares spline c curve according to the knots t(1),t(2),...,t(n). (n=nest) c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline curve c with fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing curve c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m c 0<=ipar<=1, 0=(k+1)*m+nest*(6+idim+3*k), c nc>=nest*idim c if ipar=0: sum j=1,idim (x(idim*i+j)-x(idim*(i-1)+j))**2>0 c i=1,2,...,m-1. c if ipar=1: ub<=u(1)=0: s>=0 c if s=0 : nest >= m+k+1 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the curve will be too smooth and signal will be c lost ; if s is too small the curve will pick up too much noise. in c the extreme cases the program will return an interpolating curve if c s=0 and the least-squares polynomial curve of degree k if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c x(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in x(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the least-squares c polynomial curve and the upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximating curve shows more detail) to obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if parcur is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c curve underlying the data. but, if the computation mode iopt=1 is c used, the knots returned may also depend on the s-values at previous c calls (if these were smaller). therefore, if after a number of c trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c parcur once more with the selected value for s but now with iopt=0. c indeed, parcur may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c c the form of the approximating curve can strongly be affected by c the choice of the parameter values u(i). if there is no physical c reason for choosing a particular parameter u, often good results c will be obtained with the choice of parcur (in case ipar=0), i.e. c v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m c where c q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 ) c other possibilities for q(i) are c q(i)= sum j=1,idim (xj(i)-xj(i-1))**2 c q(i)= sum j=1,idim abs(xj(i)-xj(i-1)) c q(i)= max j=1,idim abs(xj(i)-xj(i-1)) c q(i)= 1 c c other subroutines required: c fpback,fpbspl,fpchec,fppara,fpdisc,fpgivs,fpknot,fprati,fprota c c references: c dierckx p. : algorithms for smoothing data with periodic and c parametric splines, computer graphics and image c processing 20 (1982) 171-184. c dierckx p. : algorithms for smoothing data with periodic and param- c etric splines, report tw55, dept. computer science, c k.u.leuven, 1981. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : may 1979 c latest update : march 1987 c c .. c ..scalar arguments.. real ub,ue,s,fp integer iopt,ipar,idim,m,mx,k,nest,n,nc,lwrk,ier c ..array arguments.. real u(m),x(mx),w(m),t(nest),c(nc),wrk(lwrk) integer iwrk(nest) c ..local scalars.. real tol,dist integer i,ia,ib,ifp,ig,iq,iz,i1,i2,j,k1,k2,lwest,maxit,nmin,ncc c ..function references real sqrt c .. c we set up the parameters tol and maxit maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(iopt.lt.(-1) .or. iopt.gt.1) go to 90 if(ipar.lt.0 .or. ipar.gt.1) go to 90 if(idim.le.0 .or. idim.gt.10) go to 90 if(k.le.0 .or. k.gt.5) go to 90 k1 = k+1 k2 = k1+1 nmin = 2*k1 if(m.lt.k1 .or. nest.lt.nmin) go to 90 ncc = nest*idim if(mx.lt.m*idim .or. nc.lt.ncc) go to 90 lwest = m*k1+nest*(6+idim+3*k) if(lwrk.lt.lwest) go to 90 if(ipar.ne.0 .or. iopt.gt.0) go to 40 i1 = 0 i2 = idim u(1) = 0. do 20 i=2,m dist = 0. do 10 j=1,idim i1 = i1+1 i2 = i2+1 dist = dist+(x(i2)-x(i1))**2 10 continue u(i) = u(i-1)+sqrt(dist) 20 continue if(u(m).le.0.) go to 90 do 30 i=2,m u(i) = u(i)/u(m) 30 continue ub = 0. ue = 1. u(m) = ue 40 if(ub.gt.u(1) .or. ue.lt.u(m) .or. w(1).le.0.) go to 90 do 50 i=2,m if(u(i-1).ge.u(i) .or. w(i).le.0.) go to 90 50 continue if(iopt.ge.0) go to 70 if(n.lt.nmin .or. n.gt.nest) go to 90 j = n do 60 i=1,k1 t(i) = ub t(j) = ue j = j-1 60 continue call fpchec(u,m,t,n,k,ier) if(ier) 90,80,90 70 if(s.lt.0.) go to 90 if(s.eq.0. .and. nest.lt.(m+k1)) go to 90 ier = 0 c we partition the working space and determine the spline curve. 80 ifp = 1 iz = ifp+nest ia = iz+ncc ib = ia+nest*k1 ig = ib+nest*k2 iq = ig+nest*k2 call fppara(iopt,idim,m,u,mx,x,w,ub,ue,k,s,nest,tol,maxit,k1,k2, * n,t,ncc,c,fp,wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq), * iwrk,ier) 90 return end spd-1.3.0/fitpack/fpchep.f0000644000175000017500000000435011633462461012267 00000000000000 subroutine fpchep(x,m,t,n,k,ier) c subroutine fpchep verifies the number and the position of the knots c t(j),j=1,2,...,n of a periodic spline of degree k, in relation to c the number and the position of the data points x(i),i=1,2,...,m. c if all of the following conditions are fulfilled, ier is set c to zero. if one of the conditions is violated ier is set to ten. c 1) k+1 <= n-k-1 <= m+k-1 c 2) t(1) <= t(2) <= ... <= t(k+1) c t(n-k) <= t(n-k+1) <= ... <= t(n) c 3) t(k+1) < t(k+2) < ... < t(n-k) c 4) t(k+1) <= x(i) <= t(n-k) c 5) the conditions specified by schoenberg and whitney must hold c for at least one subset of data points, i.e. there must be a c subset of data points y(j) such that c t(j) < y(j) < t(j+k+1), j=k+1,...,n-k-1 c .. c ..scalar arguments.. integer m,n,k,ier c ..array arguments.. real x(m),t(n) c ..local scalars.. integer i,i1,i2,j,j1,k1,k2,l,l1,l2,mm,m1,nk1,nk2 real per,tj,tl,xi c .. k1 = k+1 k2 = k1+1 nk1 = n-k1 nk2 = nk1+1 m1 = m-1 ier = 10 c check condition no 1 if(nk1.lt.k1 .or. n.gt.m+2*k) go to 130 c check condition no 2 j = n do 20 i=1,k if(t(i).gt.t(i+1)) go to 130 if(t(j).lt.t(j-1)) go to 130 j = j-1 20 continue c check condition no 3 do 30 i=k2,nk2 if(t(i).le.t(i-1)) go to 130 30 continue c check condition no 4 if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 130 c check condition no 5 l1 = k1 l2 = 1 do 50 l=1,m xi = x(l) 40 if(xi.lt.t(l1+1) .or. l.eq.nk1) go to 50 l1 = l1+1 l2 = l2+1 if(l2.gt.k1) go to 60 go to 40 50 continue l = m 60 per = t(nk2)-t(k1) do 120 i1=2,l i = i1-1 mm = i+m1 do 110 j=k1,nk1 tj = t(j) j1 = j+k1 tl = t(j1) 70 i = i+1 if(i.gt.mm) go to 120 i2 = i-m1 if(i2) 80,80,90 80 xi = x(i) go to 100 90 xi = x(i2)+per 100 if(xi.le.tj) go to 70 if(xi.ge.tl) go to 120 110 continue ier = 0 go to 130 120 continue 130 return end spd-1.3.0/fitpack/percur.f0000644000175000017500000003321411633462460012322 00000000000000 subroutine percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp, * wrk,lwrk,iwrk,ier) c given the set of data points (x(i),y(i)) and the set of positive c numbers w(i),i=1,2,...,m-1, subroutine percur determines a smooth c periodic spline approximation of degree k with period per=x(m)-x(1). c if iopt=-1 percur calculates the weighted least-squares periodic c spline according to a given set of knots. c if iopt>=0 the number of knots of the spline s(x) and the position c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- c ness of s(x) is then achieved by minimalizing the discontinuity c jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,..., c n-k-1. the amount of smoothness is determined by the condition that c f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non- c negative constant, called the smoothing factor. c the fit s(x) is given in the b-spline representation (b-spline coef- c ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of c subroutine splev. c c calling sequence: c call percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp,wrk, c * lwrk,iwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a weighted c least-squares spline (iopt=-1) or a smoothing spline (iopt= c 0 or 1) must be determined. if iopt=0 the routine will start c with an initial set of knots t(i)=x(1)+(x(m)-x(1))*(i-k-1), c i=1,2,...,2*k+2. if iopt=1 the routine will continue with c the knots found at the last call of the routine. c attention: a call with iopt=1 must always be immediately c preceded by another call with iopt=1 or iopt=0. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m > 1. unchanged on exit. c x : real array of dimension at least (m). before entry, x(i) c must be set to the i-th value of the independent variable x, c for i=1,2,...,m. these values must be supplied in strictly c ascending order. x(m) only indicates the length of the c period of the spline, i.e per=x(m)-x(1). c unchanged on exit. c y : real array of dimension at least (m). before entry, y(i) c must be set to the i-th value of the dependent variable y, c for i=1,2,...,m-1. the element y(m) is not used. c unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) c must be set to the i-th value in the set of weights. the c w(i) must be strictly positive. w(m) is not used. c see also further comments. unchanged on exit. c k : integer. on entry k must specify the degree of the spline. c 1<=k<=5. it is recommended to use cubic splines (k=3). c the user is strongly dissuaded from choosing k even,together c with a small s-value. unchanged on exit. c s : real.on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments. c nest : integer. on entry nest must contain an over-estimate of the c total number of knots of the spline returned, to indicate c the storage space available to the routine. nest >=2*k+2. c in most practical situation nest=m/2 will be sufficient. c always large enough is nest=m+2*k,the number of knots needed c for interpolation (s=0). unchanged on exit. c n : integer. c unless ier = 10 (in case iopt >=0), n will contain the c total number of knots of the spline approximation returned. c if the computation mode iopt=1 is used this value of n c should be left unchanged between subsequent calls. c in case iopt=-1, the value of n must be specified on entry. c t : real array of dimension at least (nest). c on succesful exit, this array will contain the knots of the c spline,i.e. the position of the interior knots t(k+2),t(k+3) c ...,t(n-k-1) as well as the position of the additional knots c t(1),t(2),...,t(k+1)=x(1) and t(n-k)=x(m),..,t(n) needed for c the b-spline representation. c if the computation mode iopt=1 is used, the values of t(1), c t(2),...,t(n) should be left unchanged between subsequent c calls. if the computation mode iopt=-1 is used, the values c t(k+2),...,t(n-k-1) must be supplied by the user, before c entry. see also the restrictions (ier=10). c c : real array of dimension at least (nest). c on succesful exit, this array will contain the coefficients c c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x) c fp : real. unless ier = 10, fp contains the weighted sum of c squared residuals of the spline approximation returned. c wrk : real array of dimension at least (m*(k+1)+nest*(8+5*k)). c used as working space. if the computation mode iopt=1 is c used, the values wrk(1),...,wrk(n) should be left unchanged c between subsequent calls. c lwrk : integer. on entry,lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. lwrk c must not be too small (see wrk). unchanged on exit. c iwrk : integer array of dimension at least (nest). c used as working space. if the computation mode iopt=1 is c used,the values iwrk(1),...,iwrk(n) should be left unchanged c between subsequent calls. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is an interpolating c periodic spline (fp=0). c ier=-2 : normal return. the spline returned is the weighted least- c squares constant. in this extreme case fp gives the upper c bound fp0 for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameter nest. c probably causes : nest too small. if nest is already c large (say nest > m/2), it may also indicate that s is c too small c the approximation returned is the least-squares periodic c spline according to the knots t(1),t(2),...,t(n). (n=nest) c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, 1<=k<=5, m>1, nest>2*k+2, w(i)>0,i=1,...,m-1 c x(1)=(k+1)*m+nest*(8+5*k) c if iopt=-1: 2*k+2<=n<=min(nest,m+2*k) c x(1)=0: s>=0 c if s=0 : nest >= m+2*k c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating periodic c spline if s=0 and the weighted least-squares constant if s is very c large. between these extremes, a properly chosen s will result in c a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c y(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in y(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the least-squares c constant and the corresponding upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximation shows more detail) to obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if percur is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. but, if the computation mode iopt=1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c percur once more with the selected value for s but now with iopt=0. c indeed, percur may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c c other subroutines required: c fpbacp,fpbspl,fpchep,fpperi,fpdisc,fpgivs,fpknot,fprati,fprota c c references: c dierckx p. : algorithms for smoothing data with periodic and c parametric splines, computer graphics and image c processing 20 (1982) 171-184. c dierckx p. : algorithms for smoothing data with periodic and param- c etric splines, report tw55, dept. computer science, c k.u.leuven, 1981. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : may 1979 c latest update : march 1987 c c .. c ..scalar arguments.. real s,fp integer iopt,m,k,nest,n,lwrk,ier c ..array arguments.. real x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk) integer iwrk(nest) c ..local scalars.. real per,tol integer i,ia1,ia2,ib,ifp,ig1,ig2,iq,iz,i1,i2,j1,j2,k1,k2,lwest, * maxit,m1,nmin c ..subroutine references.. c perper,pcheck c .. c we set up the parameters tol and maxit maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(k.le.0 .or. k.gt.5) go to 50 k1 = k+1 k2 = k1+1 if(iopt.lt.(-1) .or. iopt.gt.1) go to 50 nmin = 2*k1 if(m.lt.2 .or. nest.lt.nmin) go to 50 lwest = m*k1+nest*(8+5*k) if(lwrk.lt.lwest) go to 50 m1 = m-1 do 10 i=1,m1 if(x(i).ge.x(i+1) .or. w(i).le.0.) go to 50 10 continue if(iopt.ge.0) go to 30 if(n.le.nmin .or. n.gt.nest) go to 50 per = x(m)-x(1) j1 = k1 t(j1) = x(1) i1 = n-k t(i1) = x(m) j2 = j1 i2 = i1 do 20 i=1,k i1 = i1+1 i2 = i2-1 j1 = j1+1 j2 = j2-1 t(j2) = t(i2)-per t(i1) = t(j1)+per 20 continue call fpchep(x,m,t,n,k,ier) if(ier) 50,40,50 30 if(s.lt.0.) go to 50 if(s.eq.0. .and. nest.lt.(m+2*k)) go to 50 ier = 0 c we partition the working space and determine the spline approximation. 40 ifp = 1 iz = ifp+nest ia1 = iz+nest ia2 = ia1+nest*k1 ib = ia2+nest*k ig1 = ib+nest*k2 ig2 = ig1+nest*k2 iq = ig2+nest*k1 call fpperi(iopt,x,y,w,m,k,s,nest,tol,maxit,k1,k2,n,t,c,fp, * wrk(ifp),wrk(iz),wrk(ia1),wrk(ia2),wrk(ib),wrk(ig1),wrk(ig2), * wrk(iq),iwrk,ier) 50 return end spd-1.3.0/fitpack/cualde.f0000644000175000017500000000573211633462460012263 00000000000000 subroutine cualde(idim,t,n,c,nc,k1,u,d,nd,ier) c subroutine cualde evaluates at the point u all the derivatives c (l) c d(idim*l+j) = sj (u) ,l=0,1,...,k, j=1,2,...,idim c of a spline curve s(u) of order k1 (degree k=k1-1) and dimension idim c given in its b-spline representation. c c calling sequence: c call cualde(idim,t,n,c,nc,k1,u,d,nd,ier) c c input parameters: c idim : integer, giving the dimension of the spline curve. c t : array,length n, which contains the position of the knots. c n : integer, giving the total number of knots of s(u). c c : array,length nc, which contains the b-spline coefficients. c nc : integer, giving the total number of coefficients of s(u). c k1 : integer, giving the order of s(u) (order=degree+1). c u : real, which contains the point where the derivatives must c be evaluated. c nd : integer, giving the dimension of the array d. nd >= k1*idim c c output parameters: c d : array,length nd,giving the different curve derivatives. c d(idim*l+j) will contain the j-th coordinate of the l-th c derivative of the curve at the point u. c ier : error flag c ier = 0 : normal return c ier =10 : invalid input data (see restrictions) c c restrictions: c nd >= k1*idim c t(k1) <= u <= t(n-k1+1) c c further comments: c if u coincides with a knot, right derivatives are computed c ( left derivatives if u = t(n-k1+1) ). c c other subroutines required: fpader. c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer idim,n,nc,k1,nd,ier real u c ..array arguments.. real t(n),c(nc),d(nd) c ..local scalars.. integer i,j,kk,l,m,nk1 c ..local array.. real h(6) c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 if(nd.lt.(k1*idim)) go to 500 nk1 = n-k1 if(u.lt.t(k1) .or. u.gt.t(nk1+1)) go to 500 c search for knot interval t(l) <= u < t(l+1) l = k1 100 if(u.lt.t(l+1) .or. l.eq.nk1) go to 200 l = l+1 go to 100 200 if(t(l).ge.t(l+1)) go to 500 ier = 0 c calculate the derivatives. j = 1 do 400 i=1,idim call fpader(t,n,c(j),k1,u,l,h) m = i do 300 kk=1,k1 d(m) = h(kk) m = m+idim 300 continue j = j+n 400 continue 500 return end spd-1.3.0/fitpack/fpintb.f0000644000175000017500000000706711633462460012313 00000000000000 subroutine fpintb(t,n,bint,nk1,x,y) c subroutine fpintb calculates integrals of the normalized b-splines c nj,k+1(x) of degree k, defined on the set of knots t(j),j=1,2,...n. c it makes use of the formulae of gaffney for the calculation of c indefinite integrals of b-splines. c c calling sequence: c call fpintb(t,n,bint,nk1,x,y) c c input parameters: c t : real array,length n, containing the position of the knots. c n : integer value, giving the number of knots. c nk1 : integer value, giving the number of b-splines of degree k, c defined on the set of knots ,i.e. nk1 = n-k-1. c x,y : real values, containing the end points of the integration c interval. c output parameter: c bint : array,length nk1, containing the integrals of the b-splines. c .. c ..scalars arguments.. integer n,nk1 real x,y c ..array arguments.. real t(n),bint(nk1) c ..local scalars.. integer i,ia,ib,it,j,j1,k,k1,l,li,lj,lk,l0,min real a,ak,arg,b,f,one c ..local arrays.. real aint(6),h(6),h1(6) c initialization. one = 0.1e+01 k1 = n-nk1 ak = k1 k = k1-1 do 10 i=1,nk1 bint(i) = 0. 10 continue c the integration limits are arranged in increasing order. a = x b = y min = 0 if(a-b) 30,160,20 20 a = y b = x min = 1 30 if(a.lt.t(k1)) a = t(k1) if(b.gt.t(nk1+1)) b = t(nk1+1) c using the expression of gaffney for the indefinite integral of a c b-spline we find that c bint(j) = (t(j+k+1)-t(j))*(res(j,b)-res(j,a))/(k+1) c where for t(l) <= x < t(l+1) c res(j,x) = 0, j=1,2,...,l-k-1 c = 1, j=l+1,l+2,...,nk1 c = aint(j+k-l+1), j=l-k,l-k+1,...,l c = sumi((x-t(j+i))*nj+i,k+1-i(x)/(t(j+k+1)-t(j+i))) c i=0,1,...,k l = k1 l0 = l+1 c set arg = a. arg = a do 90 it=1,2 c search for the knot interval t(l) <= arg < t(l+1). 40 if(arg.lt.t(l0) .or. l.eq.nk1) go to 50 l = l0 l0 = l+1 go to 40 c calculation of aint(j), j=1,2,...,k+1. c initialization. 50 do 55 j=1,k1 aint(j) = 0. 55 continue aint(1) = (arg-t(l))/(t(l+1)-t(l)) h1(1) = one do 70 j=1,k c evaluation of the non-zero b-splines of degree j at arg,i.e. c h(i+1) = nl-j+i,j(arg), i=0,1,...,j. h(1) = 0. do 60 i=1,j li = l+i lj = li-j f = h1(i)/(t(li)-t(lj)) h(i) = h(i)+f*(t(li)-arg) h(i+1) = f*(arg-t(lj)) 60 continue c updating of the integrals aint. j1 = j+1 do 70 i=1,j1 li = l+i lj = li-j1 aint(i) = aint(i)+h(i)*(arg-t(lj))/(t(li)-t(lj)) h1(i) = h(i) 70 continue if(it.eq.2) go to 100 c updating of the integrals bint lk = l-k ia = lk do 80 i=1,k1 bint(lk) = -aint(i) lk = lk+1 80 continue c set arg = b. arg = b 90 continue c updating of the integrals bint. 100 lk = l-k ib = lk-1 do 110 i=1,k1 bint(lk) = bint(lk)+aint(i) lk = lk+1 110 continue if(ib.lt.ia) go to 130 do 120 i=ia,ib bint(i) = bint(i)+one 120 continue c the scaling factors are taken into account. 130 f = one/ak do 140 i=1,nk1 j = i+k1 bint(i) = bint(i)*(t(j)-t(i))*f 140 continue c the order of the integration limits is taken into account. if(min.eq.0) go to 160 do 150 i=1,nk1 bint(i) = -bint(i) 150 continue 160 return end spd-1.3.0/fitpack/fpdisc.f0000644000175000017500000000201711633462461012270 00000000000000 subroutine fpdisc(t,n,k2,b,nest) c subroutine fpdisc calculates the discontinuity jumps of the kth c derivative of the b-splines of degree k at the knots t(k+2)..t(n-k-1) c ..scalar arguments.. integer n,k2,nest c ..array arguments.. real t(n),b(nest,k2) c ..local scalars.. real an,fac,prod integer i,ik,j,jk,k,k1,l,lj,lk,lmk,lp,nk1,nrint c ..local array.. real h(12) c .. k1 = k2-1 k = k1-1 nk1 = n-k1 nrint = nk1-k an = nrint fac = an/(t(nk1+1)-t(k1)) do 40 l=k2,nk1 lmk = l-k1 do 10 j=1,k1 ik = j+k1 lj = l+j lk = lj-k2 h(j) = t(l)-t(lk) h(ik) = t(l)-t(lj) 10 continue lp = lmk do 30 j=1,k2 jk = j prod = h(j) do 20 i=1,k jk = jk+1 prod = prod*h(jk)*fac 20 continue lk = lp+k1 b(lmk,j) = (t(lk)-t(lp))/prod lp = lp+1 30 continue 40 continue return end spd-1.3.0/fitpack/profil.f0000644000175000017500000000704011633462460012313 00000000000000 subroutine profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) c if iopt=0 subroutine profil calculates the b-spline coefficients of c the univariate spline f(y) = s(u,y) with s(x,y) a bivariate spline of c degrees kx and ky, given in the b-spline representation. c if iopt = 1 it calculates the b-spline coefficients of the univariate c spline g(x) = s(x,u) c c calling sequence: c call profil(iopt,tx,nx,ty,ny,c,kx,ky,u,nu,cu,ier) c c input parameters: c iopt : integer flag, specifying whether the profile f(y) (iopt=0) c or the profile g(x) (iopt=1) must be determined. c tx : real array, length nx, which contains the position of the c knots in the x-direction. c nx : integer, giving the total number of knots in the x-direction c ty : real array, length ny, which contains the position of the c knots in the y-direction. c ny : integer, giving the total number of knots in the y-direction c c : real array, length (nx-kx-1)*(ny-ky-1), which contains the c b-spline coefficients. c kx,ky : integer values, giving the degrees of the spline. c u : real value, specifying the requested profile. c tx(kx+1)<=u<=tx(nx-kx), if iopt=0. c ty(ky+1)<=u<=ty(ny-ky), if iopt=1. c nu : on entry nu must specify the dimension of the array cu. c nu >= ny if iopt=0, nu >= nx if iopt=1. c c output parameters: c cu : real array of dimension (nu). c on succesful exit this array contains the b-spline c ier : integer error flag c ier=0 : normal return c ier=10: invalid input data (see restrictions) c c restrictions: c if iopt=0 : tx(kx+1) <= u <= tx(nx-kx), nu >=ny. c if iopt=1 : ty(ky+1) <= u <= ty(ny-ky), nu >=nx. c c other subroutines required: c fpbspl c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer iopt,nx,ny,kx,ky,nu,ier real u c ..array arguments.. real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),cu(nu) c ..local scalars.. integer i,j,kx1,ky1,l,l1,m,m0,nkx1,nky1 real sum c ..local array real h(6) c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. kx1 = kx+1 ky1 = ky+1 nkx1 = nx-kx1 nky1 = ny-ky1 ier = 10 if(iopt.ne.0) go to 200 if(nu.lt.ny) go to 300 if(u.lt.tx(kx1) .or. u.gt.tx(nkx1+1)) go to 300 c the b-splinecoefficients of f(y) = s(u,y). ier = 0 l = kx1 l1 = l+1 110 if(u.lt.tx(l1) .or. l.eq.nkx1) go to 120 l = l1 l1 = l+1 go to 110 120 call fpbspl(tx,nx,kx,u,l,h) m0 = (l-kx1)*nky1+1 do 140 i=1,nky1 m = m0 sum = 0. do 130 j=1,kx1 sum = sum+h(j)*c(m) m = m+nky1 130 continue cu(i) = sum m0 = m0+1 140 continue go to 300 200 if(nu.lt.nx) go to 300 if(u.lt.ty(ky1) .or. u.gt.ty(nky1+1)) go to 300 c the b-splinecoefficients of g(x) = s(x,u). ier = 0 l = ky1 l1 = l+1 210 if(u.lt.ty(l1) .or. l.eq.nky1) go to 220 l = l1 l1 = l+1 go to 210 220 call fpbspl(ty,ny,ky,u,l,h) m0 = l-ky do 240 i=1,nkx1 m = m0 sum = 0. do 230 j=1,ky1 sum = sum+h(j)*c(m) m = m+1 230 continue cu(i) = sum m0 = m0+nky1 240 continue 300 return end spd-1.3.0/fitpack/fpspgr.f0000644000175000017500000003530611633462460012327 00000000000000 subroutine fpspgr(iopt,ider,u,mu,v,mv,r,mr,r0,r1,s,nuest,nvest, * tol,maxit,nc,nu,tu,nv,tv,c,fp,fp0,fpold,reducu,reducv,fpintu, * fpintv,dr,step,lastdi,nplusu,nplusv,lastu0,lastu1,nru,nrv, * nrdatu,nrdatv,wrk,lwrk,ier) c .. c ..scalar arguments.. integer mu,mv,mr,nuest,nvest,maxit,nc,nu,nv,lastdi,nplusu,nplusv, * lastu0,lastu1,lwrk,ier real r0,r1,s,tol,fp,fp0,fpold,reducu,reducv c ..array arguments.. integer iopt(3),ider(4),nrdatu(nuest),nrdatv(nvest),nru(mu), * nrv(mv) real u(mu),v(mv),r(mr),tu(nuest),tv(nvest),c(nc),fpintu(nuest), * fpintv(nvest),dr(6),wrk(lwrk),step(2) c ..local scalars.. real acc,fpms,f1,f2,f3,p,per,pi,p1,p2,p3,vb,ve,rmax,rmin,rn,one, * con1,con4,con9 integer i,ich1,ich3,ifbu,ifbv,ifsu,ifsv,istart,iter,i1,i2,j,ju, * ktu,l,l1,l2,l3,l4,mpm,mumin,mu0,mu1,nn,nplu,nplv,npl1,nrintu, * nrintv,nue,numax,nve,nvmax c ..local arrays.. integer idd(4) real drr(6) c ..function references.. real abs,atan2,fprati integer max0,min0 c ..subroutine references.. c fpknot,fpopsp c .. c set constants one = 1 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 c initialization ifsu = 0 ifsv = 0 ifbu = 0 ifbv = 0 p = -one mumin = 4 if(ider(1).ge.0) mumin = mumin-1 if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1 if(ider(3).ge.0) mumin = mumin-1 if(iopt(3).eq.1 .and. ider(4).eq.1) mumin = mumin-1 if(mumin.eq.0) mumin = 1 pi = atan2(0.,-one) per = pi+pi vb = v(1) ve = vb+per cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position. c c **************************************************************** c c given a set of knots we compute the least-squares spline sinf(u,v) c c and the corresponding sum of squared residuals fp = f(p=inf). c c if iopt(1)=-1 sinf(u,v) is the requested approximation. c c if iopt(1)>=0 we check whether we can accept the knots: c c if fp <= s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares spline until finally fp <= s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots in the u-direction equals nu=numax=mu+6+iopt(2)+iopt(3) c c and in the v-direction nv=nvmax=mv+7. c c if s>0 and c c iopt(1)=0 we first compute the least-squares polynomial,i.e. a c c spline without interior knots : nu=8 ; nv=8. c c iopt(1)=1 we start with the set of knots found at the last call c c of the routine, except for the case that s > fp0; then we c c compute the least-squares polynomial directly. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(iopt(1).lt.0) go to 120 c acc denotes the absolute tolerance for the root of f(p)=s. acc = tol*s c numax and nvmax denote the number of knots needed for interpolation. numax = mu+6+iopt(2)+iopt(3) nvmax = mv+7 nue = min0(numax,nuest) nve = min0(nvmax,nvest) if(s.gt.0.) go to 100 c if s = 0, s(u,v) is an interpolating spline. nu = numax nv = nvmax c test whether the required storage space exceeds the available one. if(nu.gt.nuest .or. nv.gt.nvest) go to 420 c find the position of the knots in the v-direction. do 10 l=1,mv tv(l+3) = v(l) 10 continue tv(mv+4) = ve l1 = mv-2 l2 = mv+5 do 20 i=1,3 tv(i) = v(l1)-per tv(l2) = v(i+1)+per l1 = l1+1 l2 = l2+1 20 continue c if not all the derivative values g(i,j) are given, we will first c estimate these values by computing a least-squares spline idd(1) = ider(1) if(idd(1).eq.0) idd(1) = 1 if(idd(1).gt.0) dr(1) = r0 idd(2) = ider(2) idd(3) = ider(3) if(idd(3).eq.0) idd(3) = 1 if(idd(3).gt.0) dr(4) = r1 idd(4) = ider(4) if(ider(1).lt.0 .or. ider(3).lt.0) go to 30 if(iopt(2).ne.0 .and. ider(2).eq.0) go to 30 if(iopt(3).eq.0 .or. ider(4).ne.0) go to 70 c we set up the knots in the u-direction for computing the least-squares c spline. 30 i1 = 3 i2 = mu-2 nu = 4 do 40 i=1,mu if(i1.gt.i2) go to 50 nu = nu+1 tu(nu) = u(i1) i1 = i1+2 40 continue 50 do 60 i=1,4 tu(i) = 0. nu = nu+1 tu(nu) = pi 60 continue c we compute the least-squares spline for estimating the derivatives. call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt,idd, * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, * wrk,lwrk) ifsu = 0 c if all the derivatives at the origin are known, we compute the c interpolating spline. c we set up the knots in the u-direction, needed for interpolation. 70 nn = numax-8 if(nn.eq.0) go to 95 ju = 2-iopt(2) do 80 l=1,nn tu(l+4) = u(ju) ju = ju+1 80 continue nu = numax l = nu do 90 i=1,4 tu(i) = 0. tu(l) = pi l = l-1 90 continue c we compute the interpolating spline. 95 call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt,idd, * tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru,nrv, * wrk,lwrk) go to 430 c if s>0 our initial choice of knots depends on the value of iopt(1). 100 ier = 0 if(iopt(1).eq.0) go to 115 step(1) = -step(1) step(2) = -step(2) if(fp0.le.s) go to 115 c if iopt(1)=1 and fp0 > s we start computing the least-squares spline c according to the set of knots found at the last call of the routine. c we determine the number of grid coordinates u(i) inside each knot c interval (tu(l),tu(l+1)). l = 5 j = 1 nrdatu(1) = 0 mu0 = 2-iopt(2) mu1 = mu-1+iopt(3) do 105 i=mu0,mu1 nrdatu(j) = nrdatu(j)+1 if(u(i).lt.tu(l)) go to 105 nrdatu(j) = nrdatu(j)-1 l = l+1 j = j+1 nrdatu(j) = 0 105 continue c we determine the number of grid coordinates v(i) inside each knot c interval (tv(l),tv(l+1)). l = 5 j = 1 nrdatv(1) = 0 do 110 i=2,mv nrdatv(j) = nrdatv(j)+1 if(v(i).lt.tv(l)) go to 110 nrdatv(j) = nrdatv(j)-1 l = l+1 j = j+1 nrdatv(j) = 0 110 continue idd(1) = ider(1) idd(2) = ider(2) idd(3) = ider(3) idd(4) = ider(4) go to 120 c if iopt(1)=0 or iopt(1)=1 and s >= fp0,we start computing the least- c squares polynomial (which is a spline without interior knots). 115 ier = -2 idd(1) = ider(1) idd(2) = 1 idd(3) = ider(3) idd(4) = 1 nu = 8 nv = 8 nrdatu(1) = mu-2+iopt(2)+iopt(3) nrdatv(1) = mv-1 lastdi = 0 nplusu = 0 nplusv = 0 fp0 = 0. fpold = 0. reducu = 0. reducv = 0. c main loop for the different sets of knots.mpm=mu+mv is a save upper c bound for the number of trials. 120 mpm = mu+mv do 270 iter=1,mpm c find nrintu (nrintv) which is the number of knot intervals in the c u-direction (v-direction). nrintu = nu-7 nrintv = nv-7 c find the position of the additional knots which are needed for the c b-spline representation of s(u,v). i = nu do 125 j=1,4 tu(j) = 0. tu(i) = pi i = i-1 125 continue l1 = 4 l2 = l1 l3 = nv-3 l4 = l3 tv(l2) = vb tv(l3) = ve do 130 j=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tv(l2) = tv(l4)-per tv(l3) = tv(l1)+per 130 continue c find an estimate of the range of possible values for the optimal c derivatives at the origin. ktu = nrdatu(1)+2-iopt(2) if(ktu.lt.mumin) ktu = mumin if(ktu.eq.lastu0) go to 140 rmin = r0 rmax = r0 l = mv*ktu do 135 i=1,l if(r(i).lt.rmin) rmin = r(i) if(r(i).gt.rmax) rmax = r(i) 135 continue step(1) = rmax-rmin lastu0 = ktu 140 ktu = nrdatu(nrintu)+2-iopt(3) if(ktu.lt.mumin) ktu = mumin if(ktu.eq.lastu1) go to 150 rmin = r1 rmax = r1 l = mv*ktu j = mr do 145 i=1,l if(r(j).lt.rmin) rmin = r(j) if(r(j).gt.rmax) rmax = r(j) j = j-1 145 continue step(2) = rmax-rmin lastu1 = ktu c find the least-squares spline sinf(u,v). 150 call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,dr,iopt, * idd,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru, * nrv,wrk,lwrk) if(step(1).lt.0.) step(1) = -step(1) if(step(2).lt.0.) step(2) = -step(2) if(ier.eq.(-2)) fp0 = fp c test whether the least-squares spline is an acceptable solution. if(iopt(1).lt.0) go to 440 fpms = fp-s if(abs(fpms) .lt. acc) go to 440 c if f(p=inf) < s, we accept the choice of knots. if(fpms.lt.0.) go to 300 c if nu=numax and nv=nvmax, sinf(u,v) is an interpolating spline if(nu.eq.numax .and. nv.eq.nvmax) go to 430 c increase the number of knots. c if nu=nue and nv=nve we cannot further increase the number of knots c because of the storage capacity limitation. if(nu.eq.nue .and. nv.eq.nve) go to 420 if(ider(1).eq.0) fpintu(1) = fpintu(1)+(r0-dr(1))**2 if(ider(3).eq.0) fpintu(nrintu) = fpintu(nrintu)+(r1-dr(4))**2 ier = 0 c adjust the parameter reducu or reducv according to the direction c in which the last added knots were located. if(lastdi) 160,155,170 155 nplv = 3 idd(2) = ider(2) idd(4) = ider(4) fpold = fp go to 230 160 reducu = fpold-fp go to 175 170 reducv = fpold-fp c store the sum of squared residuals for the current set of knots. 175 fpold = fp c find nplu, the number of knots we should add in the u-direction. nplu = 1 if(nu.eq.8) go to 180 npl1 = nplusu*2 rn = nplusu if(reducu.gt.acc) npl1 = rn*fpms/reducu nplu = min0(nplusu*2,max0(npl1,nplusu/2,1)) c find nplv, the number of knots we should add in the v-direction. 180 nplv = 3 if(nv.eq.8) go to 190 npl1 = nplusv*2 rn = nplusv if(reducv.gt.acc) npl1 = rn*fpms/reducv nplv = min0(nplusv*2,max0(npl1,nplusv/2,1)) c test whether we are going to add knots in the u- or v-direction. 190 if(nplu-nplv) 210,200,230 200 if(lastdi.lt.0) go to 230 210 if(nu.eq.nue) go to 230 c addition in the u-direction. lastdi = -1 nplusu = nplu ifsu = 0 istart = 0 if(iopt(2).eq.0) istart = 1 do 220 l=1,nplusu c add a new knot in the u-direction call fpknot(u,mu,tu,nu,fpintu,nrdatu,nrintu,nuest,istart) c test whether we cannot further increase the number of knots in the c u-direction. if(nu.eq.nue) go to 270 220 continue go to 270 230 if(nv.eq.nve) go to 210 c addition in the v-direction. lastdi = 1 nplusv = nplv ifsv = 0 do 240 l=1,nplusv c add a new knot in the v-direction. call fpknot(v,mv,tv,nv,fpintv,nrdatv,nrintv,nvest,1) c test whether we cannot further increase the number of knots in the c v-direction. if(nv.eq.nve) go to 270 240 continue c restart the computations with the new set of knots. 270 continue c test whether the least-squares polynomial is a solution of our c approximation problem. 300 if(ier.eq.(-2)) go to 440 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline sp(u,v) c c ***************************************************** c c we have determined the number of knots and their position. we now c c compute the b-spline coefficients of the smoothing spline sp(u,v). c c this smoothing spline depends on the parameter p in such a way that c c f(p) = sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) c c is a continuous, strictly decreasing function of p. moreover the c c least-squares polynomial corresponds to p=0 and the least-squares c c spline to p=infinity. then iteratively we have to determine the c c positive value of p such that f(p)=s. the process which is proposed c c here makes use of rational interpolation. f(p) is approximated by a c c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c c are used to calculate the new value of p such that r(p)=s. c c convergence is guaranteed by taking f1 > 0 and f3 < 0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = one do 305 i=1,6 drr(i) = dr(i) 305 continue ich1 = 0 ich3 = 0 c iteration process to find the root of f(p)=s. do 350 iter = 1,maxit c find the smoothing spline sp(u,v) and the corresponding sum f(p). call fpopsp(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,r,mr,r0,r1,drr,iopt, * idd,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpintu,fpintv,nru, * nrv,wrk,lwrk) c test whether the approximation sp(u,v) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 440 c test whether the maximum allowable number of iterations has been c reached. if(iter.eq.maxit) go to 400 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 320 if((f2-f3).gt.acc) go to 310 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 + p2*con1 go to 350 310 if(f2.lt.0.) ich3 = 1 320 if(ich1.ne.0) go to 340 if((f1-f2).gt.acc) go to 330 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 350 if(p.ge.p3) p = p2*con1 + p3*con9 go to 350 c test whether the iteration process proceeds as theoretically c expected. 330 if(f2.gt.0.) ich1 = 1 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 c find the new value of p. p = fprati(p1,f1,p2,f2,p3,f3) 350 continue c error codes and messages. 400 ier = 3 go to 440 410 ier = 2 go to 440 420 ier = 1 go to 440 430 ier = -1 fp = 0. 440 return end spd-1.3.0/fitpack/fporde.f0000644000175000017500000000245011633462460012277 00000000000000 subroutine fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,index,nreg) c subroutine fporde sorts the data points (x(i),y(i)),i=1,2,...,m c according to the panel tx(l)<=x=8 c c : real array,length n, containing the b-spline coefficients. c mest : integer, specifying the dimension of array zero. c c output parameters: c zero : real array,lenth mest, containing the zeros of s(x). c m : integer,giving the number of zeros. c ier : error flag: c ier = 0: normal return. c ier = 1: the number of zeros exceeds mest. c ier =10: invalid input data (see restrictions). c c other subroutines required: fpcuro c c restrictions: c 1) n>= 8. c 2) t(4) < t(5) < ... < t(n-4) < t(n-3). c t(1) <= t(2) <= t(3) <= t(4) c t(n-3) <= t(n-2) <= t(n-1) <= t(n) c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c .. c ..scalar arguments.. integer n,mest,m,ier c ..array arguments.. real t(n),c(n),zero(mest) c ..local scalars.. integer i,j,j1,l,n4 real ah,a0,a1,a2,a3,bh,b0,b1,c1,c2,c3,c4,c5,d4,d5,h1,h2, * three,two,t1,t2,t3,t4,t5,zz logical z0,z1,z2,z3,z4,nz0,nz1,nz2,nz3,nz4 c ..local array.. real y(3) c .. c set some constants two = 0.2e+01 three = 0.3e+01 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. n4 = n-4 ier = 10 if(n.lt.8) go to 800 j = n do 10 i=1,3 if(t(i).gt.t(i+1)) go to 800 if(t(j).lt.t(j-1)) go to 800 j = j-1 10 continue do 20 i=4,n4 if(t(i).ge.t(i+1)) go to 800 20 continue c the problem considered reduces to finding the zeros of the cubic c polynomials pl(x) which define the cubic spline in each knot c interval t(l)<=x<=t(l+1). a zero of pl(x) is also a zero of s(x) on c the condition that it belongs to the knot interval. c the cubic polynomial pl(x) is determined by computing s(t(l)), c s'(t(l)),s(t(l+1)) and s'(t(l+1)). in fact we only have to compute c s(t(l+1)) and s'(t(l+1)); because of the continuity conditions of c splines and their derivatives, the value of s(t(l)) and s'(t(l)) c is already known from the foregoing knot interval. ier = 0 c evaluate some constants for the first knot interval h1 = t(4)-t(3) h2 = t(5)-t(4) t1 = t(4)-t(2) t2 = t(5)-t(3) t3 = t(6)-t(4) t4 = t(5)-t(2) t5 = t(6)-t(3) c calculate a0 = s(t(4)) and ah = s'(t(4)). c1 = c(1) c2 = c(2) c3 = c(3) c4 = (c2-c1)/t4 c5 = (c3-c2)/t5 d4 = (h2*c1+t1*c2)/t4 d5 = (t3*c2+h1*c3)/t5 a0 = (h2*d4+h1*d5)/t2 ah = three*(h2*c4+h1*c5)/t2 z1 = .true. if(ah.lt.0.) z1 = .false. nz1 = .not.z1 m = 0 c main loop for the different knot intervals. do 300 l=4,n4 c evaluate some constants for the knot interval t(l) <= x <= t(l+1). h1 = h2 h2 = t(l+2)-t(l+1) t1 = t2 t2 = t3 t3 = t(l+3)-t(l+1) t4 = t5 t5 = t(l+3)-t(l) c find a0 = s(t(l)), ah = s'(t(l)), b0 = s(t(l+1)) and bh = s'(t(l+1)). c1 = c2 c2 = c3 c3 = c(l) c4 = c5 c5 = (c3-c2)/t5 d4 = (h2*c1+t1*c2)/t4 d5 = (h1*c3+t3*c2)/t5 b0 = (h2*d4+h1*d5)/t2 bh = three*(h2*c4+h1*c5)/t2 c calculate the coefficients a0,a1,a2 and a3 of the cubic polynomial c pl(x) = ql(y) = a0+a1*y+a2*y**2+a3*y**3 ; y = (x-t(l))/(t(l+1)-t(l)). a1 = ah*h1 b1 = bh*h1 a2 = three*(b0-a0)-b1-two*a1 a3 = two*(a0-b0)+b1+a1 c test whether or not pl(x) could have a zero in the range c t(l) <= x <= t(l+1). z3 = .true. if(b1.lt.0.) z3 = .false. nz3 = .not.z3 if(a0*b0.le.0.) go to 100 z0 = .true. if(a0.lt.0.) z0 = .false. nz0 = .not.z0 z2 = .true. if(a2.lt.0.) z2 = .false. nz2 = .not.z2 z4 = .true. if(3.0*a3+a2.lt.0.) z4 = .false. nz4 = .not.z4 if(.not.((z0.and.(nz1.and.(z3.or.z2.and.nz4).or.nz2.and. * z3.and.z4).or.nz0.and.(z1.and.(nz3.or.nz2.and.z4).or.z2.and. * nz3.and.nz4))))go to 200 c find the zeros of ql(y). 100 call fpcuro(a3,a2,a1,a0,y,j) if(j.eq.0) go to 200 c find which zeros of pl(x) are zeros of s(x). do 150 i=1,j if(y(i).lt.0. .or. y(i).gt.1.0) go to 150 c test whether the number of zeros of s(x) exceeds mest. if(m.ge.mest) go to 700 m = m+1 zero(m) = t(l)+h1*y(i) 150 continue 200 a0 = b0 ah = bh z1 = z3 nz1 = nz3 300 continue c the zeros of s(x) are arranged in increasing order. if(m.lt.2) go to 800 do 400 i=2,m j = i 350 j1 = j-1 if(j1.eq.0) go to 400 if(zero(j).ge.zero(j1)) go to 400 zz = zero(j) zero(j) = zero(j1) zero(j1) = zz j = j1 go to 350 400 continue j = m m = 1 do 500 i=2,j if(zero(i).eq.zero(m)) go to 500 m = m+1 zero(m) = zero(i) 500 continue go to 800 700 ier = 1 800 return end spd-1.3.0/fitpack/fpcyt1.f0000644000175000017500000000267511633462460012237 00000000000000 subroutine fpcyt1(a,n,nn) c (l u)-decomposition of a cyclic tridiagonal matrix with the non-zero c elements stored as follows c c | a(1,2) a(1,3) a(1,1) | c | a(2,1) a(2,2) a(2,3) | c | a(3,1) a(3,2) a(3,3) | c | ............... | c | a(n-1,1) a(n-1,2) a(n-1,3) | c | a(n,3) a(n,1) a(n,2) | c c .. c ..scalar arguments.. integer n,nn c ..array arguments.. real a(nn,6) c ..local scalars.. real aa,beta,gamma,sum,teta,v,one integer i,n1,n2 c .. c set constant one = 1 n2 = n-2 beta = one/a(1,2) gamma = a(n,3) teta = a(1,1)*beta a(1,4) = beta a(1,5) = gamma a(1,6) = teta sum = gamma*teta do 10 i=2,n2 v = a(i-1,3)*beta aa = a(i,1) beta = one/(a(i,2)-aa*v) gamma = -gamma*v teta = -teta*aa*beta a(i,4) = beta a(i,5) = gamma a(i,6) = teta sum = sum+gamma*teta 10 continue n1 = n-1 v = a(n2,3)*beta aa = a(n1,1) beta = one/(a(n1,2)-aa*v) gamma = a(n,1)-gamma*v teta = (a(n1,3)-teta*aa)*beta a(n1,4) = beta a(n1,5) = gamma a(n1,6) = teta a(n,4) = one/(a(n,2)-(sum+gamma*teta)) return end spd-1.3.0/fitpack/splint.f0000644000175000017500000000366011633462461012336 00000000000000 real function splint(t,n,c,k,a,b,wrk) c function splint calculates the integral of a spline function s(x) c of degree k, which is given in its normalized b-spline representation c c calling sequence: c aint = splint(t,n,c,k,a,b,wrk) c c input parameters: c t : array,length n,which contains the position of the knots c of s(x). c n : integer, giving the total number of knots of s(x). c c : array,length n, containing the b-spline coefficients. c k : integer, giving the degree of s(x). c a,b : real values, containing the end points of the integration c interval. s(x) is considered to be identically zero outside c the interval (t(k+1),t(n-k)). c c output parameter: c aint : real, containing the integral of s(x) between a and b. c wrk : real array, length n. used as working space c on output, wrk will contain the integrals of the normalized c b-splines defined on the set of knots. c c other subroutines required: fpintb. c c references : c gaffney p.w. : the calculation of indefinite integrals of b-splines c j. inst. maths applics 17 (1976) 37-41. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. real a,b integer n,k c ..array arguments.. real t(n),c(n),wrk(n) c ..local scalars.. integer i,nk1 c .. nk1 = n-k-1 c calculate the integrals wrk(i) of the normalized b-splines c ni,k+1(x), i=1,2,...nk1. call fpintb(t,n,wrk,nk1,a,b) c calculate the integral of s(x). splint = 0. do 10 i=1,nk1 splint = splint+c(i)*wrk(i) 10 continue return end spd-1.3.0/fitpack/fppocu.f0000644000175000017500000000346411633462460012322 00000000000000 subroutine fppocu(idim,k,a,b,ib,db,nb,ie,de,ne,cp,np) c subroutine fppocu finds a idim-dimensional polynomial curve p(u) = c (p1(u),p2(u),...,pidim(u)) of degree k, satisfying certain derivative c constraints at the end points a and b, i.e. c (l) c if ib > 0 : pj (a) = db(idim*l+j), l=0,1,...,ib-1 c (l) c if ie > 0 : pj (b) = de(idim*l+j), l=0,1,...,ie-1 c c the polynomial curve is returned in its b-spline representation c ( coefficients cp(j), j=1,2,...,np ) c .. c ..scalar arguments.. integer idim,k,ib,nb,ie,ne,np real a,b c ..array arguments.. real db(nb),de(ne),cp(np) c ..local scalars.. real ab,aki integer i,id,j,jj,l,ll,k1,k2 c ..local array.. real work(6,6) c .. k1 = k+1 k2 = 2*k1 ab = b-a do 110 id=1,idim do 10 j=1,k1 work(j,1) = 0. 10 continue if(ib.eq.0) go to 50 l = id do 20 i=1,ib work(1,i) = db(l) l = l+idim 20 continue if(ib.eq.1) go to 50 ll = ib do 40 j=2,ib ll = ll-1 do 30 i=1,ll aki = k1-i work(j,i) = ab*work(j-1,i+1)/aki + work(j-1,i) 30 continue 40 continue 50 if(ie.eq.0) go to 90 l = id j = k1 do 60 i=1,ie work(j,i) = de(l) l = l+idim j = j-1 60 continue if(ie.eq.1) go to 90 ll = ie do 80 jj=2,ie ll = ll-1 j = k1+1-jj do 70 i=1,ll aki = k1-i work(j,i) = work(j+1,i) - ab*work(j,i+1)/aki j = j-1 70 continue 80 continue 90 l = (id-1)*k2 do 100 j=1,k1 l = l+1 cp(l) = work(j,1) 100 continue 110 continue return end spd-1.3.0/fitpack/fprota.f0000644000175000017500000000047111633462460012314 00000000000000 subroutine fprota(cos,sin,a,b) c subroutine fprota applies a givens rotation to a and b. c .. c ..scalar arguments.. real cos,sin,a,b c ..local scalars.. real stor1,stor2 c .. stor1 = a stor2 = b b = cos*stor2+sin*stor1 a = cos*stor1-sin*stor2 return end spd-1.3.0/fitpack/fpbfout.f0000644000175000017500000001230011633462461012461 00000000000000 subroutine fpbfou(t,n,par,ress,resc) c subroutine fpbfou calculates the integrals c /t(n-3) c ress(j) = ! nj,4(x)*sin(par*x) dx and c t(4)/ c /t(n-3) c resc(j) = ! nj,4(x)*cos(par*x) dx , j=1,2,...n-4 c t(4)/ c where nj,4(x) denotes the cubic b-spline defined on the knots c t(j),t(j+1),...,t(j+4). c c calling sequence: c call fpbfou(t,n,par,ress,resc) c c input parameters: c t : real array,length n, containing the knots. c n : integer, containing the number of knots. c par : real, containing the value of the parameter par. c c output parameters: c ress : real array,length n, containing the integrals ress(j). c resc : real array,length n, containing the integrals resc(j). c c restrictions: c n >= 10, t(4) < t(5) < ... < t(n-4) < t(n-3). c .. c ..scalar arguments.. integer n real par c ..array arguments.. real t(n),ress(n),resc(n) c ..local scalars.. integer i,ic,ipj,is,j,jj,jp1,jp4,k,li,lj,ll,nmj,nm3,nm7 real ak,beta,con1,con2,c1,c2,delta,eps,fac,f1,f2,f3,one,quart, * sign,six,s1,s2,term c ..local arrays.. real co(5),si(5),hs(5),hc(5),rs(3),rc(3) c ..function references.. real cos,sin,abs c .. c initialization. one = 0.1e+01 six = 0.6e+01 eps = 0.1e-07 quart = 0.25e0 con1 = 0.5e-01 con2 = 0.12e+03 nm3 = n-3 nm7 = n-7 if(par.ne.0.) term = six/par beta = par*t(4) co(1) = cos(beta) si(1) = sin(beta) c calculate the integrals ress(j) and resc(j), j=1,2,3 by setting up c a divided difference table. do 30 j=1,3 jp1 = j+1 jp4 = j+4 beta = par*t(jp4) co(jp1) = cos(beta) si(jp1) = sin(beta) call fpcsin(t(4),t(jp4),par,si(1),co(1),si(jp1),co(jp1), * rs(j),rc(j)) i = 5-j hs(i) = 0. hc(i) = 0. do 10 jj=1,j ipj = i+jj hs(ipj) = rs(jj) hc(ipj) = rc(jj) 10 continue do 20 jj=1,3 if(i.lt.jj) i = jj k = 5 li = jp4 do 20 ll=i,4 lj = li-jj fac = t(li)-t(lj) hs(k) = (hs(k)-hs(k-1))/fac hc(k) = (hc(k)-hc(k-1))/fac k = k-1 li = li-1 20 continue ress(j) = hs(5)-hs(4) resc(j) = hc(5)-hc(4) 30 continue if(nm7.lt.4) go to 160 c calculate the integrals ress(j) and resc(j),j=4,5,...,n-7. do 150 j=4,nm7 jp4 = j+4 beta = par*t(jp4) co(5) = cos(beta) si(5) = sin(beta) delta = t(jp4)-t(j) c the way of computing ress(j) and resc(j) depends on the value of c beta = par*(t(j+4)-t(j)). beta = delta*par if(abs(beta).le.one) go to 60 c if !beta! > 1 the integrals are calculated by setting up a divided c difference table. do 40 k=1,5 hs(k) = si(k) hc(k) = co(k) 40 continue do 50 jj=1,3 k = 5 li = jp4 do 50 ll=jj,4 lj = li-jj fac = par*(t(li)-t(lj)) hs(k) = (hs(k)-hs(k-1))/fac hc(k) = (hc(k)-hc(k-1))/fac k = k-1 li = li-1 50 continue s2 = (hs(5)-hs(4))*term c2 = (hc(5)-hc(4))*term go to 130 c if !beta! <= 1 the integrals are calculated by evaluating a series c expansion. 60 f3 = 0. do 70 i=1,4 ipj = i+j hs(i) = par*(t(ipj)-t(j)) hc(i) = hs(i) f3 = f3+hs(i) 70 continue f3 = f3*con1 c1 = quart s1 = f3 if(abs(f3).le.eps) go to 120 sign = one fac = con2 k = 5 is = 0 do 110 ic=1,20 k = k+1 ak = k fac = fac*ak f1 = 0. f3 = 0. do 80 i=1,4 f1 = f1+hc(i) f2 = f1*hs(i) hc(i) = f2 f3 = f3+f2 80 continue f3 = f3*six/fac if(is.eq.0) go to 90 is = 0 s1 = s1+f3*sign go to 100 90 sign = -sign is = 1 c1 = c1+f3*sign 100 if(abs(f3).le.eps) go to 120 110 continue 120 s2 = delta*(co(1)*s1+si(1)*c1) c2 = delta*(co(1)*c1-si(1)*s1) 130 ress(j) = s2 resc(j) = c2 do 140 i=1,4 co(i) = co(i+1) si(i) = si(i+1) 140 continue 150 continue c calculate the integrals ress(j) and resc(j),j=n-6,n-5,n-4 by setting c up a divided difference table. 160 do 190 j=1,3 nmj = nm3-j i = 5-j call fpcsin(t(nm3),t(nmj),par,si(4),co(4),si(i-1),co(i-1), * rs(j),rc(j)) hs(i) = 0. hc(i) = 0. do 170 jj=1,j ipj = i+jj hc(ipj) = rc(jj) hs(ipj) = rs(jj) 170 continue do 180 jj=1,3 if(i.lt.jj) i = jj k = 5 li = nmj do 180 ll=i,4 lj = li+jj fac = t(lj)-t(li) hs(k) = (hs(k-1)-hs(k))/fac hc(k) = (hc(k-1)-hc(k))/fac k = k-1 li = li+1 180 continue ress(nmj) = hs(4)-hs(5) resc(nmj) = hc(4)-hc(5) 190 continue return end spd-1.3.0/fitpack/fpgrre.f0000644000175000017500000002365711633462461012322 00000000000000 subroutine fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx, * ty,ny,p,c,nc,fp,fpx,fpy,mm,mynx,kx1,kx2,ky1,ky2,spx,spy,right,q, * ax,ay,bx,by,nrx,nry) c .. c ..scalar arguments.. real p,fp integer ifsx,ifsy,ifbx,ifby,mx,my,mz,kx,ky,nx,ny,nc,mm,mynx, * kx1,kx2,ky1,ky2 c ..array arguments.. real x(mx),y(my),z(mz),tx(nx),ty(ny),c(nc),spx(mx,kx1),spy(my,ky1) * ,right(mm),q(mynx),ax(nx,kx2),bx(nx,kx2),ay(ny,ky2),by(ny,ky2), * fpx(nx),fpy(ny) integer nrx(mx),nry(my) c ..local scalars.. real arg,cos,fac,pinv,piv,sin,term,one,half integer i,ibandx,ibandy,ic,iq,irot,it,iz,i1,i2,i3,j,k,k1,k2,l, * l1,l2,ncof,nk1x,nk1y,nrold,nroldx,nroldy,number,numx,numx1, * numy,numy1,n1 c ..local arrays.. real h(7) c ..subroutine references.. c fpback,fpbspl,fpgivs,fpdisc,fprota c .. c the b-spline coefficients of the smoothing spline are calculated as c the least-squares solution of the over-determined linear system of c equations (ay) c (ax)' = q where c c | (spx) | | (spy) | c (ax) = | ---------- | (ay) = | ---------- | c | (1/p) (bx) | | (1/p) (by) | c c | z ' 0 | c q = | ------ | c | 0 ' 0 | c c with c : the (ny-ky-1) x (nx-kx-1) matrix which contains the c b-spline coefficients. c z : the my x mx matrix which contains the function values. c spx,spy: the mx x (nx-kx-1) and my x (ny-ky-1) observation c matrices according to the least-squares problems in c the x- and y-direction. c bx,by : the (nx-2*kx-1) x (nx-kx-1) and (ny-2*ky-1) x (ny-ky-1) c matrices which contain the discontinuity jumps of the c derivatives of the b-splines in the x- and y-direction. one = 1 half = 0.5 nk1x = nx-kx1 nk1y = ny-ky1 if(p.gt.0.) pinv = one/p c it depends on the value of the flags ifsx,ifsy,ifbx and ifby and on c the value of p whether the matrices (spx),(spy),(bx) and (by) still c must be determined. if(ifsx.ne.0) go to 50 c calculate the non-zero elements of the matrix (spx) which is the c observation matrix according to the least-squares spline approximat- c ion problem in the x-direction. l = kx1 l1 = kx2 number = 0 do 40 it=1,mx arg = x(it) 10 if(arg.lt.tx(l1) .or. l.eq.nk1x) go to 20 l = l1 l1 = l+1 number = number+1 go to 10 20 call fpbspl(tx,nx,kx,arg,l,h) do 30 i=1,kx1 spx(it,i) = h(i) 30 continue nrx(it) = number 40 continue ifsx = 1 50 if(ifsy.ne.0) go to 100 c calculate the non-zero elements of the matrix (spy) which is the c observation matrix according to the least-squares spline approximat- c ion problem in the y-direction. l = ky1 l1 = ky2 number = 0 do 90 it=1,my arg = y(it) 60 if(arg.lt.ty(l1) .or. l.eq.nk1y) go to 70 l = l1 l1 = l+1 number = number+1 go to 60 70 call fpbspl(ty,ny,ky,arg,l,h) do 80 i=1,ky1 spy(it,i) = h(i) 80 continue nry(it) = number 90 continue ifsy = 1 100 if(p.le.0.) go to 120 c calculate the non-zero elements of the matrix (bx). if(ifbx.ne.0 .or. nx.eq.2*kx1) go to 110 call fpdisc(tx,nx,kx2,bx,nx) ifbx = 1 c calculate the non-zero elements of the matrix (by). 110 if(ifby.ne.0 .or. ny.eq.2*ky1) go to 120 call fpdisc(ty,ny,ky2,by,ny) ifby = 1 c reduce the matrix (ax) to upper triangular form (rx) using givens c rotations. apply the same transformations to the rows of matrix q c to obtain the my x (nx-kx-1) matrix g. c store matrix (rx) into (ax) and g into q. 120 l = my*nk1x c initialization. do 130 i=1,l q(i) = 0. 130 continue do 140 i=1,nk1x do 140 j=1,kx2 ax(i,j) = 0. 140 continue l = 0 nrold = 0 c ibandx denotes the bandwidth of the matrices (ax) and (rx). ibandx = kx1 do 270 it=1,mx number = nrx(it) 150 if(nrold.eq.number) go to 180 if(p.le.0.) go to 260 ibandx = kx2 c fetch a new row of matrix (bx). n1 = nrold+1 do 160 j=1,kx2 h(j) = bx(n1,j)*pinv 160 continue c find the appropriate column of q. do 170 j=1,my right(j) = 0. 170 continue irot = nrold go to 210 c fetch a new row of matrix (spx). 180 h(ibandx) = 0. do 190 j=1,kx1 h(j) = spx(it,j) 190 continue c find the appropriate column of q. do 200 j=1,my l = l+1 right(j) = z(l) 200 continue irot = number c rotate the new row of matrix (ax) into triangle. 210 do 240 i=1,ibandx irot = irot+1 piv = h(i) if(piv.eq.0.) go to 240 c calculate the parameters of the givens transformation. call fpgivs(piv,ax(irot,1),cos,sin) c apply that transformation to the rows of matrix q. iq = (irot-1)*my do 220 j=1,my iq = iq+1 call fprota(cos,sin,right(j),q(iq)) 220 continue c apply that transformation to the columns of (ax). if(i.eq.ibandx) go to 250 i2 = 1 i3 = i+1 do 230 j=i3,ibandx i2 = i2+1 call fprota(cos,sin,h(j),ax(irot,i2)) 230 continue 240 continue 250 if(nrold.eq.number) go to 270 260 nrold = nrold+1 go to 150 270 continue c reduce the matrix (ay) to upper triangular form (ry) using givens c rotations. apply the same transformations to the columns of matrix g c to obtain the (ny-ky-1) x (nx-kx-1) matrix h. c store matrix (ry) into (ay) and h into c. ncof = nk1x*nk1y c initialization. do 280 i=1,ncof c(i) = 0. 280 continue do 290 i=1,nk1y do 290 j=1,ky2 ay(i,j) = 0. 290 continue nrold = 0 c ibandy denotes the bandwidth of the matrices (ay) and (ry). ibandy = ky1 do 420 it=1,my number = nry(it) 300 if(nrold.eq.number) go to 330 if(p.le.0.) go to 410 ibandy = ky2 c fetch a new row of matrix (by). n1 = nrold+1 do 310 j=1,ky2 h(j) = by(n1,j)*pinv 310 continue c find the appropiate row of g. do 320 j=1,nk1x right(j) = 0. 320 continue irot = nrold go to 360 c fetch a new row of matrix (spy) 330 h(ibandy) = 0. do 340 j=1,ky1 h(j) = spy(it,j) 340 continue c find the appropiate row of g. l = it do 350 j=1,nk1x right(j) = q(l) l = l+my 350 continue irot = number c rotate the new row of matrix (ay) into triangle. 360 do 390 i=1,ibandy irot = irot+1 piv = h(i) if(piv.eq.0.) go to 390 c calculate the parameters of the givens transformation. call fpgivs(piv,ay(irot,1),cos,sin) c apply that transformation to the colums of matrix g. ic = irot do 370 j=1,nk1x call fprota(cos,sin,right(j),c(ic)) ic = ic+nk1y 370 continue c apply that transformation to the columns of matrix (ay). if(i.eq.ibandy) go to 400 i2 = 1 i3 = i+1 do 380 j=i3,ibandy i2 = i2+1 call fprota(cos,sin,h(j),ay(irot,i2)) 380 continue 390 continue 400 if(nrold.eq.number) go to 420 410 nrold = nrold+1 go to 300 420 continue c backward substitution to obtain the b-spline coefficients as the c solution of the linear system (ry) c (rx)' = h. c first step: solve the system (ry) (c1) = h. k = 1 do 450 i=1,nk1x call fpback(ay,c(k),nk1y,ibandy,c(k),ny) k = k+nk1y 450 continue c second step: solve the system c (rx)' = (c1). k = 0 do 480 j=1,nk1y k = k+1 l = k do 460 i=1,nk1x right(i) = c(l) l = l+nk1y 460 continue call fpback(ax,right,nk1x,ibandx,right,nx) l = k do 470 i=1,nk1x c(l) = right(i) l = l+nk1y 470 continue 480 continue c calculate the quantities c res(i,j) = (z(i,j) - s(x(i),y(j)))**2 , i=1,2,..,mx;j=1,2,..,my c fp = sumi=1,mx(sumj=1,my(res(i,j))) c fpx(r) = sum''i(sumj=1,my(res(i,j))) , r=1,2,...,nx-2*kx-1 c tx(r+kx) <= x(i) <= tx(r+kx+1) c fpy(r) = sumi=1,mx(sum''j(res(i,j))) , r=1,2,...,ny-2*ky-1 c ty(r+ky) <= y(j) <= ty(r+ky+1) fp = 0. do 490 i=1,nx fpx(i) = 0. 490 continue do 500 i=1,ny fpy(i) = 0. 500 continue nk1y = ny-ky1 iz = 0 nroldx = 0 c main loop for the different grid points. do 550 i1=1,mx numx = nrx(i1) numx1 = numx+1 nroldy = 0 do 540 i2=1,my numy = nry(i2) numy1 = numy+1 iz = iz+1 c evaluate s(x,y) at the current grid point by making the sum of the c cross products of the non-zero b-splines at (x,y), multiplied with c the appropiate b-spline coefficients. term = 0. k1 = numx*nk1y+numy do 520 l1=1,kx1 k2 = k1 fac = spx(i1,l1) do 510 l2=1,ky1 k2 = k2+1 term = term+fac*spy(i2,l2)*c(k2) 510 continue k1 = k1+nk1y 520 continue c calculate the squared residual at the current grid point. term = (z(iz)-term)**2 c adjust the different parameters. fp = fp+term fpx(numx1) = fpx(numx1)+term fpy(numy1) = fpy(numy1)+term fac = term*half if(numy.eq.nroldy) go to 530 fpy(numy1) = fpy(numy1)-fac fpy(numy) = fpy(numy)+fac 530 nroldy = numy if(numx.eq.nroldx) go to 540 fpx(numx1) = fpx(numx1)-fac fpx(numx) = fpx(numx)+fac 540 continue nroldx = numx 550 continue return end spd-1.3.0/fitpack/fourco.f0000644000175000017500000000621511633462461012321 00000000000000 subroutine fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier) c subroutine fourco calculates the integrals c /t(n-3) c ress(i) = ! s(x)*sin(alfa(i)*x) dx and c t(4)/ c /t(n-3) c resc(i) = ! s(x)*cos(alfa(i)*x) dx, i=1,...,m, c t(4)/ c where s(x) denotes a cubic spline which is given in its c b-spline representation. c c calling sequence: c call fourco(t,n,c,alfa,m,ress,resc,wrk1,wrk2,ier) c c input parameters: c t : real array,length n, containing the knots of s(x). c n : integer, containing the total number of knots. n>=10. c c : real array,length n, containing the b-spline coefficients. c alfa : real array,length m, containing the parameters alfa(i). c m : integer, specifying the number of integrals to be computed. c wrk1 : real array,length n. used as working space c wrk2 : real array,length n. used as working space c c output parameters: c ress : real array,length m, containing the integrals ress(i). c resc : real array,length m, containing the integrals resc(i). c ier : error flag: c ier=0 : normal return. c ier=10: invalid input data (see restrictions). c c restrictions: c n >= 10 c t(4) < t(5) < ... < t(n-4) < t(n-3). c t(1) <= t(2) <= t(3) <= t(4). c t(n-3) <= t(n-2) <= t(n-1) <= t(n). c c other subroutines required: fpbfou,fpcsin c c references : c dierckx p. : calculation of fouriercoefficients of discrete c functions using cubic splines. j. computational c and applied mathematics 3 (1977) 207-209. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer n,m,ier c ..array arguments.. real t(n),c(n),wrk1(n),wrk2(n),alfa(m),ress(m),resc(m) c ..local scalars.. integer i,j,n4 real rs,rc c .. n4 = n-4 c before starting computations a data check is made. in the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(n.lt.10) go to 50 j = n do 10 i=1,3 if(t(i).gt.t(i+1)) go to 50 if(t(j).lt.t(j-1)) go to 50 j = j-1 10 continue do 20 i=4,n4 if(t(i).ge.t(i+1)) go to 50 20 continue ier = 0 c main loop for the different alfa(i). do 40 i=1,m c calculate the integrals c wrk1(j) = integral(nj,4(x)*sin(alfa*x)) and c wrk2(j) = integral(nj,4(x)*cos(alfa*x)), j=1,2,...,n-4, c where nj,4(x) denotes the normalised cubic b-spline defined on the c knots t(j),t(j+1),...,t(j+4). call fpbfou(t,n,alfa(i),wrk1,wrk2) c calculate the integrals ress(i) and resc(i). rs = 0. rc = 0. do 30 j=1,n4 rs = rs+c(j)*wrk1(j) rc = rc+c(j)*wrk2(j) 30 continue ress(i) = rs resc(i) = rc 40 continue 50 return end spd-1.3.0/fitpack/Makefile.am0000644000175000017500000000163711644024471012711 00000000000000noinst_LIBRARIES = libfitpack.a libfitpack_a_SOURCES = evapol.f fpclos.f fpgrdi.f fppocu.f fpsurf.f\ fourco.f fpcoco.f fpgrpa.f fppogr.f fpsysy.f regrid.f \ fpader.f fpcons.f fpgrre.f fppola.f fptrnp.f spalde.f \ bispev.f fpadno.f fpcosp.f fpgrsp.f fprank.f fptrpe.f spgrid.f \ clocur.f fpadpo.f fpcsin.f fpinst.f fprati.f sphere.f \ cocosp.f fpback.f fpcurf.f fpintb.f fpregr.f insert.f splder.f \ concon.f fpbacp.f fpcuro.f fpknot.f fprota.f parcur.f splev.f \ concur.f fpbfout.f fpcyt1.f fpopdi.f fprppo.f parder.f splint.f \ cualde.f fpbisp.f fpcyt2.f fpopsp.f fprpsp.f parsur.f sproot.f \ curev.f fpbspl.f fpdeno.f fporde.f fpseno.f percur.f surev.f \ curfit.f fpchec.f fpdisc.f fppara.f fpspgr.f pogrid.f surfit.f \ dblint.f fpched.f fpfrno.f fppasu.f fpsphe.f polar.f \ fpchep.f fpgivs.f fpperi.f fpsuev.f profil.fspd-1.3.0/fitpack/fpperi.f0000644000175000017500000005007711633462460012315 00000000000000 subroutine fpperi(iopt,x,y,w,m,k,s,nest,tol,maxit,k1,k2,n,t,c, * fp,fpint,z,a1,a2,b,g1,g2,q,nrdata,ier) c .. c ..scalar arguments.. real s,tol,fp integer iopt,m,k,nest,maxit,k1,k2,n,ier c ..array arguments.. real x(m),y(m),w(m),t(nest),c(nest),fpint(nest),z(nest), * a1(nest,k1),a2(nest,k),b(nest,k2),g1(nest,k2),g2(nest,k1), * q(m,k1) integer nrdata(nest) c ..local scalars.. real acc,cos,c1,d1,fpart,fpms,fpold,fp0,f1,f2,f3,p,per,pinv,piv, * p1,p2,p3,sin,store,term,wi,xi,yi,rn,one,con1,con4,con9,half integer i,ich1,ich3,ij,ik,it,iter,i1,i2,i3,j,jk,jper,j1,j2,kk, * kk1,k3,l,l0,l1,l5,mm,m1,new,nk1,nk2,nmax,nmin,nplus,npl1, * nrint,n10,n11,n7,n8 c ..local arrays.. real h(6),h1(7),h2(6) c ..function references.. real abs,fprati integer max0,min0 c ..subroutine references.. c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota c .. c set constants one = 0.1e+01 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 half = 0.5e0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position c c ************************************************************** c c given a set of knots we compute the least-squares periodic spline c c sinf(x). if the sum f(p=inf) <= s we accept the choice of knots. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots equals nmax = m+2*k. c c if s > 0 and c c iopt=0 we first compute the least-squares polynomial of c c degree k; n = nmin = 2*k+2. since s(x) must be periodic we c c find that s(x) is a constant function. c c iopt=1 we start with the set of knots found at the last c c call of the routine, except for the case that s > fp0; then c c we compute directly the least-squares periodic polynomial. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc m1 = m-1 kk = k kk1 = k1 k3 = 3*k+1 nmin = 2*k1 c determine the length of the period of s(x). per = x(m)-x(1) if(iopt.lt.0) go to 50 c calculation of acc, the absolute tolerance for the root of f(p)=s. acc = tol*s c determine nmax, the number of knots for periodic spline interpolation nmax = m+2*k if(s.gt.0. .or. nmax.eq.nmin) go to 30 c if s=0, s(x) is an interpolating spline. n = nmax c test whether the required storage space exceeds the available one. if(n.gt.nest) go to 620 c find the position of the interior knots in case of interpolation. 5 if((k/2)*2 .eq. k) go to 20 do 10 i=2,m1 j = i+k t(j) = x(i) 10 continue if(s.gt.0.) go to 50 kk = k-1 kk1 = k if(kk.gt.0) go to 50 t(1) = t(m)-per t(2) = x(1) t(m+1) = x(m) t(m+2) = t(3)+per do 15 i=1,m1 c(i) = y(i) 15 continue c(m) = c(1) fp = 0. fpint(n) = fp0 fpint(n-1) = 0. nrdata(n) = 0 go to 630 20 do 25 i=2,m1 j = i+k t(j) = (x(i)+x(i-1))*half 25 continue go to 50 c if s > 0 our initial choice depends on the value of iopt. c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares c periodic polynomial. (i.e. a constant function). c if iopt=1 and fp0>s we start computing the least-squares periodic c spline according the set of knots found at the last call of the c routine. 30 if(iopt.eq.0) go to 35 if(n.eq.nmin) go to 35 fp0 = fpint(n) fpold = fpint(n-1) nplus = nrdata(n) if(fp0.gt.s) go to 50 c the case that s(x) is a constant function is treated separetely. c find the least-squares constant c1 and compute fp0 at the same time. 35 fp0 = 0. d1 = 0. c1 = 0. do 40 it=1,m1 wi = w(it) yi = y(it)*wi call fpgivs(wi,d1,cos,sin) call fprota(cos,sin,yi,c1) fp0 = fp0+yi**2 40 continue c1 = c1/d1 c test whether that constant function is a solution of our problem. fpms = fp0-s if(fpms.lt.acc .or. nmax.eq.nmin) go to 640 fpold = fp0 c test whether the required storage space exceeds the available one. if(nmin.ge.nest) go to 620 c start computing the least-squares periodic spline with one c interior knot. nplus = 1 n = nmin+1 mm = (m+1)/2 t(k2) = x(mm) nrdata(1) = mm-2 nrdata(2) = m1-mm c main loop for the different sets of knots. m is a save upper c bound for the number of trials. 50 do 340 iter=1,m c find nrint, the number of knot intervals. nrint = n-nmin+1 c find the position of the additional knots which are needed for c the b-spline representation of s(x). if we take c t(k+1) = x(1), t(n-k) = x(m) c t(k+1-j) = t(n-k-j) - per, j=1,2,...k c t(n-k+j) = t(k+1+j) + per, j=1,2,...k c then s(x) is a periodic spline with period per if the b-spline c coefficients satisfy the following conditions c c(n7+j) = c(j), j=1,...k (**) with n7=n-2*k-1. t(k1) = x(1) nk1 = n-k1 nk2 = nk1+1 t(nk2) = x(m) do 60 j=1,k i1 = nk2+j i2 = nk2-j j1 = k1+j j2 = k1-j t(i1) = t(j1)+per t(j2) = t(i2)-per 60 continue c compute the b-spline coefficients c(j),j=1,...n7 of the least-squares c periodic spline sinf(x). the observation matrix a is built up row c by row while taking into account condition (**) and is reduced to c triangular form by givens transformations . c at the same time fp=f(p=inf) is computed. c the n7 x n7 triangularised upper matrix a has the form c ! a1 ' ! c a = ! ' a2 ! c ! 0 ' ! c with a2 a n7 x k matrix and a1 a n10 x n10 upper triangular c matrix of bandwith k+1 ( n10 = n7-k). c initialization. do 70 i=1,nk1 z(i) = 0. do 70 j=1,kk1 a1(i,j) = 0. 70 continue n7 = nk1-k n10 = n7-kk jper = 0 fp = 0. l = k1 do 290 it=1,m1 c fetch the current data point x(it),y(it) xi = x(it) wi = w(it) yi = y(it)*wi c search for knot interval t(l) <= xi < t(l+1). 80 if(xi.lt.t(l+1)) go to 85 l = l+1 go to 80 c evaluate the (k+1) non-zero b-splines at xi and store them in q. 85 call fpbspl(t,n,k,xi,l,h) do 90 i=1,k1 q(it,i) = h(i) h(i) = h(i)*wi 90 continue l5 = l-k1 c test whether the b-splines nj,k+1(x),j=1+n7,...nk1 are all zero at xi if(l5.lt.n10) go to 285 if(jper.ne.0) go to 160 c initialize the matrix a2. do 95 i=1,n7 do 95 j=1,kk a2(i,j) = 0. 95 continue jk = n10+1 do 110 i=1,kk ik = jk do 100 j=1,kk1 if(ik.le.0) go to 105 a2(ik,i) = a1(ik,j) ik = ik-1 100 continue 105 jk = jk+1 110 continue jper = 1 c if one of the b-splines nj,k+1(x),j=n7+1,...nk1 is not zero at xi c we take account of condition (**) for setting up the new row c of the observation matrix a. this row is stored in the arrays h1 c (the part with respect to a1) and h2 (the part with c respect to a2). 160 do 170 i=1,kk h1(i) = 0. h2(i) = 0. 170 continue h1(kk1) = 0. j = l5-n10 do 210 i=1,kk1 j = j+1 l0 = j 180 l1 = l0-kk if(l1.le.0) go to 200 if(l1.le.n10) go to 190 l0 = l1-n10 go to 180 190 h1(l1) = h(i) go to 210 200 h2(l0) = h2(l0)+h(i) 210 continue c rotate the new row of the observation matrix into triangle c by givens transformations. if(n10.le.0) go to 250 c rotation with the rows 1,2,...n10 of matrix a. do 240 j=1,n10 piv = h1(1) if(piv.ne.0.) go to 214 do 212 i=1,kk h1(i) = h1(i+1) 212 continue h1(kk1) = 0. go to 240 c calculate the parameters of the givens transformation. 214 call fpgivs(piv,a1(j,1),cos,sin) c transformation to the right hand side. call fprota(cos,sin,yi,z(j)) c transformations to the left hand side with respect to a2. do 220 i=1,kk call fprota(cos,sin,h2(i),a2(j,i)) 220 continue if(j.eq.n10) go to 250 i2 = min0(n10-j,kk) c transformations to the left hand side with respect to a1. do 230 i=1,i2 i1 = i+1 call fprota(cos,sin,h1(i1),a1(j,i1)) h1(i) = h1(i1) 230 continue h1(i1) = 0. 240 continue c rotation with the rows n10+1,...n7 of matrix a. 250 do 270 j=1,kk ij = n10+j if(ij.le.0) go to 270 piv = h2(j) if(piv.eq.0.) go to 270 c calculate the parameters of the givens transformation. call fpgivs(piv,a2(ij,j),cos,sin) c transformations to right hand side. call fprota(cos,sin,yi,z(ij)) if(j.eq.kk) go to 280 j1 = j+1 c transformations to left hand side. do 260 i=j1,kk call fprota(cos,sin,h2(i),a2(ij,i)) 260 continue 270 continue c add contribution of this row to the sum of squares of residual c right hand sides. 280 fp = fp+yi**2 go to 290 c rotation of the new row of the observation matrix into c triangle in case the b-splines nj,k+1(x),j=n7+1,...n-k-1 are all zero c at xi. 285 j = l5 do 140 i=1,kk1 j = j+1 piv = h(i) if(piv.eq.0.) go to 140 c calculate the parameters of the givens transformation. call fpgivs(piv,a1(j,1),cos,sin) c transformations to right hand side. call fprota(cos,sin,yi,z(j)) if(i.eq.kk1) go to 150 i2 = 1 i3 = i+1 c transformations to left hand side. do 130 i1=i3,kk1 i2 = i2+1 call fprota(cos,sin,h(i1),a1(j,i2)) 130 continue 140 continue c add contribution of this row to the sum of squares of residual c right hand sides. 150 fp = fp+yi**2 290 continue fpint(n) = fp0 fpint(n-1) = fpold nrdata(n) = nplus c backward substitution to obtain the b-spline coefficients c(j),j=1,.n call fpbacp(a1,a2,z,n7,kk,c,kk1,nest) c calculate from condition (**) the coefficients c(j+n7),j=1,2,...k. do 295 i=1,k j = i+n7 c(j) = c(i) 295 continue if(iopt.lt.0) go to 660 c test whether the approximation sinf(x) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 660 c if f(p=inf) < s accept the choice of knots. if(fpms.lt.0.) go to 350 c if n=nmax, sinf(x) is an interpolating spline. if(n.eq.nmax) go to 630 c increase the number of knots. c if n=nest we cannot increase the number of knots because of the c storage capacity limitation. if(n.eq.nest) go to 620 c determine the number of knots nplus we are going to add. npl1 = nplus*2 rn = nplus if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) nplus = min0(nplus*2,max0(npl1,nplus/2,1)) fpold = fp c compute the sum(wi*(yi-s(xi))**2) for each knot interval c t(j+k) <= xi <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. fpart = 0. i = 1 l = k1 do 320 it=1,m1 if(x(it).lt.t(l)) go to 300 new = 1 l = l+1 300 term = 0. l0 = l-k2 do 310 j=1,k1 l0 = l0+1 term = term+c(l0)*q(it,j) 310 continue term = (w(it)*(term-y(it)))**2 fpart = fpart+term if(new.eq.0) go to 320 if(l.gt.k2) go to 315 fpint(nrint) = term new = 0 go to 320 315 store = term*half fpint(i) = fpart-store i = i+1 fpart = store new = 0 320 continue fpint(nrint) = fpint(nrint)+fpart do 330 l=1,nplus c add a new knot call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1) c if n=nmax we locate the knots as for interpolation. if(n.eq.nmax) go to 5 c test whether we cannot further increase the number of knots. if(n.eq.nest) go to 340 330 continue c restart the computations with the new set of knots. 340 continue cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing periodic spline sp(x). c c ************************************************************* c c we have determined the number of knots and their position. c c we now compute the b-spline coefficients of the smoothing spline c c sp(x). the observation matrix a is extended by the rows of matrix c c b expressing that the kth derivative discontinuities of sp(x) at c c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c c ponding weights of these additional rows are set to 1/sqrt(p). c c iteratively we then have to determine the value of p such that c c f(p)=sum(w(i)*(y(i)-sp(x(i)))**2) be = s. we already know that c c the least-squares constant function corresponds to p=0, and that c c the least-squares periodic spline corresponds to p=infinity. the c c iteration process which is proposed here, makes use of rational c c interpolation. since f(p) is a convex and strictly decreasing c c function of p, it can be approximated by a rational function c c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c c to calculate the new value of p such that r(p)=s. convergence is c c guaranteed by taking f1>0 and f3<0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c evaluate the discontinuity jump of the kth derivative of the c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. 350 call fpdisc(t,n,k2,b,nest) c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms n11 = n10-1 n8 = n7-1 p = 0. l = n7 do 352 i=1,k j = k+1-i p = p+a2(l,j) l = l-1 if(l.eq.0) go to 356 352 continue do 354 i=1,n10 p = p+a1(i,1) 354 continue 356 rn = n7 p = rn/p ich1 = 0 ich3 = 0 c iteration process to find the root of f(p) = s. do 595 iter=1,maxit c form the matrix g as the matrix a extended by the rows of matrix b. c the rows of matrix b with weight 1/p are rotated into c the triangularised observation matrix a. c after triangularisation our n7 x n7 matrix g takes the form c ! g1 ' ! c g = ! ' g2 ! c ! 0 ' ! c with g2 a n7 x (k+1) matrix and g1 a n11 x n11 upper triangular c matrix of bandwidth k+2. ( n11 = n7-k-1) pinv = one/p c store matrix a into g do 360 i=1,n7 c(i) = z(i) g1(i,k1) = a1(i,k1) g1(i,k2) = 0. g2(i,1) = 0. do 360 j=1,k g1(i,j) = a1(i,j) g2(i,j+1) = a2(i,j) 360 continue l = n10 do 370 j=1,k1 if(l.le.0) go to 375 g2(l,1) = a1(l,j) l = l-1 370 continue 375 do 540 it=1,n8 c fetch a new row of matrix b and store it in the arrays h1 (the part c with respect to g1) and h2 (the part with respect to g2). yi = 0. do 380 i=1,k1 h1(i) = 0. h2(i) = 0. 380 continue h1(k2) = 0. if(it.gt.n11) go to 420 l = it l0 = it do 390 j=1,k2 if(l0.eq.n10) go to 400 h1(j) = b(it,j)*pinv l0 = l0+1 390 continue go to 470 400 l0 = 1 do 410 l1=j,k2 h2(l0) = b(it,l1)*pinv l0 = l0+1 410 continue go to 470 420 l = 1 i = it-n10 do 460 j=1,k2 i = i+1 l0 = i 430 l1 = l0-k1 if(l1.le.0) go to 450 if(l1.le.n11) go to 440 l0 = l1-n11 go to 430 440 h1(l1) = b(it,j)*pinv go to 460 450 h2(l0) = h2(l0)+b(it,j)*pinv 460 continue if(n11.le.0) go to 510 c rotate this row into triangle by givens transformations without c square roots. c rotation with the rows l,l+1,...n11. 470 do 500 j=l,n11 piv = h1(1) c calculate the parameters of the givens transformation. call fpgivs(piv,g1(j,1),cos,sin) c transformation to right hand side. call fprota(cos,sin,yi,c(j)) c transformation to the left hand side with respect to g2. do 480 i=1,k1 call fprota(cos,sin,h2(i),g2(j,i)) 480 continue if(j.eq.n11) go to 510 i2 = min0(n11-j,k1) c transformation to the left hand side with respect to g1. do 490 i=1,i2 i1 = i+1 call fprota(cos,sin,h1(i1),g1(j,i1)) h1(i) = h1(i1) 490 continue h1(i1) = 0. 500 continue c rotation with the rows n11+1,...n7 510 do 530 j=1,k1 ij = n11+j if(ij.le.0) go to 530 piv = h2(j) c calculate the parameters of the givens transformation call fpgivs(piv,g2(ij,j),cos,sin) c transformation to the right hand side. call fprota(cos,sin,yi,c(ij)) if(j.eq.k1) go to 540 j1 = j+1 c transformation to the left hand side. do 520 i=j1,k1 call fprota(cos,sin,h2(i),g2(ij,i)) 520 continue 530 continue 540 continue c backward substitution to obtain the b-spline coefficients c c(j),j=1,2,...n7 of sp(x). call fpbacp(g1,g2,c,n7,k1,c,k2,nest) c calculate from condition (**) the b-spline coefficients c(n7+j),j=1,. do 545 i=1,k j = i+n7 c(j) = c(i) 545 continue c computation of f(p). fp = 0. l = k1 do 570 it=1,m1 if(x(it).lt.t(l)) go to 550 l = l+1 550 l0 = l-k2 term = 0. do 560 j=1,k1 l0 = l0+1 term = term+c(l0)*q(it,j) 560 continue fp = fp+(w(it)*(term-y(it)))**2 570 continue c test whether the approximation sp(x) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 660 c test whether the maximal number of iterations is reached. if(iter.eq.maxit) go to 600 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 580 if((f2-f3) .gt. acc) go to 575 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 +p2*con1 go to 595 575 if(f2.lt.0.) ich3 = 1 580 if(ich1.ne.0) go to 590 if((f1-f2) .gt. acc) go to 585 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 595 if(p.ge.p3) p = p2*con1 +p3*con9 go to 595 585 if(f2.gt.0.) ich1 = 1 c test whether the iteration process proceeds as theoretically c expected. 590 if(f2.ge.f1 .or. f2.le.f3) go to 610 c find the new value for p. p = fprati(p1,f1,p2,f2,p3,f3) 595 continue c error codes and messages. 600 ier = 3 go to 660 610 ier = 2 go to 660 620 ier = 1 go to 660 630 ier = -1 go to 660 640 ier = -2 c the least-squares constant function c1 is a solution of our problem. c a constant function is a spline of degree k with all b-spline c coefficients equal to that constant c1. do 650 i=1,k1 rn = k1-i t(i) = x(1)-rn*per c(i) = c1 j = i+k1 rn = i-1 t(j) = x(m)+rn*per 650 continue n = nmin fp = fp0 fpint(n) = fp0 fpint(n-1) = 0. nrdata(n) = 0 660 return end spd-1.3.0/fitpack/fpregr.f0000644000175000017500000003110111633462461012301 00000000000000 subroutine fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s, * nxest,nyest,tol,maxit,nc,nx,tx,ny,ty,c,fp,fp0,fpold,reducx, * reducy,fpintx,fpinty,lastdi,nplusx,nplusy,nrx,nry,nrdatx,nrdaty, * wrk,lwrk,ier) c .. c ..scalar arguments.. real xb,xe,yb,ye,s,tol,fp,fp0,fpold,reducx,reducy integer iopt,mx,my,mz,kx,ky,nxest,nyest,maxit,nc,nx,ny,lastdi, * nplusx,nplusy,lwrk,ier c ..array arguments.. real x(mx),y(my),z(mz),tx(nxest),ty(nyest),c(nc),fpintx(nxest), * fpinty(nyest),wrk(lwrk) integer nrdatx(nxest),nrdaty(nyest),nrx(mx),nry(my) c ..local scalars real acc,fpms,f1,f2,f3,p,p1,p2,p3,rn,one,half,con1,con9,con4 integer i,ich1,ich3,ifbx,ifby,ifsx,ifsy,iter,j,kx1,kx2,ky1,ky2, * k3,l,lax,lay,lbx,lby,lq,lri,lsx,lsy,mk1,mm,mpm,mynx,ncof, * nk1x,nk1y,nmaxx,nmaxy,nminx,nminy,nplx,nply,npl1,nrintx, * nrinty,nxe,nxk,nye c ..function references.. real abs,fprati integer max0,min0 c ..subroutine references.. c fpgrre,fpknot c .. c set constants one = 1 half = 0.5e0 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 c we partition the working space. kx1 = kx+1 ky1 = ky+1 kx2 = kx1+1 ky2 = ky1+1 lsx = 1 lsy = lsx+mx*kx1 lri = lsy+my*ky1 mm = max0(nxest,my) lq = lri+mm mynx = nxest*my lax = lq+mynx nxk = nxest*kx2 lbx = lax+nxk lay = lbx+nxk lby = lay+nyest*ky2 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position. c c **************************************************************** c c given a set of knots we compute the least-squares spline sinf(x,y), c c and the corresponding sum of squared residuals fp=f(p=inf). c c if iopt=-1 sinf(x,y) is the requested approximation. c c if iopt=0 or iopt=1 we check whether we can accept the knots: c c if fp <=s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares spline until finally fp<=s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots equals nmaxx = mx+kx+1 and nmaxy = my+ky+1. c c if s>0 and c c *iopt=0 we first compute the least-squares polynomial of degree c c kx in x and ky in y; nx=nminx=2*kx+2 and ny=nymin=2*ky+2. c c *iopt=1 we start with the knots found at the last call of the c c routine, except for the case that s > fp0; then we can compute c c the least-squares polynomial directly. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c determine the number of knots for polynomial approximation. nminx = 2*kx1 nminy = 2*ky1 if(iopt.lt.0) go to 120 c acc denotes the absolute tolerance for the root of f(p)=s. acc = tol*s c find nmaxx and nmaxy which denote the number of knots in x- and y- c direction in case of spline interpolation. nmaxx = mx+kx1 nmaxy = my+ky1 c find nxe and nye which denote the maximum number of knots c allowed in each direction nxe = min0(nmaxx,nxest) nye = min0(nmaxy,nyest) if(s.gt.0.) go to 100 c if s = 0, s(x,y) is an interpolating spline. nx = nmaxx ny = nmaxy c test whether the required storage space exceeds the available one. if(ny.gt.nyest .or. nx.gt.nxest) go to 420 c find the position of the interior knots in case of interpolation. c the knots in the x-direction. mk1 = mx-kx1 if(mk1.eq.0) go to 60 k3 = kx/2 i = kx1+1 j = k3+2 if(k3*2.eq.kx) go to 40 do 30 l=1,mk1 tx(i) = x(j) i = i+1 j = j+1 30 continue go to 60 40 do 50 l=1,mk1 tx(i) = (x(j)+x(j-1))*half i = i+1 j = j+1 50 continue c the knots in the y-direction. 60 mk1 = my-ky1 if(mk1.eq.0) go to 120 k3 = ky/2 i = ky1+1 j = k3+2 if(k3*2.eq.ky) go to 80 do 70 l=1,mk1 ty(i) = y(j) i = i+1 j = j+1 70 continue go to 120 80 do 90 l=1,mk1 ty(i) = (y(j)+y(j-1))*half i = i+1 j = j+1 90 continue go to 120 c if s > 0 our initial choice of knots depends on the value of iopt. 100 if(iopt.eq.0) go to 115 if(fp0.le.s) go to 115 c if iopt=1 and fp0 > s we start computing the least- squares spline c according to the set of knots found at the last call of the routine. c we determine the number of grid coordinates x(i) inside each knot c interval (tx(l),tx(l+1)). l = kx2 j = 1 nrdatx(1) = 0 mpm = mx-1 do 105 i=2,mpm nrdatx(j) = nrdatx(j)+1 if(x(i).lt.tx(l)) go to 105 nrdatx(j) = nrdatx(j)-1 l = l+1 j = j+1 nrdatx(j) = 0 105 continue c we determine the number of grid coordinates y(i) inside each knot c interval (ty(l),ty(l+1)). l = ky2 j = 1 nrdaty(1) = 0 mpm = my-1 do 110 i=2,mpm nrdaty(j) = nrdaty(j)+1 if(y(i).lt.ty(l)) go to 110 nrdaty(j) = nrdaty(j)-1 l = l+1 j = j+1 nrdaty(j) = 0 110 continue go to 120 c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares c polynomial of degree kx in x and ky in y (which is a spline without c interior knots). 115 nx = nminx ny = nminy nrdatx(1) = mx-2 nrdaty(1) = my-2 lastdi = 0 nplusx = 0 nplusy = 0 fp0 = 0. fpold = 0. reducx = 0. reducy = 0. 120 mpm = mx+my ifsx = 0 ifsy = 0 ifbx = 0 ifby = 0 p = -one c main loop for the different sets of knots.mpm=mx+my is a save upper c bound for the number of trials. do 250 iter=1,mpm if(nx.eq.nminx .and. ny.eq.nminy) ier = -2 c find nrintx (nrinty) which is the number of knot intervals in the c x-direction (y-direction). nrintx = nx-nminx+1 nrinty = ny-nminy+1 c find ncof, the number of b-spline coefficients for the current set c of knots. nk1x = nx-kx1 nk1y = ny-ky1 ncof = nk1x*nk1y c find the position of the additional knots which are needed for the c b-spline representation of s(x,y). i = nx do 130 j=1,kx1 tx(j) = xb tx(i) = xe i = i-1 130 continue i = ny do 140 j=1,ky1 ty(j) = yb ty(i) = ye i = i-1 140 continue c find the least-squares spline sinf(x,y) and calculate for each knot c interval tx(j+kx)<=x<=tx(j+kx+1) (ty(j+ky)<=y<=ty(j+ky+1)) the sum c of squared residuals fpintx(j),j=1,2,...,nx-2*kx-1 (fpinty(j),j=1,2, c ...,ny-2*ky-1) for the data points having their absciss (ordinate)- c value belonging to that interval. c fp gives the total sum of squared residuals. call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty, * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx), * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby), * nrx,nry) if(ier.eq.(-2)) fp0 = fp c test whether the least-squares spline is an acceptable solution. if(iopt.lt.0) go to 440 fpms = fp-s if(abs(fpms) .lt. acc) go to 440 c if f(p=inf) < s, we accept the choice of knots. if(fpms.lt.0.) go to 300 c if nx=nmaxx and ny=nmaxy, sinf(x,y) is an interpolating spline. if(nx.eq.nmaxx .and. ny.eq.nmaxy) go to 430 c increase the number of knots. c if nx=nxe and ny=nye we cannot further increase the number of knots c because of the storage capacity limitation. if(nx.eq.nxe .and. ny.eq.nye) go to 420 ier = 0 c adjust the parameter reducx or reducy according to the direction c in which the last added knots were located. if(lastdi) 150,170,160 150 reducx = fpold-fp go to 170 160 reducy = fpold-fp c store the sum of squared residuals for the current set of knots. 170 fpold = fp c find nplx, the number of knots we should add in the x-direction. nplx = 1 if(nx.eq.nminx) go to 180 npl1 = nplusx*2 rn = nplusx if(reducx.gt.acc) npl1 = rn*fpms/reducx nplx = min0(nplusx*2,max0(npl1,nplusx/2,1)) c find nply, the number of knots we should add in the y-direction. 180 nply = 1 if(ny.eq.nminy) go to 190 npl1 = nplusy*2 rn = nplusy if(reducy.gt.acc) npl1 = rn*fpms/reducy nply = min0(nplusy*2,max0(npl1,nplusy/2,1)) 190 if(nplx-nply) 210,200,230 200 if(lastdi.lt.0) go to 230 210 if(nx.eq.nxe) go to 230 c addition in the x-direction. lastdi = -1 nplusx = nplx ifsx = 0 do 220 l=1,nplusx c add a new knot in the x-direction call fpknot(x,mx,tx,nx,fpintx,nrdatx,nrintx,nxest,1) c test whether we cannot further increase the number of knots in the c x-direction. if(nx.eq.nxe) go to 250 220 continue go to 250 230 if(ny.eq.nye) go to 210 c addition in the y-direction. lastdi = 1 nplusy = nply ifsy = 0 do 240 l=1,nplusy c add a new knot in the y-direction. call fpknot(y,my,ty,ny,fpinty,nrdaty,nrinty,nyest,1) c test whether we cannot further increase the number of knots in the c y-direction. if(ny.eq.nye) go to 250 240 continue c restart the computations with the new set of knots. 250 continue c test whether the least-squares polynomial is a solution of our c approximation problem. 300 if(ier.eq.(-2)) go to 440 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline sp(x,y) c c ***************************************************** c c we have determined the number of knots and their position. we now c c compute the b-spline coefficients of the smoothing spline sp(x,y). c c this smoothing spline varies with the parameter p in such a way thatc c f(p) = sumi=1,mx(sumj=1,my((z(i,j)-sp(x(i),y(j)))**2) c c is a continuous, strictly decreasing function of p. moreover the c c least-squares polynomial corresponds to p=0 and the least-squares c c spline to p=infinity. iteratively we then have to determine the c c positive value of p such that f(p)=s. the process which is proposed c c here makes use of rational interpolation. f(p) is approximated by a c c rational function r(p)=(u*p+v)/(p+w); three values of p (p1,p2,p3) c c with corresponding values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s)c c are used to calculate the new value of p such that r(p)=s. c c convergence is guaranteed by taking f1 > 0 and f3 < 0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = one ich1 = 0 ich3 = 0 c iteration process to find the root of f(p)=s. do 350 iter = 1,maxit c find the smoothing spline sp(x,y) and the corresponding sum of c squared residuals fp. call fpgrre(ifsx,ifsy,ifbx,ifby,x,mx,y,my,z,mz,kx,ky,tx,nx,ty, * ny,p,c,nc,fp,fpintx,fpinty,mm,mynx,kx1,kx2,ky1,ky2,wrk(lsx), * wrk(lsy),wrk(lri),wrk(lq),wrk(lax),wrk(lay),wrk(lbx),wrk(lby), * nrx,nry) c test whether the approximation sp(x,y) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 440 c test whether the maximum allowable number of iterations has been c reached. if(iter.eq.maxit) go to 400 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 320 if((f2-f3).gt.acc) go to 310 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 + p2*con1 go to 350 310 if(f2.lt.0.) ich3 = 1 320 if(ich1.ne.0) go to 340 if((f1-f2).gt.acc) go to 330 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 350 if(p.ge.p3) p = p2*con1 + p3*con9 go to 350 c test whether the iteration process proceeds as theoretically c expected. 330 if(f2.gt.0.) ich1 = 1 340 if(f2.ge.f1 .or. f2.le.f3) go to 410 c find the new value of p. p = fprati(p1,f1,p2,f2,p3,f3) 350 continue c error codes and messages. 400 ier = 3 go to 440 410 ier = 2 go to 440 420 ier = 1 go to 440 430 ier = -1 fp = 0. 440 return end spd-1.3.0/fitpack/splev.f0000644000175000017500000000550711633462460012157 00000000000000 subroutine splev(t,n,c,k,x,y,m,ier) c subroutine splev evaluates in a number of points x(i),i=1,2,...,m c a spline s(x) of degree k, given in its b-spline representation. c c calling sequence: c call splev(t,n,c,k,x,y,m,ier) c c input parameters: c t : array,length n, which contains the position of the knots. c n : integer, giving the total number of knots of s(x). c c : array,length n, which contains the b-spline coefficients. c k : integer, giving the degree of s(x). c x : array,length m, which contains the points where s(x) must c be evaluated. c m : integer, giving the number of points where s(x) must be c evaluated. c c output parameter: c y : array,length m, giving the value of s(x) at the different c points. c ier : error flag c ier = 0 : normal return c ier =10 : invalid input data (see restrictions) c c restrictions: c m >= 1 c t(k+1) <= x(i) <= x(i+1) <= t(n-k) , i=1,2,...,m-1. c c other subroutines required: fpbspl. c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer n,k,m,ier c ..array arguments.. real t(n),c(n),x(m),y(m) c ..local scalars.. integer i,j,k1,l,ll,l1,nk1 real arg,sp,tb,te c ..local array.. real h(6) c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 if(m-1) 100,30,10 10 do 20 i=2,m if(x(i).lt.x(i-1)) go to 100 20 continue 30 ier = 0 c fetch tb and te, the boundaries of the approximation interval. k1 = k+1 nk1 = n-k1 tb = t(k1) te = t(nk1+1) l = k1 l1 = l+1 c main loop for the different points. do 80 i=1,m c fetch a new x-value arg. arg = x(i) if(arg.lt.tb) arg = tb if(arg.gt.te) arg = te c search for knot interval t(l) <= arg < t(l+1) 40 if(arg.lt.t(l1) .or. l.eq.nk1) go to 50 l = l1 l1 = l+1 go to 40 c evaluate the non-zero b-splines at arg. 50 call fpbspl(t,n,k,arg,l,h) c find the value of s(x) at x=arg. sp = 0. ll = l-k1 do 60 j=1,k1 ll = ll+1 sp = sp+c(ll)*h(j) 60 continue y(i) = sp 80 continue 100 return end spd-1.3.0/fitpack/fpinst.f0000644000175000017500000000373511633462461012333 00000000000000 subroutine fpinst(iopt,t,n,c,k,x,l,tt,nn,cc,nest) c given the b-spline representation (knots t(j),j=1,2,...,n, b-spline c coefficients c(j),j=1,2,...,n-k-1) of a spline of degree k, fpinst c calculates the b-spline representation (knots tt(j),j=1,2,...,nn, c b-spline coefficients cc(j),j=1,2,...,nn-k-1) of the same spline if c an additional knot is inserted at the point x situated in the inter- c val t(l)<=x2*k or l 0 , f(3) = 0 if iopt2 > 1 and c f(2) = 0 if iopt3> 0. c the corresponding weighted sum of squared residuals gives the upper c bound sup for the smoothing factor s. 10 sup = 0. do 20 i=1,4 f(i) = 0. do 20 j=1,4 a(i,j) = 0. 20 continue do 50 i=1,m wi = w(i) zi = z(i)*wi uu = u(i) u2 = uu*uu u3 = uu*u2 h(1) = (one-u3)*wi h(2) = u3*wi h(3) = u2*(one-uu)*wi h(4) = uu*(one-u2)*wi if(iopt3.ne.0) h(2) = 0. if(iopt2.gt.1) h(3) = 0. if(iopt2.gt.0) h(4) = 0. do 40 j=1,4 piv = h(j) if(piv.eq.0.) go to 40 call fpgivs(piv,a(j,1),co,si) call fprota(co,si,zi,f(j)) if(j.eq.4) go to 40 j1 = j+1 j2 = 1 do 30 l=j1,4 j2 = j2+1 call fprota(co,si,h(l),a(j,j2)) 30 continue 40 continue sup = sup+zi*zi 50 continue if(a(4,1).ne.0.) f(4) = f(4)/a(4,1) if(a(3,1).ne.0.) f(3) = (f(3)-a(3,2)*f(4))/a(3,1) if(a(2,1).ne.0.) f(2) = (f(2)-a(2,2)*f(3)-a(2,3)*f(4))/a(2,1) if(a(1,1).ne.0.) * f(1) = (f(1)-a(1,2)*f(2)-a(1,3)*f(3)-a(1,4)*f(4))/a(1,1) c find the b-spline representation of this least-squares polynomial c1 = f(1) c4 = f(2) c2 = f(4)/three+c1 c3 = (f(3)+two*f(4))/three+c1 nu = 8 nv = 8 do 60 i=1,4 c(i) = c1 c(i+4) = c2 c(i+8) = c3 c(i+12) = c4 tu(i) = 0. tu(i+4) = one rn = 2*i-9 tv(i) = rn*pi rn = 2*i-1 tv(i+4) = rn*pi 60 continue fp = sup c test whether the least-squares polynomial is an acceptable solution fpms = sup-s if(fpms.lt.acc) go to 960 c test whether we cannot further increase the number of knots. 70 if(nuest.lt.numin .or. nvest.lt.nvmin) go to 950 c find the initial set of interior knots of the spline in case iopt1=0. nu = numin nv = nvmin tu(5) = half nvv = nv-8 rn = nvv+1 fac = pi2/rn do 80 i=1,nvv rn = i tv(i+4) = rn*fac-pi 80 continue cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1 : computation of least-squares bicubic splines. c c ****************************************************** c c if iopt1<0 we compute the least-squares bicubic spline according c c to the given set of knots. c c if iopt1>=0 we compute least-squares bicubic splines with in- c c creasing numbers of knots until the corresponding sum f(p=inf)<=s. c c the initial set of knots then depends on the value of iopt1 c c if iopt1=0 we start with one interior knot in the u-direction c c (0.5) and 1+iopt2*(iopt2+1) in the v-direction. c c if iopt1>0 we start with the set of knots found at the last c c call of the routine. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c main loop for the different sets of knots. m is a save upper bound c for the number of trials. 90 do 570 iter=1,m c find the position of the additional knots which are needed for the c b-spline representation of s(u,v). l1 = 4 l2 = l1 l3 = nv-3 l4 = l3 tv(l2) = -pi tv(l3) = pi do 120 i=1,3 l1 = l1+1 l2 = l2-1 l3 = l3+1 l4 = l4-1 tv(l2) = tv(l4)-pi2 tv(l3) = tv(l1)+pi2 120 continue l = nu do 130 i=1,4 tu(i) = 0. tu(l) = one l = l-1 130 continue c find nrint, the total number of knot intervals and nreg, the number c of panels in which the approximation domain is subdivided by the c intersection of knots. nuu = nu-7 nvv = nv-7 nrr = nvv/2 nr1 = nrr+1 nrint = nuu+nvv nreg = nuu*nvv c arrange the data points according to the panel they belong to. call fporde(u,v,m,3,3,tu,nu,tv,nv,nummer,index,nreg) if(iopt2.eq.0) go to 195 c find the b-spline coefficients cosi of the cubic spline c approximations for cr(v)=rad(v)*cos(v) and sr(v) = rad(v)*sin(v) c if iopt2=1, and additionally also for cr(v)**2,sr(v)**2 and c 2*cr(v)*sr(v) if iopt2=2 do 140 i=1,nvv do 135 j=1,ipar cosi(j,i) = 0. 135 continue do 140 j=1,nvv a(i,j) = 0. 140 continue c the coefficients cosi are obtained from interpolation conditions c at the knots tv(i),i=4,5,...nv-4. do 175 i=1,nvv l2 = i+3 arg = tv(l2) call fpbspl(tv,nv,3,arg,l2,hv) do 145 j=1,nvv row(j) = 0. 145 continue ll = i do 150 j=1,3 if(ll.gt.nvv) ll= 1 row(ll) = row(ll)+hv(j) ll = ll+1 150 continue co = cos(arg) si = sin(arg) r = rad(arg) cs(1) = co*r cs(2) = si*r if(iopt2.eq.1) go to 155 cs(3) = cs(1)*cs(1) cs(4) = cs(2)*cs(2) cs(5) = cs(1)*cs(2) 155 do 170 j=1,nvv piv = row(j) if(piv.eq.0.) go to 170 call fpgivs(piv,a(j,1),co,si) do 160 l=1,ipar call fprota(co,si,cs(l),cosi(l,j)) 160 continue if(j.eq.nvv) go to 175 j1 = j+1 j2 = 1 do 165 l=j1,nvv j2 = j2+1 call fprota(co,si,row(l),a(j,j2)) 165 continue 170 continue 175 continue do 190 l=1,ipar do 180 j=1,nvv cs(j) = cosi(l,j) 180 continue call fpback(a,cs,nvv,nvv,cs,ncc) do 185 j=1,nvv cosi(l,j) = cs(j) 185 continue 190 continue c find ncof, the dimension of the spline and ncoff, the number c of coefficients in the standard b-spline representation. 195 nu4 = nu-4 nv4 = nv-4 ncoff = nu4*nv4 ncof = ipar1+nvv*(nu4-1-iopt2-iopt3) c find the bandwidth of the observation matrix a. iband = 4*nvv if(nuu-iopt2-iopt3.le.1) iband = ncof iband1 = iband-1 c initialize the observation matrix a. do 200 i=1,ncof f(i) = 0. do 200 j=1,iband a(i,j) = 0. 200 continue c initialize the sum of squared residuals. fp = 0. ratio = one+tu(6)/tu(5) c fetch the data points in the new order. main loop for the c different panels. do 380 num=1,nreg c fix certain constants for the current panel; jrot records the column c number of the first non-zero element in a row of the observation c matrix according to a data point of the panel. num1 = num-1 lu = num1/nvv l1 = lu+4 lv = num1-lu*nvv+1 l2 = lv+3 jrot = 0 if(lu.gt.iopt2) jrot = ipar1+(lu-iopt2-1)*nvv lu = lu+1 c test whether there are still data points in the current panel. in = index(num) 210 if(in.eq.0) go to 380 c fetch a new data point. wi = w(in) zi = z(in)*wi c evaluate for the u-direction, the 4 non-zero b-splines at u(in) call fpbspl(tu,nu,3,u(in),l1,hu) c evaluate for the v-direction, the 4 non-zero b-splines at v(in) call fpbspl(tv,nv,3,v(in),l2,hv) c store the value of these b-splines in spu and spv resp. do 220 i=1,4 spu(in,i) = hu(i) spv(in,i) = hv(i) 220 continue c initialize the new row of observation matrix. do 240 i=1,iband h(i) = 0. 240 continue c calculate the non-zero elements of the new row by making the cross c products of the non-zero b-splines in u- and v-direction and c by taking into account the conditions of the splines. do 250 i=1,nvv row(i) = 0. 250 continue c take into account the periodicity condition of the bicubic splines. ll = lv do 260 i=1,4 if(ll.gt.nvv) ll=1 row(ll) = row(ll)+hv(i) ll = ll+1 260 continue c take into account the other conditions of the splines. if(iopt2.eq.0 .or. lu.gt.iopt2+1) go to 280 do 270 l=1,ipar cs(l) = 0. do 270 i=1,nvv cs(l) = cs(l)+row(i)*cosi(l,i) 270 continue c fill in the non-zero elements of the new row. 280 j1 = 0 do 330 j =1,4 jlu = j+lu huj = hu(j) if(jlu.gt.iopt2+2) go to 320 go to (290,290,300,310),jlu 290 h(1) = huj j1 = 1 go to 330 300 h(1) = h(1)+huj h(2) = huj*cs(1) h(3) = huj*cs(2) j1 = 3 go to 330 310 h(1) = h(1)+huj h(2) = h(2)+huj*ratio*cs(1) h(3) = h(3)+huj*ratio*cs(2) h(4) = huj*cs(3) h(5) = huj*cs(4) h(6) = huj*cs(5) j1 = 6 go to 330 320 if(jlu.gt.nu4 .and. iopt3.ne.0) go to 330 do 325 i=1,nvv j1 = j1+1 h(j1) = row(i)*huj 325 continue 330 continue do 335 i=1,iband h(i) = h(i)*wi 335 continue c rotate the row into triangle by givens transformations. irot = jrot do 350 i=1,iband irot = irot+1 piv = h(i) if(piv.eq.0.) go to 350 c calculate the parameters of the givens transformation. call fpgivs(piv,a(irot,1),co,si) c apply that transformation to the right hand side. call fprota(co,si,zi,f(irot)) if(i.eq.iband) go to 360 c apply that transformation to the left hand side. i2 = 1 i3 = i+1 do 340 j=i3,iband i2 = i2+1 call fprota(co,si,h(j),a(irot,i2)) 340 continue 350 continue c add the contribution of the row to the sum of squares of residual c right hand sides. 360 fp = fp+zi**2 c find the number of the next data point in the panel. 370 in = nummer(in) go to 210 380 continue c find dmax, the maximum value for the diagonal elements in the reduced c triangle. dmax = 0. do 390 i=1,ncof if(a(i,1).le.dmax) go to 390 dmax = a(i,1) 390 continue c check whether the observation matrix is rank deficient. sigma = eps*dmax do 400 i=1,ncof if(a(i,1).le.sigma) go to 410 400 continue c backward substitution in case of full rank. call fpback(a,f,ncof,iband,c,ncc) rank = ncof do 405 i=1,ncof q(i,1) = a(i,1)/dmax 405 continue go to 430 c in case of rank deficiency, find the minimum norm solution. 410 lwest = ncof*iband+ncof+iband if(lwrk.lt.lwest) go to 925 lf = 1 lh = lf+ncof la = lh+iband do 420 i=1,ncof ff(i) = f(i) do 420 j=1,iband q(i,j) = a(i,j) 420 continue call fprank(q,ff,ncof,iband,ncc,sigma,c,sq,rank,wrk(la), * wrk(lf),wrk(lh)) do 425 i=1,ncof q(i,1) = q(i,1)/dmax 425 continue c add to the sum of squared residuals, the contribution of reducing c the rank. fp = fp+sq c find the coefficients in the standard b-spline representation of c the spline. 430 call fprppo(nu,nv,iopt2,iopt3,cosi,ratio,c,ff,ncoff) c test whether the least-squares spline is an acceptable solution. if(iopt1.lt.0) if(fp) 970,970,980 fpms = fp-s if(abs(fpms).le.acc) if(fp) 970,970,980 c if f(p=inf) < s, accept the choice of knots. if(fpms.lt.0.) go to 580 c test whether we cannot further increase the number of knots if(m.lt.ncof) go to 935 c search where to add a new knot. c find for each interval the sum of squared residuals fpint for the c data points having the coordinate belonging to that knot interval. c calculate also coord which is the same sum, weighted by the position c of the data points considered. 440 do 450 i=1,nrint fpint(i) = 0. coord(i) = 0. 450 continue do 490 num=1,nreg num1 = num-1 lu = num1/nvv l1 = lu+1 lv = num1-lu*nvv l2 = lv+1+nuu jrot = lu*nv4+lv in = index(num) 460 if(in.eq.0) go to 490 store = 0. i1 = jrot do 480 i=1,4 hui = spu(in,i) j1 = i1 do 470 j=1,4 j1 = j1+1 store = store+hui*spv(in,j)*c(j1) 470 continue i1 = i1+nv4 480 continue store = (w(in)*(z(in)-store))**2 fpint(l1) = fpint(l1)+store coord(l1) = coord(l1)+store*u(in) fpint(l2) = fpint(l2)+store coord(l2) = coord(l2)+store*v(in) in = nummer(in) go to 460 490 continue c bring together the information concerning knot panels which are c symmetric with respect to the origin. do 495 i=1,nrr l1 = nuu+i l2 = l1+nrr fpint(l1) = fpint(l1)+fpint(l2) coord(l1) = coord(l1)+coord(l2)-pi*fpint(l2) 495 continue c find the interval for which fpint is maximal on the condition that c there still can be added a knot. l1 = 1 l2 = nuu+nrr if(nuest.lt.nu+1) l1=nuu+1 if(nvest.lt.nv+2) l2=nuu c test whether we cannot further increase the number of knots. if(l1.gt.l2) go to 950 500 fpmax = 0. l = 0 do 510 i=l1,l2 if(fpmax.ge.fpint(i)) go to 510 l = i fpmax = fpint(i) 510 continue if(l.eq.0) go to 930 c calculate the position of the new knot. arg = coord(l)/fpint(l) c test in what direction the new knot is going to be added. if(l.gt.nuu) go to 530 c addition in the u-direction l4 = l+4 fpint(l) = 0. fac1 = tu(l4)-arg fac2 = arg-tu(l4-1) if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 j = nu do 520 i=l4,nu tu(j+1) = tu(j) j = j-1 520 continue tu(l4) = arg nu = nu+1 go to 570 c addition in the v-direction 530 l4 = l+4-nuu fpint(l) = 0. fac1 = tv(l4)-arg fac2 = arg-tv(l4-1) if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 500 ll = nrr+4 j = ll do 550 i=l4,ll tv(j+1) = tv(j) j = j-1 550 continue tv(l4) = arg nv = nv+2 nrr = nrr+1 do 560 i=5,ll j = i+nrr tv(j) = tv(i)+pi 560 continue c restart the computations with the new set of knots. 570 continue cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing bicubic spline. c c ****************************************************** c c we have determined the number of knots and their position. we now c c compute the coefficients of the smoothing spline sp(u,v). c c the observation matrix a is extended by the rows of a matrix, expres-c c sing that sp(u,v) must be a constant function in the variable c c v and a cubic polynomial in the variable u. the corresponding c c weights of these additional rows are set to 1/(p). iteratively c c we than have to determine the value of p such that f(p) = sum((w(i)* c c (z(i)-sp(u(i),v(i))))**2) be = s. c c we already know that the least-squares polynomial corresponds to p=0,c c and that the least-squares bicubic spline corresponds to p=infin. c c the iteration process makes use of rational interpolation. since f(p)c c is a convex and strictly decreasing function of p, it can be approx- c c imated by a rational function of the form r(p) = (u*p+v)/(p+w). c c three values of p (p1,p2,p3) with corresponding values of f(p) (f1= c c f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the new value c c of p such that r(p)=s. convergence is guaranteed by taking f1>0,f3<0.c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c evaluate the discontinuity jumps of the 3-th order derivative of c the b-splines at the knots tu(l),l=5,...,nu-4. 580 call fpdisc(tu,nu,5,bu,nuest) c evaluate the discontinuity jumps of the 3-th order derivative of c the b-splines at the knots tv(l),l=5,...,nv-4. call fpdisc(tv,nv,5,bv,nvest) c initial value for p. p1 = 0. f1 = sup-s p3 = -one f3 = fpms p = 0. do 590 i=1,ncof p = p+a(i,1) 590 continue rn = ncof p = rn/p c find the bandwidth of the extended observation matrix. iband4 = iband+ipar1 if(iband4.gt.ncof) iband4 = ncof iband3 = iband4 -1 ich1 = 0 ich3 = 0 nuu = nu4-iopt3-1 c iteration process to find the root of f(p)=s. do 920 iter=1,maxit pinv = one/p c store the triangularized observation matrix into q. do 630 i=1,ncof ff(i) = f(i) do 620 j=1,iband4 q(i,j) = 0. 620 continue do 630 j=1,iband q(i,j) = a(i,j) 630 continue c extend the observation matrix with the rows of a matrix, expressing c that for u=constant sp(u,v) must be a constant function. do 720 i=5,nv4 ii = i-4 do 635 l=1,nvv row(l) = 0. 635 continue ll = ii do 640 l=1,5 if(ll.gt.nvv) ll=1 row(ll) = row(ll)+bv(ii,l) ll = ll+1 640 continue do 720 j=1,nuu c initialize the new row. do 645 l=1,iband h(l) = 0. 645 continue c fill in the non-zero elements of the row. jrot records the column c number of the first non-zero element in the row. if(j.gt.iopt2) go to 665 if(j.eq.2) go to 655 do 650 k=1,2 cs(k) = 0. do 650 l=1,nvv cs(k) = cs(k)+cosi(k,l)*row(l) 650 continue h(1) = cs(1) h(2) = cs(2) jrot = 2 go to 675 655 do 660 k=3,5 cs(k) = 0. do 660 l=1,nvv cs(k) = cs(k)+cosi(k,l)*row(l) 660 continue h(1) = cs(1)*ratio h(2) = cs(2)*ratio h(3) = cs(3) h(4) = cs(4) h(5) = cs(5) jrot = 2 go to 675 665 do 670 l=1,nvv h(l) = row(l) 670 continue jrot = ipar1+1+(j-iopt2-1)*nvv 675 do 677 l=1,iband h(l) = h(l)*pinv 677 continue zi = 0. c rotate the new row into triangle by givens transformations. do 710 irot=jrot,ncof piv = h(1) i2 = min0(iband1,ncof-irot) if(piv.eq.0.) if(i2) 720,720,690 c calculate the parameters of the givens transformation. call fpgivs(piv,q(irot,1),co,si) c apply that givens transformation to the right hand side. call fprota(co,si,zi,ff(irot)) if(i2.eq.0) go to 720 c apply that givens transformation to the left hand side. do 680 l=1,i2 l1 = l+1 call fprota(co,si,h(l1),q(irot,l1)) 680 continue 690 do 700 l=1,i2 h(l) = h(l+1) 700 continue h(i2+1) = 0. 710 continue 720 continue c extend the observation matrix with the rows of a matrix expressing c that for v=constant. sp(u,v) must be a cubic polynomial. do 810 i=5,nu4 ii = i-4 do 810 j=1,nvv c initialize the new row do 730 l=1,iband4 h(l) = 0. 730 continue c fill in the non-zero elements of the row. jrot records the column c number of the first non-zero element in the row. j1 = 1 do 760 l=1,5 il = ii+l-1 if(il.eq.nu4 .and. iopt3.ne.0) go to 760 if(il.gt.iopt2+1) go to 750 go to (735,740,745),il 735 h(1) = bu(ii,l) j1 = j+1 go to 760 740 h(1) = h(1)+bu(ii,l) h(2) = bu(ii,l)*cosi(1,j) h(3) = bu(ii,l)*cosi(2,j) j1 = j+3 go to 760 745 h(1) = h(1)+bu(ii,l) h(2) = bu(ii,l)*cosi(1,j)*ratio h(3) = bu(ii,l)*cosi(2,j)*ratio h(4) = bu(ii,l)*cosi(3,j) h(5) = bu(ii,l)*cosi(4,j) h(6) = bu(ii,l)*cosi(5,j) j1 = j+6 go to 760 750 h(j1) = bu(ii,l) j1 = j1+nvv 760 continue do 765 l=1,iband4 h(l) = h(l)*pinv 765 continue zi = 0. jrot = 1 if(ii.gt.iopt2+1) jrot = ipar1+(ii-iopt2-2)*nvv+j c rotate the new row into triangle by givens transformations. do 800 irot=jrot,ncof piv = h(1) i2 = min0(iband3,ncof-irot) if(piv.eq.0.) if(i2) 810,810,780 c calculate the parameters of the givens transformation. call fpgivs(piv,q(irot,1),co,si) c apply that givens transformation to the right hand side. call fprota(co,si,zi,ff(irot)) if(i2.eq.0) go to 810 c apply that givens transformation to the left hand side. do 770 l=1,i2 l1 = l+1 call fprota(co,si,h(l1),q(irot,l1)) 770 continue 780 do 790 l=1,i2 h(l) = h(l+1) 790 continue h(i2+1) = 0. 800 continue 810 continue c find dmax, the maximum value for the diagonal elements in the c reduced triangle. dmax = 0. do 820 i=1,ncof if(q(i,1).le.dmax) go to 820 dmax = q(i,1) 820 continue c check whether the matrix is rank deficient. sigma = eps*dmax do 830 i=1,ncof if(q(i,1).le.sigma) go to 840 830 continue c backward substitution in case of full rank. call fpback(q,ff,ncof,iband4,c,ncc) rank = ncof go to 845 c in case of rank deficiency, find the minimum norm solution. 840 lwest = ncof*iband4+ncof+iband4 if(lwrk.lt.lwest) go to 925 lf = 1 lh = lf+ncof la = lh+iband4 call fprank(q,ff,ncof,iband4,ncc,sigma,c,sq,rank,wrk(la), * wrk(lf),wrk(lh)) 845 do 850 i=1,ncof q(i,1) = q(i,1)/dmax 850 continue c find the coefficients in the standard b-spline representation of c the polar spline. call fprppo(nu,nv,iopt2,iopt3,cosi,ratio,c,ff,ncoff) c compute f(p). fp = 0. do 890 num = 1,nreg num1 = num-1 lu = num1/nvv lv = num1-lu*nvv jrot = lu*nv4+lv in = index(num) 860 if(in.eq.0) go to 890 store = 0. i1 = jrot do 880 i=1,4 hui = spu(in,i) j1 = i1 do 870 j=1,4 j1 = j1+1 store = store+hui*spv(in,j)*c(j1) 870 continue i1 = i1+nv4 880 continue fp = fp+(w(in)*(z(in)-store))**2 in = nummer(in) go to 860 890 continue c test whether the approximation sp(u,v) is an acceptable solution fpms = fp-s if(abs(fpms).le.acc) go to 980 c test whether the maximum allowable number of iterations has been c reached. if(iter.eq.maxit) go to 940 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 900 if((f2-f3).gt.acc) go to 895 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 + p2*con1 go to 920 895 if(f2.lt.0.) ich3 = 1 900 if(ich1.ne.0) go to 910 if((f1-f2).gt.acc) go to 905 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 920 if(p.ge.p3) p = p2*con1 +p3*con9 go to 920 905 if(f2.gt.0.) ich1 = 1 c test whether the iteration process proceeds as theoretically c expected. 910 if(f2.ge.f1 .or. f2.le.f3) go to 945 c find the new value of p. p = fprati(p1,f1,p2,f2,p3,f3) 920 continue c error codes and messages. 925 ier = lwest go to 990 930 ier = 5 go to 990 935 ier = 4 go to 990 940 ier = 3 go to 990 945 ier = 2 go to 990 950 ier = 1 go to 990 960 ier = -2 go to 990 970 ier = -1 fp = 0. 980 if(ncof.ne.rank) ier = -rank 990 return end spd-1.3.0/fitpack/fpcurf.f0000644000175000017500000003110111633462460012300 00000000000000 subroutine fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2, * n,t,c,fp,fpint,z,a,b,g,q,nrdata,ier) c .. c ..scalar arguments.. real xb,xe,s,tol,fp integer iopt,m,k,nest,maxit,k1,k2,n,ier c ..array arguments.. real x(m),y(m),w(m),t(nest),c(nest),fpint(nest), * z(nest),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1) integer nrdata(nest) c ..local scalars.. real acc,con1,con4,con9,cos,half,fpart,fpms,fpold,fp0,f1,f2,f3, * one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,wi,xi,yi integer i,ich1,ich3,it,iter,i1,i2,i3,j,k3,l,l0, * mk1,new,nk1,nmax,nmin,nplus,npl1,nrint,n8 c ..local arrays.. real h(7) c ..function references real abs,fprati integer max0,min0 c ..subroutine references.. c fpback,fpbspl,fpgivs,fpdisc,fpknot,fprota c .. c set constants one = 0.1e+01 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 half = 0.5e0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position c c ************************************************************** c c given a set of knots we compute the least-squares spline sinf(x), c c and the corresponding sum of squared residuals fp=f(p=inf). c c if iopt=-1 sinf(x) is the requested approximation. c c if iopt=0 or iopt=1 we check whether we can accept the knots: c c if fp <=s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares spline until finally fp<=s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots equals nmax = m+k+1. c c if s > 0 and c c iopt=0 we first compute the least-squares polynomial of c c degree k; n = nmin = 2*k+2 c c iopt=1 we start with the set of knots found at the last c c call of the routine, except for the case that s > fp0; then c c we compute directly the least-squares polynomial of degree k. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c determine nmin, the number of knots for polynomial approximation. nmin = 2*k1 if(iopt.lt.0) go to 60 c calculation of acc, the absolute tolerance for the root of f(p)=s. acc = tol*s c determine nmax, the number of knots for spline interpolation. nmax = m+k1 if(s.gt.0.) go to 45 c if s=0, s(x) is an interpolating spline. c test whether the required storage space exceeds the available one. n = nmax if(nmax.gt.nest) go to 420 c find the position of the interior knots in case of interpolation. 10 mk1 = m-k1 if(mk1.eq.0) go to 60 k3 = k/2 i = k2 j = k3+2 if(k3*2.eq.k) go to 30 do 20 l=1,mk1 t(i) = x(j) i = i+1 j = j+1 20 continue go to 60 30 do 40 l=1,mk1 t(i) = (x(j)+x(j-1))*half i = i+1 j = j+1 40 continue go to 60 c if s>0 our initial choice of knots depends on the value of iopt. c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares c polynomial of degree k which is a spline without interior knots. c if iopt=1 and fp0>s we start computing the least squares spline c according to the set of knots found at the last call of the routine. 45 if(iopt.eq.0) go to 50 if(n.eq.nmin) go to 50 fp0 = fpint(n) fpold = fpint(n-1) nplus = nrdata(n) if(fp0.gt.s) go to 60 50 n = nmin fpold = 0. nplus = 0 nrdata(1) = m-2 c main loop for the different sets of knots. m is a save upper bound c for the number of trials. 60 do 200 iter = 1,m if(n.eq.nmin) ier = -2 c find nrint, tne number of knot intervals. nrint = n-nmin+1 c find the position of the additional knots which are needed for c the b-spline representation of s(x). nk1 = n-k1 i = n do 70 j=1,k1 t(j) = xb t(i) = xe i = i-1 70 continue c compute the b-spline coefficients of the least-squares spline c sinf(x). the observation matrix a is built up row by row and c reduced to upper triangular form by givens transformations. c at the same time fp=f(p=inf) is computed. fp = 0. c initialize the observation matrix a. do 80 i=1,nk1 z(i) = 0. do 80 j=1,k1 a(i,j) = 0. 80 continue l = k1 do 130 it=1,m c fetch the current data point x(it),y(it). xi = x(it) wi = w(it) yi = y(it)*wi c search for knot interval t(l) <= xi < t(l+1). 85 if(xi.lt.t(l+1) .or. l.eq.nk1) go to 90 l = l+1 go to 85 c evaluate the (k+1) non-zero b-splines at xi and store them in q. 90 call fpbspl(t,n,k,xi,l,h) do 95 i=1,k1 q(it,i) = h(i) h(i) = h(i)*wi 95 continue c rotate the new row of the observation matrix into triangle. j = l-k1 do 110 i=1,k1 j = j+1 piv = h(i) if(piv.eq.0.) go to 110 c calculate the parameters of the givens transformation. call fpgivs(piv,a(j,1),cos,sin) c transformations to right hand side. call fprota(cos,sin,yi,z(j)) if(i.eq.k1) go to 120 i2 = 1 i3 = i+1 do 100 i1 = i3,k1 i2 = i2+1 c transformations to left hand side. call fprota(cos,sin,h(i1),a(j,i2)) 100 continue 110 continue c add contribution of this row to the sum of squares of residual c right hand sides. 120 fp = fp+yi**2 130 continue if(ier.eq.(-2)) fp0 = fp fpint(n) = fp0 fpint(n-1) = fpold nrdata(n) = nplus c backward substitution to obtain the b-spline coefficients. call fpback(a,z,nk1,k1,c,nest) c test whether the approximation sinf(x) is an acceptable solution. if(iopt.lt.0) go to 440 fpms = fp-s if(abs(fpms).lt.acc) go to 440 c if f(p=inf) < s accept the choice of knots. if(fpms.lt.0.) go to 250 c if n = nmax, sinf(x) is an interpolating spline. if(n.eq.nmax) go to 430 c increase the number of knots. c if n=nest we cannot increase the number of knots because of c the storage capacity limitation. if(n.eq.nest) go to 420 c determine the number of knots nplus we are going to add. if(ier.eq.0) go to 140 nplus = 1 ier = 0 go to 150 140 npl1 = nplus*2 rn = nplus if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) nplus = min0(nplus*2,max0(npl1,nplus/2,1)) 150 fpold = fp c compute the sum((w(i)*(y(i)-s(x(i))))**2) for each knot interval c t(j+k) <= x(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. fpart = 0. i = 1 l = k2 new = 0 do 180 it=1,m if(x(it).lt.t(l) .or. l.gt.nk1) go to 160 new = 1 l = l+1 160 term = 0. l0 = l-k2 do 170 j=1,k1 l0 = l0+1 term = term+c(l0)*q(it,j) 170 continue term = (w(it)*(term-y(it)))**2 fpart = fpart+term if(new.eq.0) go to 180 store = term*half fpint(i) = fpart-store i = i+1 fpart = store new = 0 180 continue fpint(nrint) = fpart do 190 l=1,nplus c add a new knot. call fpknot(x,m,t,n,fpint,nrdata,nrint,nest,1) c if n=nmax we locate the knots as for interpolation. if(n.eq.nmax) go to 10 c test whether we cannot further increase the number of knots. if(n.eq.nest) go to 200 190 continue c restart the computations with the new set of knots. 200 continue c test whether the least-squares kth degree polynomial is a solution c of our approximation problem. 250 if(ier.eq.(-2)) go to 440 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline sp(x). c c *************************************************** c c we have determined the number of knots and their position. c c we now compute the b-spline coefficients of the smoothing spline c c sp(x). the observation matrix a is extended by the rows of matrix c c b expressing that the kth derivative discontinuities of sp(x) at c c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c c ponding weights of these additional rows are set to 1/p. c c iteratively we then have to determine the value of p such that c c f(p)=sum((w(i)*(y(i)-sp(x(i))))**2) be = s. we already know that c c the least-squares kth degree polynomial corresponds to p=0, and c c that the least-squares spline corresponds to p=infinity. the c c iteration process which is proposed here, makes use of rational c c interpolation. since f(p) is a convex and strictly decreasing c c function of p, it can be approximated by a rational function c c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c c to calculate the new value of p such that r(p)=s. convergence is c c guaranteed by taking f1>0 and f3<0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c evaluate the discontinuity jump of the kth derivative of the c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. call fpdisc(t,n,k2,b,nest) c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = 0. do 255 i=1,nk1 p = p+a(i,1) 255 continue rn = nk1 p = rn/p ich1 = 0 ich3 = 0 n8 = n-nmin c iteration process to find the root of f(p) = s. do 360 iter=1,maxit c the rows of matrix b with weight 1/p are rotated into the c triangularised observation matrix a which is stored in g. pinv = one/p do 260 i=1,nk1 c(i) = z(i) g(i,k2) = 0. do 260 j=1,k1 g(i,j) = a(i,j) 260 continue do 300 it=1,n8 c the row of matrix b is rotated into triangle by givens transformation do 270 i=1,k2 h(i) = b(it,i)*pinv 270 continue yi = 0. do 290 j=it,nk1 piv = h(1) c calculate the parameters of the givens transformation. call fpgivs(piv,g(j,1),cos,sin) c transformations to right hand side. call fprota(cos,sin,yi,c(j)) if(j.eq.nk1) go to 300 i2 = k1 if(j.gt.n8) i2 = nk1-j do 280 i=1,i2 c transformations to left hand side. i1 = i+1 call fprota(cos,sin,h(i1),g(j,i1)) h(i) = h(i1) 280 continue h(i2+1) = 0. 290 continue 300 continue c backward substitution to obtain the b-spline coefficients. call fpback(g,c,nk1,k2,c,nest) c computation of f(p). fp = 0. l = k2 do 330 it=1,m if(x(it).lt.t(l) .or. l.gt.nk1) go to 310 l = l+1 310 l0 = l-k2 term = 0. do 320 j=1,k1 l0 = l0+1 term = term+c(l0)*q(it,j) 320 continue fp = fp+(w(it)*(term-y(it)))**2 330 continue c test whether the approximation sp(x) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 440 c test whether the maximal number of iterations is reached. if(iter.eq.maxit) go to 400 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 340 if((f2-f3).gt.acc) go to 335 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p=p1*con9 + p2*con1 go to 360 335 if(f2.lt.0.) ich3=1 340 if(ich1.ne.0) go to 350 if((f1-f2).gt.acc) go to 345 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 360 if(p.ge.p3) p = p2*con1 + p3*con9 go to 360 345 if(f2.gt.0.) ich1=1 c test whether the iteration process proceeds as theoretically c expected. 350 if(f2.ge.f1 .or. f2.le.f3) go to 410 c find the new value for p. p = fprati(p1,f1,p2,f2,p3,f3) 360 continue c error codes and messages. 400 ier = 3 go to 440 410 ier = 2 go to 440 420 ier = 1 go to 440 430 ier = -1 440 return end spd-1.3.0/fitpack/fpcsin.f0000644000175000017500000000300611633462461012301 00000000000000 subroutine fpcsin(a,b,par,sia,coa,sib,cob,ress,resc) c fpcsin calculates the integrals ress=integral((b-x)**3*sin(par*x)) c and resc=integral((b-x)**3*cos(par*x)) over the interval (a,b), c given sia=sin(par*a),coa=cos(par*a),sib=sin(par*b) and cob=cos(par*b) c .. c ..scalar arguments.. real a,b,par,sia,coa,sib,cob,ress,resc c ..local scalars.. integer i,j real ab,ab4,ai,alfa,beta,b2,b4,eps,fac,f1,f2,one,quart,six, * three,two c ..function references.. real abs c .. one = 0.1e+01 two = 0.2e+01 three = 0.3e+01 six = 0.6e+01 quart = 0.25e+0 eps = 0.1e-09 ab = b-a ab4 = ab**4 alfa = ab*par c the way of calculating the integrals ress and resc depends on c the value of alfa = (b-a)*par. if(abs(alfa).le.one) go to 100 c integration by parts. beta = one/alfa b2 = beta**2 b4 = six*b2**2 f1 = three*b2*(one-two*b2) f2 = beta*(one-six*b2) ress = ab4*(coa*f2+sia*f1+sib*b4) resc = ab4*(coa*f1-sia*f2+cob*b4) go to 400 c ress and resc are found by evaluating a series expansion. 100 fac = quart f1 = fac f2 = 0. i = 4 do 200 j=1,5 i = i+1 ai = i fac = fac*alfa/ai f2 = f2+fac if(abs(fac).le.eps) go to 300 i = i+1 ai = i fac = -fac*alfa/ai f1 = f1+fac if(abs(fac).le.eps) go to 300 200 continue 300 ress = ab4*(coa*f2+sia*f1) resc = ab4*(coa*f1-sia*f2) 400 return end spd-1.3.0/fitpack/insert.f0000644000175000017500000000702011633462461012323 00000000000000 subroutine insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier) c subroutine insert inserts a new knot x into a spline function s(x) c of degree k and calculates the b-spline representation of s(x) with c respect to the new set of knots. in addition, if iopt.ne.0, s(x) c will be considered as a periodic spline with period per=t(n-k)-t(k+1) c satisfying the boundary constraints c t(i+n-2*k-1) = t(i)+per ,i=1,2,...,2*k+1 c c(i+n-2*k-1) = c(i) ,i=1,2,...,k c in that case, the knots and b-spline coefficients returned will also c satisfy these boundary constraints, i.e. c tt(i+nn-2*k-1) = tt(i)+per ,i=1,2,...,2*k+1 c cc(i+nn-2*k-1) = cc(i) ,i=1,2,...,k c c calling sequence: c call insert(iopt,t,n,c,k,x,tt,nn,cc,nest,ier) c c input parameters: c iopt : integer flag, specifying whether (iopt.ne.0) or not (iopt=0) c the given spline must be considered as being periodic. c t : array,length nest, which contains the position of the knots. c n : integer, giving the total number of knots of s(x). c c : array,length nest, which contains the b-spline coefficients. c k : integer, giving the degree of s(x). c x : real, which gives the location of the knot to be inserted. c nest : integer specifying the dimension of the arrays t,c,tt and cc c nest > n. c c output parameters: c tt : array,length nest, which contains the position of the knots c after insertion. c nn : integer, giving the total number of knots after insertion c cc : array,length nest, which contains the b-spline coefficients c of s(x) with respect to the new set of knots. c ier : error flag c ier = 0 : normal return c ier =10 : invalid input data (see restrictions) c c restrictions: c nest > n c t(k+1) <= x <= t(n-k) c in case of a periodic spline (iopt.ne.0) there must be c either at least k interior knots t(j) satisfying t(k+1)0) in such a way that c - if p tends to infinity, sp(u,v) becomes the least-squares spline c with given knots, satisfying the constraints. c - if p tends to zero, sp(u,v) becomes the least-squares polynomial, c satisfying the constraints. c - the function f(p)=sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2) c is continuous and strictly decreasing for p>0. c c ..scalar arguments.. integer ifsu,ifsv,ifbu,ifbv,mu,mv,mz,nu,nv,nuest,nvest, * nc,lwrk real z0,p,step,fp c ..array arguments.. integer ider(2),nru(mu),nrv(mv),iopt(3) real u(mu),v(mv),z(mz),dz(3),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv), * wrk(lwrk) c ..local scalars.. real res,sq,sqq,step1,step2,three integer i,id0,iop0,iop1,i1,j,l,laa,lau,lav1,lav2,lbb,lbu,lbv, * lcc,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number c ..local arrays.. integer nr(3) real delta(3),dzz(3),sum(3),a(6,6),g(6) c ..function references.. integer max0 c ..subroutine references.. c fpgrdi,fpsysy c .. c set constant three = 3 c we partition the working space lsu = 1 lsv = lsu+4*mu lri = lsv+4*mv mm = max0(nuest,mv+nvest) lq = lri+mm mvnu = nuest*(mv+nvest-8) lau = lq+mvnu lav1 = lau+5*nuest lav2 = lav1+6*nvest lbu = lav2+4*nvest lbv = lbu+5*nuest laa = lbv+5*nvest lbb = laa+2*mv lcc = lbb+2*nvest lcs = lcc+nvest c we calculate the smoothing spline sp(u,v) according to the input c values dz(i),i=1,2,3. iop0 = iopt(2) iop1 = iopt(3) call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), * wrk(lcc),wrk(lcs),nru,nrv) id0 = ider(1) if(id0.ne.0) go to 5 res = (z0-dz(1))**2 fp = fp+res sq = sq+res c in case all derivative values dz(i) are given (step<=0) or in case c we have spline interpolation, we accept this spline as a solution. 5 if(step.le.0. .or. sq.le.0.) return dzz(1) = dz(1) dzz(2) = dz(2) dzz(3) = dz(3) c number denotes the number of derivative values dz(i) that still must c be optimized. let us denote these parameters by g(j),j=1,...,number. number = 0 if(id0.gt.0) go to 10 number = 1 nr(1) = 1 delta(1) = step 10 if(iop0.eq.0) go to 20 if(ider(2).ne.0) go to 20 step2 = step*three/tu(5) nr(number+1) = 2 nr(number+2) = 3 delta(number+1) = step2 delta(number+2) = step2 number = number+2 20 if(number.eq.0) return c the sum of squared residuals sq is a quadratic polynomial in the c parameters g(j). we determine the unknown coefficients of this c polymomial by calculating (number+1)*(number+2)/2 different splines c according to specific values for g(j). do 30 i=1,number l = nr(i) step1 = delta(i) dzz(l) = dz(l)+step1 call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), * wrk(lcc),wrk(lcs),nru,nrv) if(id0.eq.0) sum(i) = sum(i)+(z0-dzz(1))**2 dzz(l) = dz(l)-step1 call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), * wrk(lcc),wrk(lcs),nru,nrv) if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2 a(i,i) = (sum(i)+sqq-sq-sq)/step1**2 if(a(i,i).le.0.) go to 80 g(i) = (sqq-sum(i))/(step1+step1) dzz(l) = dz(l) 30 continue if(number.eq.1) go to 60 do 50 i=2,number l1 = nr(i) step1 = delta(i) dzz(l1) = dz(l1)+step1 i1 = i-1 do 40 j=1,i1 l2 = nr(j) step2 = delta(j) dzz(l2) = dz(l2)+step2 call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), * wrk(lcc),wrk(lcs),nru,nrv) if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2 a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2) dzz(l2) = dz(l2) 40 continue dzz(l1) = dz(l1) 50 continue c the optimal values g(j) are found as the solution of the system c d (sq) / d (g(j)) = 0 , j=1,...,number. 60 call fpsysy(a,number,g) do 70 i=1,number l = nr(i) dz(l) = dz(l)+g(i) 70 continue c we determine the spline sp(u,v) according to the optimal values g(j). 80 call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu, * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1), * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb), * wrk(lcc),wrk(lcs),nru,nrv) if(id0.eq.0) fp = fp+(z0-dz(1))**2 return end spd-1.3.0/fitpack/fppara.f0000644000175000017500000003315511633462460012277 00000000000000 subroutine fppara(iopt,idim,m,u,mx,x,w,ub,ue,k,s,nest,tol,maxit, * k1,k2,n,t,nc,c,fp,fpint,z,a,b,g,q,nrdata,ier) c .. c ..scalar arguments.. real ub,ue,s,tol,fp integer iopt,idim,m,mx,k,nest,maxit,k1,k2,n,nc,ier c ..array arguments.. real u(m),x(mx),w(m),t(nest),c(nc),fpint(nest), * z(nc),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1) integer nrdata(nest) c ..local scalars.. real acc,con1,con4,con9,cos,fac,fpart,fpms,fpold,fp0,f1,f2,f3, * half,one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,ui,wi integer i,ich1,ich3,it,iter,i1,i2,i3,j,jj,j1,j2,k3,l,l0, * mk1,new,nk1,nmax,nmin,nplus,npl1,nrint,n8 c ..local arrays.. real h(7),xi(10) c ..function references real abs,fprati integer max0,min0 c ..subroutine references.. c fpback,fpbspl,fpgivs,fpdisc,fpknot,fprota c .. c set constants one = 0.1e+01 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 half = 0.5e0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position c c ************************************************************** c c given a set of knots we compute the least-squares curve sinf(u), c c and the corresponding sum of squared residuals fp=f(p=inf). c c if iopt=-1 sinf(u) is the requested curve. c c if iopt=0 or iopt=1 we check whether we can accept the knots: c c if fp <=s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares curve until finally fp<=s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots equals nmax = m+k+1. c c if s > 0 and c c iopt=0 we first compute the least-squares polynomial curve of c c degree k; n = nmin = 2*k+2 c c iopt=1 we start with the set of knots found at the last c c call of the routine, except for the case that s > fp0; then c c we compute directly the polynomial curve of degree k. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c determine nmin, the number of knots for polynomial approximation. nmin = 2*k1 if(iopt.lt.0) go to 60 c calculation of acc, the absolute tolerance for the root of f(p)=s. acc = tol*s c determine nmax, the number of knots for spline interpolation. nmax = m+k1 if(s.gt.0.) go to 45 c if s=0, s(u) is an interpolating curve. c test whether the required storage space exceeds the available one. n = nmax if(nmax.gt.nest) go to 420 c find the position of the interior knots in case of interpolation. 10 mk1 = m-k1 if(mk1.eq.0) go to 60 k3 = k/2 i = k2 j = k3+2 if(k3*2.eq.k) go to 30 do 20 l=1,mk1 t(i) = u(j) i = i+1 j = j+1 20 continue go to 60 30 do 40 l=1,mk1 t(i) = (u(j)+u(j-1))*half i = i+1 j = j+1 40 continue go to 60 c if s>0 our initial choice of knots depends on the value of iopt. c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares c polynomial curve which is a spline curve without interior knots. c if iopt=1 and fp0>s we start computing the least squares spline curve c according to the set of knots found at the last call of the routine. 45 if(iopt.eq.0) go to 50 if(n.eq.nmin) go to 50 fp0 = fpint(n) fpold = fpint(n-1) nplus = nrdata(n) if(fp0.gt.s) go to 60 50 n = nmin fpold = 0. nplus = 0 nrdata(1) = m-2 c main loop for the different sets of knots. m is a save upper bound c for the number of trials. 60 do 200 iter = 1,m if(n.eq.nmin) ier = -2 c find nrint, tne number of knot intervals. nrint = n-nmin+1 c find the position of the additional knots which are needed for c the b-spline representation of s(u). nk1 = n-k1 i = n do 70 j=1,k1 t(j) = ub t(i) = ue i = i-1 70 continue c compute the b-spline coefficients of the least-squares spline curve c sinf(u). the observation matrix a is built up row by row and c reduced to upper triangular form by givens transformations. c at the same time fp=f(p=inf) is computed. fp = 0. c initialize the b-spline coefficients and the observation matrix a. do 75 i=1,nc z(i) = 0. 75 continue do 80 i=1,nk1 do 80 j=1,k1 a(i,j) = 0. 80 continue l = k1 jj = 0 do 130 it=1,m c fetch the current data point u(it),x(it). ui = u(it) wi = w(it) do 83 j=1,idim jj = jj+1 xi(j) = x(jj)*wi 83 continue c search for knot interval t(l) <= ui < t(l+1). 85 if(ui.lt.t(l+1) .or. l.eq.nk1) go to 90 l = l+1 go to 85 c evaluate the (k+1) non-zero b-splines at ui and store them in q. 90 call fpbspl(t,n,k,ui,l,h) do 95 i=1,k1 q(it,i) = h(i) h(i) = h(i)*wi 95 continue c rotate the new row of the observation matrix into triangle. j = l-k1 do 110 i=1,k1 j = j+1 piv = h(i) if(piv.eq.0.) go to 110 c calculate the parameters of the givens transformation. call fpgivs(piv,a(j,1),cos,sin) c transformations to right hand side. j1 = j do 97 j2 =1,idim call fprota(cos,sin,xi(j2),z(j1)) j1 = j1+n 97 continue if(i.eq.k1) go to 120 i2 = 1 i3 = i+1 do 100 i1 = i3,k1 i2 = i2+1 c transformations to left hand side. call fprota(cos,sin,h(i1),a(j,i2)) 100 continue 110 continue c add contribution of this row to the sum of squares of residual c right hand sides. 120 do 125 j2=1,idim fp = fp+xi(j2)**2 125 continue 130 continue if(ier.eq.(-2)) fp0 = fp fpint(n) = fp0 fpint(n-1) = fpold nrdata(n) = nplus c backward substitution to obtain the b-spline coefficients. j1 = 1 do 135 j2=1,idim call fpback(a,z(j1),nk1,k1,c(j1),nest) j1 = j1+n 135 continue c test whether the approximation sinf(u) is an acceptable solution. if(iopt.lt.0) go to 440 fpms = fp-s if(abs(fpms).lt.acc) go to 440 c if f(p=inf) < s accept the choice of knots. if(fpms.lt.0.) go to 250 c if n = nmax, sinf(u) is an interpolating spline curve. if(n.eq.nmax) go to 430 c increase the number of knots. c if n=nest we cannot increase the number of knots because of c the storage capacity limitation. if(n.eq.nest) go to 420 c determine the number of knots nplus we are going to add. if(ier.eq.0) go to 140 nplus = 1 ier = 0 go to 150 140 npl1 = nplus*2 rn = nplus if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) nplus = min0(nplus*2,max0(npl1,nplus/2,1)) 150 fpold = fp c compute the sum of squared residuals for each knot interval c t(j+k) <= u(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. fpart = 0. i = 1 l = k2 new = 0 jj = 0 do 180 it=1,m if(u(it).lt.t(l) .or. l.gt.nk1) go to 160 new = 1 l = l+1 160 term = 0. l0 = l-k2 do 175 j2=1,idim fac = 0. j1 = l0 do 170 j=1,k1 j1 = j1+1 fac = fac+c(j1)*q(it,j) 170 continue jj = jj+1 term = term+(w(it)*(fac-x(jj)))**2 l0 = l0+n 175 continue fpart = fpart+term if(new.eq.0) go to 180 store = term*half fpint(i) = fpart-store i = i+1 fpart = store new = 0 180 continue fpint(nrint) = fpart do 190 l=1,nplus c add a new knot. call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1) c if n=nmax we locate the knots as for interpolation if(n.eq.nmax) go to 10 c test whether we cannot further increase the number of knots. if(n.eq.nest) go to 200 190 continue c restart the computations with the new set of knots. 200 continue c test whether the least-squares kth degree polynomial curve is a c solution of our approximation problem. 250 if(ier.eq.(-2)) go to 440 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline curve sp(u). c c ********************************************************** c c we have determined the number of knots and their position. c c we now compute the b-spline coefficients of the smoothing curve c c sp(u). the observation matrix a is extended by the rows of matrix c c b expressing that the kth derivative discontinuities of sp(u) at c c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c c ponding weights of these additional rows are set to 1/p. c c iteratively we then have to determine the value of p such that f(p),c c the sum of squared residuals be = s. we already know that the least c c squares kth degree polynomial curve corresponds to p=0, and that c c the least-squares spline curve corresponds to p=infinity. the c c iteration process which is proposed here, makes use of rational c c interpolation. since f(p) is a convex and strictly decreasing c c function of p, it can be approximated by a rational function c c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c c to calculate the new value of p such that r(p)=s. convergence is c c guaranteed by taking f1>0 and f3<0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c evaluate the discontinuity jump of the kth derivative of the c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. call fpdisc(t,n,k2,b,nest) c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = 0. do 252 i=1,nk1 p = p+a(i,1) 252 continue rn = nk1 p = rn/p ich1 = 0 ich3 = 0 n8 = n-nmin c iteration process to find the root of f(p) = s. do 360 iter=1,maxit c the rows of matrix b with weight 1/p are rotated into the c triangularised observation matrix a which is stored in g. pinv = one/p do 255 i=1,nc c(i) = z(i) 255 continue do 260 i=1,nk1 g(i,k2) = 0. do 260 j=1,k1 g(i,j) = a(i,j) 260 continue do 300 it=1,n8 c the row of matrix b is rotated into triangle by givens transformation do 270 i=1,k2 h(i) = b(it,i)*pinv 270 continue do 275 j=1,idim xi(j) = 0. 275 continue do 290 j=it,nk1 piv = h(1) c calculate the parameters of the givens transformation. call fpgivs(piv,g(j,1),cos,sin) c transformations to right hand side. j1 = j do 277 j2=1,idim call fprota(cos,sin,xi(j2),c(j1)) j1 = j1+n 277 continue if(j.eq.nk1) go to 300 i2 = k1 if(j.gt.n8) i2 = nk1-j do 280 i=1,i2 c transformations to left hand side. i1 = i+1 call fprota(cos,sin,h(i1),g(j,i1)) h(i) = h(i1) 280 continue h(i2+1) = 0. 290 continue 300 continue c backward substitution to obtain the b-spline coefficients. j1 = 1 do 305 j2=1,idim call fpback(g,c(j1),nk1,k2,c(j1),nest) j1 =j1+n 305 continue c computation of f(p). fp = 0. l = k2 jj = 0 do 330 it=1,m if(u(it).lt.t(l) .or. l.gt.nk1) go to 310 l = l+1 310 l0 = l-k2 term = 0. do 325 j2=1,idim fac = 0. j1 = l0 do 320 j=1,k1 j1 = j1+1 fac = fac+c(j1)*q(it,j) 320 continue jj = jj+1 term = term+(fac-x(jj))**2 l0 = l0+n 325 continue fp = fp+term*w(it)**2 330 continue c test whether the approximation sp(u) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 440 c test whether the maximal number of iterations is reached. if(iter.eq.maxit) go to 400 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 340 if((f2-f3).gt.acc) go to 335 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p=p1*con9 + p2*con1 go to 360 335 if(f2.lt.0.) ich3=1 340 if(ich1.ne.0) go to 350 if((f1-f2).gt.acc) go to 345 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 360 if(p.ge.p3) p = p2*con1 + p3*con9 go to 360 345 if(f2.gt.0.) ich1=1 c test whether the iteration process proceeds as theoretically c expected. 350 if(f2.ge.f1 .or. f2.le.f3) go to 410 c find the new value for p. p = fprati(p1,f1,p2,f2,p3,f3) 360 continue c error codes and messages. 400 ier = 3 go to 440 410 ier = 2 go to 440 420 ier = 1 go to 440 430 ier = -1 440 return end spd-1.3.0/fitpack/fpback.f0000644000175000017500000000131211633462460012242 00000000000000 subroutine fpback(a,z,n,k,c,nest) c subroutine fpback calculates the solution of the system of c equations a*c = z with a a n x n upper triangular matrix c of bandwidth k. c .. c ..scalar arguments.. integer n,k,nest c ..array arguments.. real a(nest,k),z(n),c(n) c ..local scalars.. real store integer i,i1,j,k1,l,m c .. k1 = k-1 c(n) = z(n)/a(n,1) i = n-1 if(i.eq.0) go to 30 do 20 j=2,n store = z(i) i1 = k1 if(j.le.k1) i1 = j-1 m = i do 10 l=1,i1 m = m+1 store = store-c(m)*a(i,l+1) 10 continue c(i) = store/a(i,1) i = i-1 20 continue 30 return end spd-1.3.0/fitpack/sphere.f0000644000175000017500000005044511633462461012316 00000000000000 subroutine sphere(iopt,m,teta,phi,r,w,s,ntest,npest,eps, * nt,tt,np,tp,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) c subroutine sphere determines a smooth bicubic spherical spline c approximation s(teta,phi), 0 <= teta <= pi ; 0 <= phi <= 2*pi c to a given set of data points (teta(i),phi(i),r(i)),i=1,2,...,m. c such a spline has the following specific properties c c (1) s(0,phi) = constant 0 <=phi<= 2*pi. c c (2) s(pi,phi) = constant 0 <=phi<= 2*pi c c j j c d s(teta,0) d s(teta,2*pi) c (3) ----------- = ------------ 0 <=teta<=pi, j=0,1,2 c j j c d phi d phi c c d s(0,phi) d s(0,0) d s(0,pi/2) c (4) ---------- = -------- *cos(phi) + ----------- *sin(phi) c d teta d teta d teta c c d s(pi,phi) d s(pi,0) d s(pi,pi/2) c (5) ----------- = ---------*cos(phi) + ------------*sin(phi) c d teta d teta d teta c c if iopt =-1 sphere calculates a weighted least-squares spherical c spline according to a given set of knots in teta- and phi- direction. c if iopt >=0, the number of knots in each direction and their position c tt(j),j=1,2,...,nt ; tp(j),j=1,2,...,np are chosen automatically by c the routine. the smoothness of s(teta,phi) is then achieved by mini- c malizing the discontinuity jumps of the derivatives of the spline c at the knots. the amount of smoothness of s(teta,phi) is determined c by the condition that fp = sum((w(i)*(r(i)-s(teta(i),phi(i))))**2) c be <= s, with s a given non-negative constant. c the spherical spline is given in the standard b-spline representation c of bicubic splines and can be evaluated by means of subroutine bispev c c calling sequence: c call sphere(iopt,m,teta,phi,r,w,s,ntest,npest,eps, c * nt,tt,np,tp,c,fp,wrk1,lwrk1,wrk2,lwrk2,iwrk,kwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a weighted c least-squares spherical spline (iopt=-1) or a smoothing c spherical spline (iopt=0 or 1) must be determined. c if iopt=0 the routine will start with an initial set of knots c tt(i)=0,tt(i+4)=pi,i=1,...,4;tp(i)=0,tp(i+4)=2*pi,i=1,...,4. c if iopt=1 the routine will continue with the set of knots c found at the last call of the routine. c attention: a call with iopt=1 must always be immediately pre- c ceded by another call with iopt=1 or iopt=0. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m >= 2. unchanged on exit. c teta : real array of dimension at least (m). c phi : real array of dimension at least (m). c r : real array of dimension at least (m). c before entry,teta(i),phi(i),r(i) must be set to the spherical c co-ordinates of the i-th data point, for i=1,...,m.the order c of the data points is immaterial. unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) must c be set to the i-th value in the set of weights. the w(i) must c be strictly positive. unchanged on exit. c s : real. on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments c ntest : integer. unchanged on exit. c npest : integer. unchanged on exit. c on entry, ntest and npest must specify an upper bound for the c number of knots required in the teta- and phi-directions. c these numbers will also determine the storage space needed by c the routine. ntest >= 8, npest >= 8. c in most practical situation ntest = npest = 8+sqrt(m/2) will c be sufficient. see also further comments. c eps : real. c on entry, eps must specify a threshold for determining the c effective rank of an over-determined linear system of equat- c ions. 0 < eps < 1. if the number of decimal digits in the c computer representation of a real number is q, then 10**(-q) c is a suitable value for eps in most practical applications. c unchanged on exit. c nt : integer. c unless ier=10 (in case iopt >=0), nt will contain the total c number of knots with respect to the teta-variable, of the c spline approximation returned. if the computation mode iopt=1 c is used, the value of nt should be left unchanged between c subsequent calls. c in case iopt=-1, the value of nt should be specified on entry c tt : real array of dimension at least ntest. c on succesful exit, this array will contain the knots of the c spline with respect to the teta-variable, i.e. the position c of the interior knots tt(5),...,tt(nt-4) as well as the c position of the additional knots tt(1)=...=tt(4)=0 and c tt(nt-3)=...=tt(nt)=pi needed for the b-spline representation c if the computation mode iopt=1 is used, the values of tt(1), c ...,tt(nt) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values tt(5), c ...tt(nt-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c np : integer. c unless ier=10 (in case iopt >=0), np will contain the total c number of knots with respect to the phi-variable, of the c spline approximation returned. if the computation mode iopt=1 c is used, the value of np should be left unchanged between c subsequent calls. c in case iopt=-1, the value of np (>=9) should be specified c on entry. c tp : real array of dimension at least npest. c on succesful exit, this array will contain the knots of the c spline with respect to the phi-variable, i.e. the position of c the interior knots tp(5),...,tp(np-4) as well as the position c of the additional knots tp(1),...,tp(4) and tp(np-3),..., c tp(np) needed for the b-spline representation. c if the computation mode iopt=1 is used, the values of tp(1), c ...,tp(np) should be left unchanged between subsequent calls. c if the computation mode iopt=-1 is used, the values tp(5), c ...tp(np-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c c : real array of dimension at least (ntest-4)*(npest-4). c on succesful exit, c contains the coefficients of the spline c approximation s(teta,phi). c fp : real. unless ier=10, fp contains the weighted sum of c squared residuals of the spline approximation returned. c wrk1 : real array of dimension (lwrk1). used as workspace. c if the computation mode iopt=1 is used the value of wrk1(1) c should be left unchanged between subsequent calls. c on exit wrk1(2),wrk1(3),...,wrk1(1+ncof) will contain the c values d(i)/max(d(i)),i=1,...,ncof=6+(np-7)*(nt-8) c with d(i) the i-th diagonal element of the reduced triangular c matrix for calculating the b-spline coefficients. it includes c those elements whose square is less than eps,which are treat- c ed as 0 in the case of presumed rank deficiency (ier<-2). c lwrk1 : integer. on entry lwrk1 must specify the actual dimension of c the array wrk1 as declared in the calling (sub)program. c lwrk1 must not be too small. let c u = ntest-7, v = npest-7, then c lwrk1 >= 185+52*v+10*u+14*u*v+8*(u-1)*v**2+8*m c wrk2 : real array of dimension (lwrk2). used as workspace, but c only in the case a rank deficient system is encountered. c lwrk2 : integer. on entry lwrk2 must specify the actual dimension of c the array wrk2 as declared in the calling (sub)program. c lwrk2 > 0 . a save upper bound for lwrk2 = 48+21*v+7*u*v+ c 4*(u-1)*v**2 where u,v are as above. if there are enough data c points, scattered uniformly over the approximation domain c and if the smoothing factor s is not too small, there is a c good chance that this extra workspace is not needed. a lot c of memory might therefore be saved by setting lwrk2=1. c (see also ier > 10) c iwrk : integer array of dimension (kwrk). used as workspace. c kwrk : integer. on entry kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. c kwrk >= m+(ntest-7)*(npest-7). c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is a spherical c interpolating spline (fp=0). c ier=-2 : normal return. the spline returned is the weighted least- c squares constrained polynomial . in this extreme case c fp gives the upper bound for the smoothing factor s. c ier<-2 : warning. the coefficients of the spline returned have been c computed as the minimal norm least-squares solution of a c (numerically) rank deficient system. (-ier) gives the rank. c especially if the rank deficiency which can be computed as c 6+(nt-8)*(np-7)+ier, is large the results may be inaccurate c they could also seriously depend on the value of eps. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameters ntest and c npest. c probably causes : ntest or npest too small. if these param- c eters are already large, it may also indicate that s is c too small c the approximation returned is the weighted least-squares c spherical spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small or badly chosen eps. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=4 : error. no more knots can be added because the dimension c of the spherical spline 6+(nt-8)*(np-7) already exceeds c the number of data points m. c probably causes : either s or m too small. c the approximation returned is the weighted least-squares c spherical spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=5 : error. no more knots can be added because the additional c knot would (quasi) coincide with an old one. c probably causes : s too small or too large a weight to an c inaccurate data point. c the approximation returned is the weighted least-squares c spherical spline according to the current set of knots. c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, m>=2, ntest>=8 ,npest >=8, 00, i=1,...,m c lwrk1 >= 185+52*v+10*u+14*u*v+8*(u-1)*v**2+8*m c kwrk >= m+(ntest-7)*(npest-7) c if iopt=-1: 8<=nt<=ntest , 9<=np<=npest c 0=0: s>=0 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c ier>10 : error. lwrk2 is too small, i.e. there is not enough work- c space for computing the minimal least-squares solution of c a rank deficient system of linear equations. ier gives the c requested value for lwrk2. there is no approximation re- c turned but, having saved the information contained in nt, c np,tt,tp,wrk1, and having adjusted the value of lwrk2 and c the dimension of the array wrk2 accordingly, the user can c continue at the point the program was left, by calling c sphere with iopt=1. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating spline if c s=0 and the constrained weighted least-squares polynomial if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c r(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in r(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the least-squares c polynomial and the corresponding upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximation shows more detail) to obtain closer fits. c to choose s very small is strongly discouraged. this considerably c increases computation time and memory requirements. it may also c cause rank-deficiency (ier<-2) and endager numerical stability. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if sphere is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. if the computation mode iopt=1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c sphere once more with the selected value for s but now with iopt=0. c indeed, sphere may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c the number of knots may also depend on the upper bounds ntest and c npest. indeed, if at a certain stage in sphere the number of knots c in one direction (say nt) has reached the value of its upper bound c (ntest), then from that moment on all subsequent knots are added c in the other (phi) direction. this may indicate that the value of c ntest is too small. on the other hand, it gives the user the option c of limiting the number of knots the routine locates in any direction c for example, by setting ntest=8 (the lowest allowable value for c ntest), the user can indicate that he wants an approximation which c is a cubic polynomial in the variable teta. c c other subroutines required: c fpback,fpbspl,fpsphe,fpdisc,fpgivs,fprank,fprati,fprota,fporde, c fprpsp c c references: c dierckx p. : algorithms for smoothing data on the sphere with tensor c product splines, computing 32 (1984) 319-342. c dierckx p. : algorithms for smoothing data on the sphere with tensor c product splines, report tw62, dept. computer science, c k.u.leuven, 1983. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : july 1983 c latest update : march 1989 c c .. c ..scalar arguments.. real s,eps,fp integer iopt,m,ntest,npest,nt,np,lwrk1,lwrk2,kwrk,ier c ..array arguments.. real teta(m),phi(m),r(m),w(m),tt(ntest),tp(npest), * c((ntest-4)*(npest-4)),wrk1(lwrk1),wrk2(lwrk2) integer iwrk(kwrk) c ..local scalars.. real tol,pi,pi2,one integer i,ib1,ib3,ki,kn,kwest,la,lbt,lcc,lcs,lro,j * lbp,lco,lf,lff,lfp,lh,lq,lst,lsp,lwest,maxit,ncest,ncc,ntt, * npp,nreg,nrint,ncof,nt4,np4 c ..function references.. real atan c ..subroutine references.. c fpsphe c .. c set constants one = 0.1e+01 c we set up the parameters tol and maxit. maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid,control is immediately repassed to the calling program. ier = 10 if(eps.le.0. .or. eps.ge.1.) go to 80 if(iopt.lt.(-1) .or. iopt.gt.1) go to 80 if(m.lt.2) go to 80 if(ntest.lt.8 .or. npest.lt.8) go to 80 nt4 = ntest-4 np4 = npest-4 ncest = nt4*np4 ntt = ntest-7 npp = npest-7 ncc = 6+npp*(ntt-1) nrint = ntt+npp nreg = ntt*npp ncof = 6+3*npp ib1 = 4*npp ib3 = ib1+3 if(ncof.gt.ib1) ib1 = ncof if(ncof.gt.ib3) ib3 = ncof lwest = 185+52*npp+10*ntt+14*ntt*npp+8*(m+(ntt-1)*npp**2) kwest = m+nreg if(lwrk1.lt.lwest .or. kwrk.lt.kwest) go to 80 if(iopt.gt.0) go to 60 pi = atan(one)*4 pi2 = pi+pi do 20 i=1,m if(w(i).le.0.) go to 80 if(teta(i).lt.0. .or. teta(i).gt.pi) go to 80 if(phi(i) .lt.0. .or. phi(i).gt.pi2) go to 80 20 continue if(iopt.eq.0) go to 60 ntt = nt-8 if(ntt.lt.0 .or. nt.gt.ntest) go to 80 if(ntt.eq.0) go to 40 tt(4) = 0. do 30 i=1,ntt j = i+4 if(tt(j).le.tt(j-1) .or. tt(j).ge.pi) go to 80 30 continue 40 npp = np-8 if(npp.lt.1 .or. np.gt.npest) go to 80 tp(4) = 0. do 50 i=1,npp j = i+4 if(tp(j).le.tp(j-1) .or. tp(j).ge.pi2) go to 80 50 continue go to 70 60 if(s.lt.0.) go to 80 70 ier = 0 c we partition the working space and determine the spline approximation kn = 1 ki = kn+m lq = 2 la = lq+ncc*ib3 lf = la+ncc*ib1 lff = lf+ncc lfp = lff+ncest lco = lfp+nrint lh = lco+nrint lbt = lh+ib3 lbp = lbt+5*ntest lro = lbp+5*npest lcc = lro+npest lcs = lcc+npest lst = lcs+npest lsp = lst+m*4 call fpsphe(iopt,m,teta,phi,r,w,s,ntest,npest,eps,tol,maxit, * ib1,ib3,ncest,ncc,nrint,nreg,nt,tt,np,tp,c,fp,wrk1(1),wrk1(lfp), * wrk1(lco),wrk1(lf),wrk1(lff),wrk1(lro),wrk1(lcc),wrk1(lcs), * wrk1(la),wrk1(lq),wrk1(lbt),wrk1(lbp),wrk1(lst),wrk1(lsp), * wrk1(lh),iwrk(ki),iwrk(kn),wrk2,lwrk2,ier) 80 return end spd-1.3.0/fitpack/pogrid.f0000644000175000017500000005326611633462461012320 00000000000000 subroutine pogrid(iopt,ider,mu,u,mv,v,z,z0,r,s,nuest,nvest, * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) c subroutine pogrid fits a function f(x,y) to a set of data points c z(i,j) given at the nodes (x,y)=(u(i)*cos(v(j)),u(i)*sin(v(j))), c i=1,...,mu ; j=1,...,mv , of a radius-angle grid over a disc c x ** 2 + y ** 2 <= r ** 2 . c c this approximation problem is reduced to the determination of a c bicubic spline s(u,v) smoothing the data (u(i),v(j),z(i,j)) on the c rectangle 0<=u<=r, v(1)<=v<=v(1)+2*pi c in order to have continuous partial derivatives c i+j c d f(0,0) c g(i,j) = ---------- c i j c dx dy c c s(u,v)=f(x,y) must satisfy the following conditions c c (1) s(0,v) = g(0,0) v(1)<=v<= v(1)+2*pi c c d s(0,v) c (2) -------- = cos(v)*g(1,0)+sin(v)*g(0,1) v(1)<=v<= v(1)+2*pi c d u c c moreover, s(u,v) must be periodic in the variable v, i.e. c c j j c d s(u,vb) d s(u,ve) c (3) ---------- = --------- 0 <=u<= r, j=0,1,2 , vb=v(1), c j j ve=vb+2*pi c d v d v c c the number of knots of s(u,v) and their position tu(i),i=1,2,...,nu; c tv(j),j=1,2,...,nv, is chosen automatically by the routine. the c smoothness of s(u,v) is achieved by minimalizing the discontinuity c jumps of the derivatives of the spline at the knots. the amount of c smoothness of s(u,v) is determined by the condition that c fp=sumi=1,mu(sumj=1,mv((z(i,j)-s(u(i),v(j)))**2))+(z0-g(0,0))**2<=s, c with s a given non-negative constant. c the fit s(u,v) is given in its b-spline representation and can be c evaluated by means of routine bispev. f(x,y) = s(u,v) can also be c evaluated by means of function program evapol. c c calling sequence: c call pogrid(iopt,ider,mu,u,mv,v,z,z0,r,s,nuest,nvest,nu,tu, c * ,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) c c parameters: c iopt : integer array of dimension 3, specifying different options. c unchanged on exit. c iopt(1):on entry iopt(1) must specify whether a least-squares spline c (iopt(1)=-1) or a smoothing spline (iopt(1)=0 or 1) must be c determined. c if iopt(1)=0 the routine will start with an initial set of c knots tu(i)=0,tu(i+4)=r,i=1,...,4;tv(i)=v(1)+(i-4)*2*pi,i=1,. c ...,8. c if iopt(1)=1 the routine will continue with the set of knots c found at the last call of the routine. c attention: a call with iopt(1)=1 must always be immediately c preceded by another call with iopt(1) = 1 or iopt(1) = 0. c iopt(2):on entry iopt(2) must specify the requested order of conti- c nuity for f(x,y) at the origin. c if iopt(2)=0 only condition (1) must be fulfilled and c if iopt(2)=1 conditions (1)+(2) must be fulfilled. c iopt(3):on entry iopt(3) must specify whether (iopt(3)=1) or not c (iopt(3)=0) the approximation f(x,y) must vanish at the c boundary of the approximation domain. c ider : integer array of dimension 2, specifying different options. c unchanged on exit. c ider(1):on entry ider(1) must specify whether (ider(1)=0 or 1) or not c (ider(1)=-1) there is a data value z0 at the origin. c if ider(1)=1, z0 will be considered to be the right function c value, and it will be fitted exactly (g(0,0)=z0=c(1)). c if ider(1)=0, z0 will be considered to be a data value just c like the other data values z(i,j). c ider(2):on entry ider(2) must specify whether (ider(2)=1) or not c (ider(2)=0) f(x,y) must have vanishing partial derivatives c g(1,0) and g(0,1) at the origin. (in case iopt(2)=1) c mu : integer. on entry mu must specify the number of grid points c along the u-axis. unchanged on exit. c mu >= mumin where mumin=4-iopt(3)-ider(2) if ider(1)<0 c =3-iopt(3)-ider(2) if ider(1)>=0 c u : real array of dimension at least (mu). before entry, u(i) c must be set to the u-co-ordinate of the i-th grid point c along the u-axis, for i=1,2,...,mu. these values must be c positive and supplied in strictly ascending order. c unchanged on exit. c mv : integer. on entry mv must specify the number of grid points c along the v-axis. mv > 3 . unchanged on exit. c v : real array of dimension at least (mv). before entry, v(j) c must be set to the v-co-ordinate of the j-th grid point c along the v-axis, for j=1,2,...,mv. these values must be c supplied in strictly ascending order. unchanged on exit. c -pi <= v(1) < pi , v(mv) < v(1)+2*pi. c z : real array of dimension at least (mu*mv). c before entry, z(mv*(i-1)+j) must be set to the data value at c the grid point (u(i),v(j)) for i=1,...,mu and j=1,...,mv. c unchanged on exit. c z0 : real value. on entry (if ider(1) >=0 ) z0 must specify the c data value at the origin. unchanged on exit. c r : real value. on entry r must specify the radius of the disk. c r>=u(mu) (>u(mu) if iopt(3)=1). unchanged on exit. c s : real. on entry (if iopt(1)>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments c nuest : integer. unchanged on exit. c nvest : integer. unchanged on exit. c on entry, nuest and nvest must specify an upper bound for the c number of knots required in the u- and v-directions respect. c these numbers will also determine the storage space needed by c the routine. nuest >= 8, nvest >= 8. c in most practical situation nuest = mu/2, nvest=mv/2, will c be sufficient. always large enough are nuest=mu+5+iopt(2)+ c iopt(3), nvest = mv+7, the number of knots needed for c interpolation (s=0). see also further comments. c nu : integer. c unless ier=10 (in case iopt(1)>=0), nu will contain the total c number of knots with respect to the u-variable, of the spline c approximation returned. if the computation mode iopt(1)=1 is c used, the value of nu should be left unchanged between sub- c sequent calls. in case iopt(1)=-1, the value of nu should be c specified on entry. c tu : real array of dimension at least (nuest). c on succesful exit, this array will contain the knots of the c spline with respect to the u-variable, i.e. the position of c the interior knots tu(5),...,tu(nu-4) as well as the position c of the additional knots tu(1)=...=tu(4)=0 and tu(nu-3)=...= c tu(nu)=r needed for the b-spline representation. c if the computation mode iopt(1)=1 is used,the values of tu(1) c ...,tu(nu) should be left unchanged between subsequent calls. c if the computation mode iopt(1)=-1 is used, the values tu(5), c ...tu(nu-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c nv : integer. c unless ier=10 (in case iopt(1)>=0), nv will contain the total c number of knots with respect to the v-variable, of the spline c approximation returned. if the computation mode iopt(1)=1 is c used, the value of nv should be left unchanged between sub- c sequent calls. in case iopt(1) = -1, the value of nv should c be specified on entry. c tv : real array of dimension at least (nvest). c on succesful exit, this array will contain the knots of the c spline with respect to the v-variable, i.e. the position of c the interior knots tv(5),...,tv(nv-4) as well as the position c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., c tv(nv) needed for the b-spline representation. c if the computation mode iopt(1)=1 is used,the values of tv(1) c ...,tv(nv) should be left unchanged between subsequent calls. c if the computation mode iopt(1)=-1 is used, the values tv(5), c ...tv(nv-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c c : real array of dimension at least (nuest-4)*(nvest-4). c on succesful exit, c contains the coefficients of the spline c approximation s(u,v) c fp : real. unless ier=10, fp contains the sum of squared c residuals of the spline approximation returned. c wrk : real array of dimension (lwrk). used as workspace. c if the computation mode iopt(1)=1 is used the values of c wrk(1),...,wrk(8) should be left unchanged between subsequent c calls. c lwrk : integer. on entry lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. c lwrk must not be too small. c lwrk >= 8+nuest*(mv+nvest+3)+nvest*21+4*mu+6*mv+q c where q is the larger of (mv+nvest) and nuest. c iwrk : integer array of dimension (kwrk). used as workspace. c if the computation mode iopt(1)=1 is used the values of c iwrk(1),.,iwrk(4) should be left unchanged between subsequent c calls. c kwrk : integer. on entry kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. c kwrk >= 4+mu+mv+nuest+nvest. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is an interpolating c spline (fp=0). c ier=-2 : normal return. the spline returned is the least-squares c constrained polynomial. in this extreme case fp gives the c upper bound for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameters nuest and c nvest. c probably causes : nuest or nvest too small. if these param- c eters are already large, it may also indicate that s is c too small c the approximation returned is the least-squares spline c according to the current set of knots. the parameter fp c gives the corresponding sum of squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt(1)<=1, 0<=iopt(2)<=1, 0<=iopt(3)<=1, c -1<=ider(1)<=1, 0<=ider(2)<=1, ider(2)=0 if iopt(2)=0. c mu >= mumin (see above), mv >= 4, nuest >=8, nvest >= 8, c kwrk>=4+mu+mv+nuest+nvest, c lwrk >= 8+nuest*(mv+nvest+3)+nvest*21+4*mu+6*mv+ c max(nuest,mv+nvest) c 0< u(i-1)=0: s>=0 c if s=0: nuest>=mu+5+iopt(2)+iopt(3), nvest>=mv+7 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c pogrid does not allow individual weighting of the data-values. c so, if these were determined to widely different accuracies, then c perhaps the general data set routine polar should rather be used c in spite of efficiency. c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating spline if c s=0 and the constrained least-squares polynomial(degrees 3,0)if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the accuracy of the data values. c if the user has an idea of the statistical errors on the data, he c can also find a proper estimate for s. for, by assuming that, if he c specifies the right s, pogrid will return a spline s(u,v) which c exactly reproduces the function underlying the data he can evaluate c the sum((z(i,j)-s(u(i),v(j)))**2) to find a good estimate for this s c for example, if he knows that the statistical errors on his z(i,j)- c values is not greater than 0.1, he may expect that a good s should c have a value not larger than mu*mv*(0.1)**2. c if nothing is known about the statistical error in z(i,j), s must c be determined by trial and error, taking account of the comments c above. the best is then to start with a very large value of s (to c determine the least-squares polynomial and the corresponding upper c bound fp0 for s) and then to progressively decrease the value of s c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... c and more carefully as the approximation shows more detail) to c obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt(1)=0. c if iopt(1) = 1 the program will continue with the knots found at c the last call of the routine. this will save a lot of computation c time if pogrid is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. if the computation mode iopt(1) = 1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt(1)=1,the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c pogrid once more with the chosen value for s but now with iopt(1)=0. c indeed, pogrid may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c the number of knots may also depend on the upper bounds nuest and c nvest. indeed, if at a certain stage in pogrid the number of knots c in one direction (say nu) has reached the value of its upper bound c (nuest), then from that moment on all subsequent knots are added c in the other (v) direction. this may indicate that the value of c nuest is too small. on the other hand, it gives the user the option c of limiting the number of knots the routine locates in any direction c for example, by setting nuest=8 (the lowest allowable value for c nuest), the user can indicate that he wants an approximation which c is a simple cubic polynomial in the variable u. c c other subroutines required: c fppogr,fpchec,fpchep,fpknot,fpopdi,fprati,fpgrdi,fpsysy,fpback, c fpbacp,fpbspl,fpcyt1,fpcyt2,fpdisc,fpgivs,fprota c c references: c dierckx p. : fast algorithms for smoothing data over a disc or a c sphere using tensor product splines, in "algorithms c for approximation", ed. j.c.mason and m.g.cox, c clarendon press oxford, 1987, pp. 51-65 c dierckx p. : fast algorithms for smoothing data over a disc or a c sphere using tensor product splines, report tw73, dept. c computer science,k.u.leuven, 1985. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : july 1985 c latest update : march 1989 c c .. c ..scalar arguments.. real z0,r,s,fp integer mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier c ..array arguments.. integer iopt(3),ider(2),iwrk(kwrk) real u(mu),v(mv),z(mu*mv),c((nuest-4)*(nvest-4)),tu(nuest), * tv(nvest),wrk(lwrk) c ..local scalars.. real per,pi,tol,uu,ve,zmax,zmin,one,half,rn,zb integer i,i1,i2,j,jwrk,j1,j2,kndu,kndv,knru,knrv,kwest,l, * ldz,lfpu,lfpv,lwest,lww,m,maxit,mumin,muu,nc c ..function references.. real atan2 integer max0 c ..subroutine references.. c fpchec,fpchep,fppogr c .. c set constants one = 1 half = 0.5e0 pi = atan2(0.,-one) per = pi+pi ve = v(1)+per c we set up the parameters tol and maxit. maxit = 20 tol = 0.1e-02 c before starting computations, a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(iopt(1).lt.(-1) .or. iopt(1).gt.1) go to 200 if(iopt(2).lt.0 .or. iopt(2).gt.1) go to 200 if(iopt(3).lt.0 .or. iopt(3).gt.1) go to 200 if(ider(1).lt.(-1) .or. ider(1).gt.1) go to 200 if(ider(2).lt.0 .or. ider(2).gt.1) go to 200 if(ider(2).eq.1 .and. iopt(2).eq.0) go to 200 mumin = 4-iopt(3)-ider(2) if(ider(1).ge.0) mumin = mumin-1 if(mu.lt.mumin .or. mv.lt.4) go to 200 if(nuest.lt.8 .or. nvest.lt.8) go to 200 m = mu*mv nc = (nuest-4)*(nvest-4) lwest = 8+nuest*(mv+nvest+3)+21*nvest+4*mu+6*mv+ * max0(nuest,mv+nvest) kwest = 4+mu+mv+nuest+nvest if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200 if(u(1).le.0. .or. u(mu).gt.r) go to 200 if(iopt(3).eq.0) go to 10 if(u(mu).eq.r) go to 200 10 if(mu.eq.1) go to 30 do 20 i=2,mu if(u(i-1).ge.u(i)) go to 200 20 continue 30 if(v(1).lt. (-pi) .or. v(1).ge.pi ) go to 200 if(v(mv).ge.v(1)+per) go to 200 do 40 i=2,mv if(v(i-1).ge.v(i)) go to 200 40 continue if(iopt(1).gt.0) go to 140 c if not given, we compute an estimate for z0. if(ider(1).lt.0) go to 50 zb = z0 go to 70 50 zb = 0. do 60 i=1,mv zb = zb+z(i) 60 continue rn = mv zb = zb/rn c we determine the range of z-values. 70 zmin = zb zmax = zb do 80 i=1,m if(z(i).lt.zmin) zmin = z(i) if(z(i).gt.zmax) zmax = z(i) 80 continue wrk(5) = zb wrk(6) = 0. wrk(7) = 0. wrk(8) = zmax -zmin iwrk(4) = mu if(iopt(1).eq.0) go to 140 if(nu.lt.8 .or. nu.gt.nuest) go to 200 if(nv.lt.11 .or. nv.gt.nvest) go to 200 j = nu do 90 i=1,4 tu(i) = 0. tu(j) = r j = j-1 90 continue l = 9 wrk(l) = 0. if(iopt(2).eq.0) go to 100 l = l+1 uu = u(1) if(uu.gt.tu(5)) uu = tu(5) wrk(l) = uu*half 100 do 110 i=1,mu l = l+1 wrk(l) = u(i) 110 continue if(iopt(3).eq.0) go to 120 l = l+1 wrk(l) = r 120 muu = l-8 call fpchec(wrk(9),muu,tu,nu,3,ier) if(ier.ne.0) go to 200 j1 = 4 tv(j1) = v(1) i1 = nv-3 tv(i1) = ve j2 = j1 i2 = i1 do 130 i=1,3 i1 = i1+1 i2 = i2-1 j1 = j1+1 j2 = j2-1 tv(j2) = tv(i2)-per tv(i1) = tv(j1)+per 130 continue l = 9 do 135 i=1,mv wrk(l) = v(i) l = l+1 135 continue wrk(l) = ve call fpchep(wrk(9),mv+1,tv,nv,3,ier) if(ier) 200,150,200 140 if(s.lt.0.) go to 200 if(s.eq.0. .and. (nuest.lt.(mu+5+iopt(2)+iopt(3)) .or. * nvest.lt.(mv+7)) ) go to 200 c we partition the working space and determine the spline approximation 150 ldz = 5 lfpu = 9 lfpv = lfpu+nuest lww = lfpv+nvest jwrk = lwrk-8-nuest-nvest knru = 5 knrv = knru+mu kndu = knrv+mv kndv = kndu+nuest call fppogr(iopt,ider,u,mu,v,mv,z,m,zb,r,s,nuest,nvest,tol,maxit, * nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),wrk(lfpu), * wrk(lfpv),wrk(ldz),wrk(8),iwrk(1),iwrk(2),iwrk(3),iwrk(4), * iwrk(knru),iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww),jwrk,ier) 200 return end spd-1.3.0/fitpack/fpcosp.f0000644000175000017500000002715311633462460012321 00000000000000 subroutine fpcosp(m,x,y,w,n,t,e,maxtr,maxbin,c,sq,sx,bind,nm,mb,a, * b,const,z,zz,u,q,info,up,left,right,jbind,ibind,ier) c .. c ..scalar arguments.. real sq integer m,n,maxtr,maxbin,nm,mb,ier c ..array arguments.. real x(m),y(m),w(m),t(n),e(n),c(n),sx(m),a(n,4),b(nm,maxbin), * const(n),z(n),zz(n),u(maxbin),q(m,4) integer info(maxtr),up(maxtr),left(maxtr),right(maxtr),jbind(mb), * ibind(mb) logical bind(n) c ..local scalars.. integer count,i,i1,j,j1,j2,j3,k,kdim,k1,k2,k3,k4,k5,k6, * l,lp1,l1,l2,l3,merk,nbind,number,n1,n4,n6 real f,wi,xi c ..local array.. real h(4) c ..subroutine references.. c fpbspl,fpadno,fpdeno,fpfrno,fpseno c .. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c if we use the b-spline representation of s(x) our approximation c c problem results in a quadratic programming problem: c c find the b-spline coefficients c(j),j=1,2,...n-4 such that c c (1) sumi((wi*(yi-sumj(cj*nj(xi))))**2),i=1,2,...m is minimal c c (2) sumj(cj*n''j(t(l+3)))*e(l) <= 0, l=1,2,...n-6. c c to solve this problem we use the theil-van de panne procedure. c c if the inequality constraints (2) are numbered from 1 to n-6, c c this algorithm finds a subset of constraints ibind(1)..ibind(nbind) c c such that the solution of the minimization problem (1) with these c c constraints in equality form, satisfies all constraints. such a c c feasible solution is optimal if the lagrange parameters associated c c with that problem with equality constraints, are all positive. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c determine n6, the number of inequality constraints. n6 = n-6 c fix the parameters which determine these constraints. do 10 i=1,n6 const(i) = e(i)*(t(i+4)-t(i+1))/(t(i+5)-t(i+2)) 10 continue c initialize the triply linked tree which is used to find the subset c of constraints ibind(1),...ibind(nbind). count = 1 info(1) = 0 left(1) = 0 right(1) = 0 up(1) = 1 merk = 1 c set up the normal equations n'nc=n'y where n denotes the m x (n-4) c observation matrix with elements ni,j = wi*nj(xi) and y is the c column vector with elements yi*wi. c from the properties of the b-splines nj(x),j=1,2,...n-4, it follows c that n'n is a (n-4) x (n-4) positive definit bandmatrix of c bandwidth 7. the matrices n'n and n'y are built up in a and z. n4 = n-4 c initialization do 20 i=1,n4 z(i) = 0. do 20 j=1,4 a(i,j) = 0. 20 continue l = 4 lp1 = l+1 do 70 i=1,m c fetch the current row of the observation matrix. xi = x(i) wi = w(i)**2 c search for knot interval t(l) <= xi < t(l+1) 30 if(xi.lt.t(lp1) .or. l.eq.n4) go to 40 l = lp1 lp1 = l+1 go to 30 c evaluate the four non-zero cubic b-splines nj(xi),j=l-3,...l. 40 call fpbspl(t,n,3,xi,l,h) c store in q these values h(1),h(2),...h(4). do 50 j=1,4 q(i,j) = h(j) 50 continue c add the contribution of the current row of the observation matrix c n to the normal equations. l3 = l-3 k1 = 0 do 60 j1 = l3,l k1 = k1+1 f = h(k1) z(j1) = z(j1)+f*wi*y(i) k2 = k1 j2 = 4 do 60 j3 = j1,l a(j3,j2) = a(j3,j2)+f*wi*h(k2) k2 = k2+1 j2 = j2-1 60 continue 70 continue c since n'n is a symmetric matrix it can be factorized as c (3) n'n = (r1)'(d1)(r1) c with d1 a diagonal matrix and r1 an (n-4) x (n-4) unit upper c triangular matrix of bandwidth 4. the matrices r1 and d1 are built c up in a. at the same time we solve the systems of equations c (4) (r1)'(z2) = n'y c (5) (d1) (z1) = (z2) c the vectors z2 and z1 are kept in zz and z. do 140 i=1,n4 k1 = 1 if(i.lt.4) k1 = 5-i k2 = i-4+k1 k3 = k2 do 100 j=k1,4 k4 = j-1 k5 = 4-j+k1 f = a(i,j) if(k1.gt.k4) go to 90 k6 = k2 do 80 k=k1,k4 f = f-a(i,k)*a(k3,k5)*a(k6,4) k5 = k5+1 k6 = k6+1 80 continue 90 if(j.eq.4) go to 110 a(i,j) = f/a(k3,4) k3 = k3+1 100 continue 110 a(i,4) = f f = z(i) if(i.eq.1) go to 130 k4 = i do 120 j=k1,3 k = k1+3-j k4 = k4-1 f = f-a(i,k)*z(k4)*a(k4,4) 120 continue 130 z(i) = f/a(i,4) zz(i) = f 140 continue c start computing the least-squares cubic spline without taking account c of any constraint. nbind = 0 n1 = 1 ibind(1) = 0 c main loop for the least-squares problems with different subsets of c the constraints (2) in equality form. the resulting b-spline coeff. c c and lagrange parameters u are the solution of the system c ! n'n b' ! ! c ! ! n'y ! c (6) ! ! ! ! = ! ! c ! b 0 ! ! u ! ! 0 ! c z1 is stored into array c. 150 do 160 i=1,n4 c(i) = z(i) 160 continue c if there are no equality constraints, compute the coeff. c directly. if(nbind.eq.0) go to 370 c initialization kdim = n4+nbind do 170 i=1,nbind do 170 j=1,kdim b(j,i) = 0. 170 continue c matrix b is built up,expressing that the constraints nrs ibind(1),... c ibind(nbind) must be satisfied in equality form. do 180 i=1,nbind l = ibind(i) b(l,i) = e(l) b(l+1,i) = -(e(l)+const(l)) b(l+2,i) = const(l) 180 continue c find the matrix (b1) as the solution of the system of equations c (7) (r1)'(d1)(b1) = b' c (b1) is built up in the upper part of the array b(rows 1,...n-4). do 220 k1=1,nbind l = ibind(k1) do 210 i=l,n4 f = b(i,k1) if(i.eq.1) go to 200 k2 = 3 if(i.lt.4) k2 = i-1 do 190 k3=1,k2 l1 = i-k3 l2 = 4-k3 f = f-b(l1,k1)*a(i,l2)*a(l1,4) 190 continue 200 b(i,k1) = f/a(i,4) 210 continue 220 continue c factorization of the symmetric matrix -(b1)'(d1)(b1) c (8) -(b1)'(d1)(b1) = (r2)'(d2)(r2) c with (d2) a diagonal matrix and (r2) an nbind x nbind unit upper c triangular matrix. the matrices r2 and d2 are built up in the lower c part of the array b (rows n-3,n-2,...n-4+nbind). do 270 i=1,nbind i1 = i-1 do 260 j=i,nbind f = 0. do 230 k=1,n4 f = f+b(k,i)*b(k,j)*a(k,4) 230 continue k1 = n4+1 if(i1.eq.0) go to 250 do 240 k=1,i1 f = f+b(k1,i)*b(k1,j)*b(k1,k) k1 = k1+1 240 continue 250 b(k1,j) = -f if(j.eq.i) go to 260 b(k1,j) = b(k1,j)/b(k1,i) 260 continue 270 continue c according to (3),(7) and (8) the system of equations (6) becomes c ! (r1)' 0 ! ! (d1) 0 ! ! (r1) (b1) ! ! c ! ! n'y ! c (9) ! ! ! ! ! ! ! ! = ! ! c ! (b1)' (r2)'! ! 0 (d2) ! ! 0 (r2) ! ! u ! ! 0 ! c backward substitution to obtain the b-spline coefficients c(j),j=1,.. c n-4 and the lagrange parameters u(j),j=1,2,...nbind. c first step of the backward substitution: solve the system c ! (r1)'(d1) 0 ! ! (c1) ! ! n'y ! c (10) ! ! ! ! = ! ! c ! (b1)'(d1) (r2)'(d2) ! ! (u1) ! ! 0 ! c from (4) and (5) we know that this is equivalent to c (11) (c1) = (z1) c (12) (r2)'(d2)(u1) = -(b1)'(z2) do 310 i=1,nbind f = 0. do 280 j=1,n4 f = f+b(j,i)*zz(j) 280 continue i1 = i-1 k1 = n4+1 if(i1.eq.0) go to 300 do 290 j=1,i1 f = f+u(j)*b(k1,i)*b(k1,j) k1 = k1+1 290 continue 300 u(i) = -f/b(k1,i) 310 continue c second step of the backward substitution: solve the system c ! (r1) (b1) ! ! c ! ! c1 ! c (13) ! ! ! ! = ! ! c ! 0 (r2) ! ! u ! ! u1 ! k1 = nbind k2 = kdim c find the lagrange parameters u. do 340 i=1,nbind f = u(k1) if(i.eq.1) go to 330 k3 = k1+1 do 320 j=k3,nbind f = f-u(j)*b(k2,j) 320 continue 330 u(k1) = f k1 = k1-1 k2 = k2-1 340 continue c find the b-spline coefficients c. do 360 i=1,n4 f = c(i) do 350 j=1,nbind f = f-u(j)*b(i,j) 350 continue c(i) = f 360 continue 370 k1 = n4 do 390 i=2,n4 k1 = k1-1 f = c(k1) k2 = 1 if(i.lt.5) k2 = 5-i k3 = k1 l = 3 do 380 j=k2,3 k3 = k3+1 f = f-a(k3,l)*c(k3) l = l-1 380 continue c(k1) = f 390 continue c test whether the solution of the least-squares problem with the c constraints ibind(1),...ibind(nbind) in equality form, satisfies c all of the constraints (2). k = 1 c number counts the number of violated inequality constraints. number = 0 do 440 j=1,n6 l = ibind(k) k = k+1 if(j.eq.l) go to 440 k = k-1 c test whether constraint j is satisfied f = e(j)*(c(j)-c(j+1))+const(j)*(c(j+2)-c(j+1)) if(f.le.0.) go to 440 c if constraint j is not satisfied, add a branch of length nbind+1 c to the tree. the nodes of this branch contain in their information c field the number of the constraints ibind(1),...ibind(nbind) and j, c arranged in increasing order. number = number+1 k1 = k-1 if(k1.eq.0) go to 410 do 400 i=1,k1 jbind(i) = ibind(i) 400 continue 410 jbind(k) = j if(l.eq.0) go to 430 do 420 i=k,nbind jbind(i+1) = ibind(i) 420 continue 430 call fpadno(maxtr,up,left,right,info,count,merk,jbind,n1,ier) c test whether the storage space which is required for the tree,exceeds c the available storage space. if(ier.ne.0) go to 560 440 continue c test whether the solution of the least-squares problem with equality c constraints is a feasible solution. if(number.eq.0) go to 470 c test whether there are still cases with nbind constraints in c equality form to be considered. 450 if(merk.gt.1) go to 460 nbind = n1 c test whether the number of knots where s''(x)=0 exceeds maxbin. if(nbind.gt.maxbin) go to 550 n1 = n1+1 ibind(n1) = 0 c search which cases with nbind constraints in equality form c are going to be considered. call fpdeno(maxtr,up,left,right,nbind,merk) c test whether the quadratic programming problem has a solution. if(merk.eq.1) go to 570 c find a new case with nbind constraints in equality form. 460 call fpseno(maxtr,up,left,right,info,merk,ibind,nbind) go to 150 c test whether the feasible solution is optimal. 470 ier = 0 do 480 i=1,n6 bind(i) = .false. 480 continue if(nbind.eq.0) go to 500 do 490 i=1,nbind if(u(i).le.0.) go to 450 j = ibind(i) bind(j) = .true. 490 continue c evaluate s(x) at the data points x(i) and calculate the weighted c sum of squared residual right hand sides sq. 500 sq = 0. l = 4 lp1 = 5 do 530 i=1,m 510 if(x(i).lt.t(lp1) .or. l.eq.n4) go to 520 l = lp1 lp1 = l+1 go to 510 520 sx(i) = c(l-3)*q(i,1)+c(l-2)*q(i,2)+c(l-1)*q(i,3)+c(l)*q(i,4) sq = sq+(w(i)*(y(i)-sx(i)))**2 530 continue go to 600 c error codes and messages. 550 ier = 1 go to 600 560 ier = 2 go to 600 570 ier = 3 600 return end spd-1.3.0/fitpack/fpbacp.f0000644000175000017500000000253311633462461012256 00000000000000 subroutine fpbacp(a,b,z,n,k,c,k1,nest) c subroutine fpbacp calculates the solution of the system of equations c g * c = z with g a n x n upper triangular matrix of the form c ! a ' ! c g = ! ' b ! c ! 0 ' ! c with b a n x k matrix and a a (n-k) x (n-k) upper triangular c matrix of bandwidth k1. c .. c ..scalar arguments.. integer n,k,k1,nest c ..array arguments.. real a(nest,k1),b(nest,k),z(n),c(n) c ..local scalars.. integer i,i1,j,l,l0,l1,n2 real store c .. n2 = n-k l = n do 30 i=1,k store = z(l) j = k+2-i if(i.eq.1) go to 20 l0 = l do 10 l1=j,k l0 = l0+1 store = store-c(l0)*b(l,l1) 10 continue 20 c(l) = store/b(l,j-1) l = l-1 if(l.eq.0) go to 80 30 continue do 50 i=1,n2 store = z(i) l = n2 do 40 j=1,k l = l+1 store = store-c(l)*b(i,j) 40 continue c(i) = store 50 continue i = n2 c(i) = c(i)/a(i,1) if(i.eq.1) go to 80 do 70 j=2,n2 i = i-1 store = c(i) i1 = k if(j.le.k) i1=j-1 l = i do 60 l0=1,i1 l = l+1 store = store-c(l)*a(i,l0+1) 60 continue c(i) = store/a(i,1) 70 continue 80 return end spd-1.3.0/fitpack/spgrid.f0000644000175000017500000005577711633462460012334 00000000000000 subroutine spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest, * nu,tu,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) c given the function values r(i,j) on the latitude-longitude grid c (u(i),v(j)), i=1,...,mu ; j=1,...,mv , spgrid determines a smooth c bicubic spline approximation on the rectangular domain 0<=u<=pi, c vb<=v<=ve (vb = v(1), ve=vb+2*pi). c this approximation s(u,v) will satisfy the properties c c (1) s(0,v) = s(0,0) = dr(1) c c d s(0,v) d s(0,0) d s(0,pi/2) c (2) -------- = cos(v)* -------- + sin(v)* ----------- c d u d u d u c c = cos(v)*dr(2)+sin(v)*dr(3) c vb <= v <= ve c (3) s(pi,v) = s(pi,0) = dr(4) c c d s(pi,v) d s(pi,0) d s(pi,pi/2) c (4) -------- = cos(v)* --------- + sin(v)* ------------ c d u d u d u c c = cos(v)*dr(5)+sin(v)*dr(6) c c and will be periodic in the variable v, i.e. c c j j c d s(u,vb) d s(u,ve) c (5) --------- = --------- 0 <=u<= pi , j=0,1,2 c j j c d v d v c c the number of knots of s(u,v) and their position tu(i),i=1,2,...,nu; c tv(j),j=1,2,...,nv, is chosen automatically by the routine. the c smoothness of s(u,v) is achieved by minimalizing the discontinuity c jumps of the derivatives of the spline at the knots. the amount of c smoothness of s(u,v) is determined by the condition that c fp=sumi=1,mu(sumj=1,mv((r(i,j)-s(u(i),v(j)))**2))+(r0-s(0,v))**2 c + (r1-s(pi,v))**2 <= s, with s a given non-negative constant. c the fit s(u,v) is given in its b-spline representation and can be c evaluated by means of routine bispev c c calling sequence: c call spgrid(iopt,ider,mu,u,mv,v,r,r0,r1,s,nuest,nvest,nu,tu, c * ,nv,tv,c,fp,wrk,lwrk,iwrk,kwrk,ier) c c parameters: c iopt : integer array of dimension 3, specifying different options. c unchanged on exit. c iopt(1):on entry iopt(1) must specify whether a least-squares spline c (iopt(1)=-1) or a smoothing spline (iopt(1)=0 or 1) must be c determined. c if iopt(1)=0 the routine will start with an initial set of c knots tu(i)=0,tu(i+4)=pi,i=1,...,4;tv(i)=v(1)+(i-4)*2*pi, c i=1,...,8. c if iopt(1)=1 the routine will continue with the set of knots c found at the last call of the routine. c attention: a call with iopt(1)=1 must always be immediately c preceded by another call with iopt(1) = 1 or iopt(1) = 0. c iopt(2):on entry iopt(2) must specify the requested order of conti- c nuity at the pole u=0. c if iopt(2)=0 only condition (1) must be fulfilled and c if iopt(2)=1 conditions (1)+(2) must be fulfilled. c iopt(3):on entry iopt(3) must specify the requested order of conti- c nuity at the pole u=pi. c if iopt(3)=0 only condition (3) must be fulfilled and c if iopt(3)=1 conditions (3)+(4) must be fulfilled. c ider : integer array of dimension 4, specifying different options. c unchanged on exit. c ider(1):on entry ider(1) must specify whether (ider(1)=0 or 1) or not c (ider(1)=-1) there is a data value r0 at the pole u=0. c if ider(1)=1, r0 will be considered to be the right function c value, and it will be fitted exactly (s(0,v)=r0). c if ider(1)=0, r0 will be considered to be a data value just c like the other data values r(i,j). c ider(2):on entry ider(2) must specify whether (ider(2)=1) or not c (ider(2)=0) the approximation has vanishing derivatives c dr(2) and dr(3) at the pole u=0 (in case iopt(2)=1) c ider(3):on entry ider(3) must specify whether (ider(3)=0 or 1) or not c (ider(3)=-1) there is a data value r1 at the pole u=pi. c if ider(3)=1, r1 will be considered to be the right function c value, and it will be fitted exactly (s(pi,v)=r1). c if ider(3)=0, r1 will be considered to be a data value just c like the other data values r(i,j). c ider(4):on entry ider(4) must specify whether (ider(4)=1) or not c (ider(4)=0) the approximation has vanishing derivatives c dr(5) and dr(6) at the pole u=pi (in case iopt(3)=1) c mu : integer. on entry mu must specify the number of grid points c along the u-axis. unchanged on exit. c mu >= 1, mu >=mumin=4-i0-i1-ider(2)-ider(4) with c i0=min(1,ider(1)+1), i1=min(1,ider(3)+1) c u : real array of dimension at least (mu). before entry, u(i) c must be set to the u-co-ordinate of the i-th grid point c along the u-axis, for i=1,2,...,mu. these values must be c supplied in strictly ascending order. unchanged on exit. c 0 < u(i) < pi. c mv : integer. on entry mv must specify the number of grid points c along the v-axis. mv > 3 . unchanged on exit. c v : real array of dimension at least (mv). before entry, v(j) c must be set to the v-co-ordinate of the j-th grid point c along the v-axis, for j=1,2,...,mv. these values must be c supplied in strictly ascending order. unchanged on exit. c -pi <= v(1) < pi , v(mv) < v(1)+2*pi. c r : real array of dimension at least (mu*mv). c before entry, r(mv*(i-1)+j) must be set to the data value at c the grid point (u(i),v(j)) for i=1,...,mu and j=1,...,mv. c unchanged on exit. c r0 : real value. on entry (if ider(1) >=0 ) r0 must specify the c data value at the pole u=0. unchanged on exit. c r1 : real value. on entry (if ider(1) >=0 ) r1 must specify the c data value at the pole u=pi. unchanged on exit. c s : real. on entry (if iopt(1)>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments c nuest : integer. unchanged on exit. c nvest : integer. unchanged on exit. c on entry, nuest and nvest must specify an upper bound for the c number of knots required in the u- and v-directions respect. c these numbers will also determine the storage space needed by c the routine. nuest >= 8, nvest >= 8. c in most practical situation nuest = mu/2, nvest=mv/2, will c be sufficient. always large enough are nuest=mu+6+iopt(2)+ c iopt(3), nvest = mv+7, the number of knots needed for c interpolation (s=0). see also further comments. c nu : integer. c unless ier=10 (in case iopt(1)>=0), nu will contain the total c number of knots with respect to the u-variable, of the spline c approximation returned. if the computation mode iopt(1)=1 is c used, the value of nu should be left unchanged between sub- c sequent calls. in case iopt(1)=-1, the value of nu should be c specified on entry. c tu : real array of dimension at least (nuest). c on succesful exit, this array will contain the knots of the c spline with respect to the u-variable, i.e. the position of c the interior knots tu(5),...,tu(nu-4) as well as the position c of the additional knots tu(1)=...=tu(4)=0 and tu(nu-3)=...= c tu(nu)=pi needed for the b-spline representation. c if the computation mode iopt(1)=1 is used,the values of tu(1) c ...,tu(nu) should be left unchanged between subsequent calls. c if the computation mode iopt(1)=-1 is used, the values tu(5), c ...tu(nu-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c nv : integer. c unless ier=10 (in case iopt(1)>=0), nv will contain the total c number of knots with respect to the v-variable, of the spline c approximation returned. if the computation mode iopt(1)=1 is c used, the value of nv should be left unchanged between sub- c sequent calls. in case iopt(1) = -1, the value of nv should c be specified on entry. c tv : real array of dimension at least (nvest). c on succesful exit, this array will contain the knots of the c spline with respect to the v-variable, i.e. the position of c the interior knots tv(5),...,tv(nv-4) as well as the position c of the additional knots tv(1),...,tv(4) and tv(nv-3),..., c tv(nv) needed for the b-spline representation. c if the computation mode iopt(1)=1 is used,the values of tv(1) c ...,tv(nv) should be left unchanged between subsequent calls. c if the computation mode iopt(1)=-1 is used, the values tv(5), c ...tv(nv-4) must be supplied by the user, before entry. c see also the restrictions (ier=10). c c : real array of dimension at least (nuest-4)*(nvest-4). c on succesful exit, c contains the coefficients of the spline c approximation s(u,v) c fp : real. unless ier=10, fp contains the sum of squared c residuals of the spline approximation returned. c wrk : real array of dimension (lwrk). used as workspace. c if the computation mode iopt(1)=1 is used the values of c wrk(1),..,wrk(12) should be left unchanged between subsequent c calls. c lwrk : integer. on entry lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program. c lwrk must not be too small. c lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+q c where q is the larger of (mv+nvest) and nuest. c iwrk : integer array of dimension (kwrk). used as workspace. c if the computation mode iopt(1)=1 is used the values of c iwrk(1),.,iwrk(5) should be left unchanged between subsequent c calls. c kwrk : integer. on entry kwrk must specify the actual dimension of c the array iwrk as declared in the calling (sub)program. c kwrk >= 5+mu+mv+nuest+nvest. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is an interpolating c spline (fp=0). c ier=-2 : normal return. the spline returned is the least-squares c constrained polynomial. in this extreme case fp gives the c upper bound for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameters nuest and c nvest. c probably causes : nuest or nvest too small. if these param- c eters are already large, it may also indicate that s is c too small c the approximation returned is the least-squares spline c according to the current set of knots. the parameter fp c gives the corresponding sum of squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c sum of squared residuals does not satisfy the condition c abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt(1)<=1, 0<=iopt(2)<=1, 0<=iopt(3)<=1, c -1<=ider(1)<=1, 0<=ider(2)<=1, ider(2)=0 if iopt(2)=0. c -1<=ider(3)<=1, 0<=ider(4)<=1, ider(4)=0 if iopt(3)=0. c mu >= mumin (see above), mv >= 4, nuest >=8, nvest >= 8, c kwrk>=5+mu+mv+nuest+nvest, c lwrk >= 12+nuest*(mv+nvest+3)+nvest*24+4*mu+8*mv+ c max(nuest,mv+nvest) c 0< u(i-1)=0: s>=0 c if s=0: nuest>=mu+6+iopt(2)+iopt(3), nvest>=mv+7 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c spgrid does not allow individual weighting of the data-values. c so, if these were determined to widely different accuracies, then c perhaps the general data set routine sphere should rather be used c in spite of efficiency. c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating spline if c s=0 and the constrained least-squares polynomial(degrees 3,0)if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the accuracy of the data values. c if the user has an idea of the statistical errors on the data, he c can also find a proper estimate for s. for, by assuming that, if he c specifies the right s, spgrid will return a spline s(u,v) which c exactly reproduces the function underlying the data he can evaluate c the sum((r(i,j)-s(u(i),v(j)))**2) to find a good estimate for this s c for example, if he knows that the statistical errors on his r(i,j)- c values is not greater than 0.1, he may expect that a good s should c have a value not larger than mu*mv*(0.1)**2. c if nothing is known about the statistical error in r(i,j), s must c be determined by trial and error, taking account of the comments c above. the best is then to start with a very large value of s (to c determine the least-squares polynomial and the corresponding upper c bound fp0 for s) and then to progressively decrease the value of s c ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,... c and more carefully as the approximation shows more detail) to c obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt(1)=0. c if iopt(1) = 1 the program will continue with the knots found at c the last call of the routine. this will save a lot of computation c time if spgrid is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. if the computation mode iopt(1) = 1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt(1)=1,the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c spgrid once more with the chosen value for s but now with iopt(1)=0. c indeed, spgrid may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c the number of knots may also depend on the upper bounds nuest and c nvest. indeed, if at a certain stage in spgrid the number of knots c in one direction (say nu) has reached the value of its upper bound c (nuest), then from that moment on all subsequent knots are added c in the other (v) direction. this may indicate that the value of c nuest is too small. on the other hand, it gives the user the option c of limiting the number of knots the routine locates in any direction c for example, by setting nuest=8 (the lowest allowable value for c nuest), the user can indicate that he wants an approximation which c is a simple cubic polynomial in the variable u. c c other subroutines required: c fpspgr,fpchec,fpchep,fpknot,fpopsp,fprati,fpgrsp,fpsysy,fpback, c fpbacp,fpbspl,fpcyt1,fpcyt2,fpdisc,fpgivs,fprota c c references: c dierckx p. : fast algorithms for smoothing data over a disc or a c sphere using tensor product splines, in "algorithms c for approximation", ed. j.c.mason and m.g.cox, c clarendon press oxford, 1987, pp. 51-65 c dierckx p. : fast algorithms for smoothing data over a disc or a c sphere using tensor product splines, report tw73, dept. c computer science,k.u.leuven, 1985. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : july 1985 c latest update : march 1989 c c .. c ..scalar arguments.. real r0,r1,s,fp integer mu,mv,nuest,nvest,nu,nv,lwrk,kwrk,ier c ..array arguments.. integer iopt(3),ider(4),iwrk(kwrk) real u(mu),v(mv),r(mu*mv),c((nuest-4)*(nvest-4)),tu(nuest), * tv(nvest),wrk(lwrk) c ..local scalars.. real per,pi,tol,uu,ve,rmax,rmin,one,half,rn,rb,re integer i,i1,i2,j,jwrk,j1,j2,kndu,kndv,knru,knrv,kwest,l, * ldr,lfpu,lfpv,lwest,lww,m,maxit,mumin,muu,nc c ..function references.. real atan2 integer max0 c ..subroutine references.. c fpchec,fpchep,fpspgr c .. c set constants one = 1 half = 0.5e0 pi = atan2(0.,-one) per = pi+pi ve = v(1)+per c we set up the parameters tol and maxit. maxit = 20 tol = 0.1e-02 c before starting computations, a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(iopt(1).lt.(-1) .or. iopt(1).gt.1) go to 200 if(iopt(2).lt.0 .or. iopt(2).gt.1) go to 200 if(iopt(3).lt.0 .or. iopt(3).gt.1) go to 200 if(ider(1).lt.(-1) .or. ider(1).gt.1) go to 200 if(ider(2).lt.0 .or. ider(2).gt.1) go to 200 if(ider(2).eq.1 .and. iopt(2).eq.0) go to 200 if(ider(3).lt.(-1) .or. ider(3).gt.1) go to 200 if(ider(4).lt.0 .or. ider(4).gt.1) go to 200 if(ider(4).eq.1 .and. iopt(3).eq.0) go to 200 mumin = 4 if(ider(1).ge.0) mumin = mumin-1 if(iopt(2).eq.1 .and. ider(2).eq.1) mumin = mumin-1 if(ider(3).ge.0) mumin = mumin-1 if(iopt(3).eq.1 .and. ider(4).eq.1) mumin = mumin-1 if(mumin.eq.0) mumin = 1 if(mu.lt.mumin .or. mv.lt.4) go to 200 if(nuest.lt.8 .or. nvest.lt.8) go to 200 m = mu*mv nc = (nuest-4)*(nvest-4) lwest = 12+nuest*(mv+nvest+3)+24*nvest+4*mu+8*mv+ * max0(nuest,mv+nvest) kwest = 5+mu+mv+nuest+nvest if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 200 if(u(1).le.0. .or. u(mu).ge.pi) go to 200 if(mu.eq.1) go to 30 do 20 i=2,mu if(u(i-1).ge.u(i)) go to 200 20 continue 30 if(v(1).lt. (-pi) .or. v(1).ge.pi ) go to 200 if(v(mv).ge.v(1)+per) go to 200 do 40 i=2,mv if(v(i-1).ge.v(i)) go to 200 40 continue if(iopt(1).gt.0) go to 140 c if not given, we compute an estimate for r0. rn = mv if(ider(1).lt.0) go to 45 rb = r0 go to 55 45 rb = 0. do 50 i=1,mv rb = rb+r(i) 50 continue rb = rb/rn c if not given, we compute an estimate for r1. 55 if(ider(3).lt.0) go to 60 re = r1 go to 70 60 re = 0. j = m do 65 i=1,mv re = re+r(j) j = j-1 65 continue re = re/rn c we determine the range of r-values. 70 rmin = rb rmax = re do 80 i=1,m if(r(i).lt.rmin) rmin = r(i) if(r(i).gt.rmax) rmax = r(i) 80 continue wrk(5) = rb wrk(6) = 0. wrk(7) = 0. wrk(8) = re wrk(9) = 0. wrk(10) = 0. wrk(11) = rmax -rmin wrk(12) = wrk(11) iwrk(4) = mu iwrk(5) = mu if(iopt(1).eq.0) go to 140 if(nu.lt.8 .or. nu.gt.nuest) go to 200 if(nv.lt.11 .or. nv.gt.nvest) go to 200 j = nu do 90 i=1,4 tu(i) = 0. tu(j) = pi j = j-1 90 continue l = 13 wrk(l) = 0. if(iopt(2).eq.0) go to 100 l = l+1 uu = u(1) if(uu.gt.tu(5)) uu = tu(5) wrk(l) = uu*half 100 do 110 i=1,mu l = l+1 wrk(l) = u(i) 110 continue if(iopt(3).eq.0) go to 120 l = l+1 uu = u(mu) if(uu.lt.tu(nu-4)) uu = tu(nu-4) wrk(l) = uu+(pi-uu)*half 120 l = l+1 wrk(l) = pi muu = l-12 call fpchec(wrk(13),muu,tu,nu,3,ier) if(ier.ne.0) go to 200 j1 = 4 tv(j1) = v(1) i1 = nv-3 tv(i1) = ve j2 = j1 i2 = i1 do 130 i=1,3 i1 = i1+1 i2 = i2-1 j1 = j1+1 j2 = j2-1 tv(j2) = tv(i2)-per tv(i1) = tv(j1)+per 130 continue l = 13 do 135 i=1,mv wrk(l) = v(i) l = l+1 135 continue wrk(l) = ve call fpchep(wrk(13),mv+1,tv,nv,3,ier) if(ier) 200,150,200 140 if(s.lt.0.) go to 200 if(s.eq.0. .and. (nuest.lt.(mu+6+iopt(2)+iopt(3)) .or. * nvest.lt.(mv+7)) ) go to 200 c we partition the working space and determine the spline approximation 150 ldr = 5 lfpu = 13 lfpv = lfpu+nuest lww = lfpv+nvest jwrk = lwrk-12-nuest-nvest knru = 6 knrv = knru+mu kndu = knrv+mv kndv = kndu+nuest call fpspgr(iopt,ider,u,mu,v,mv,r,m,rb,re,s,nuest,nvest,tol,maxit, * nc,nu,tu,nv,tv,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),wrk(lfpu), * wrk(lfpv),wrk(ldr),wrk(11),iwrk(1),iwrk(2),iwrk(3),iwrk(4), * iwrk(5),iwrk(knru),iwrk(knrv),iwrk(kndu),iwrk(kndv),wrk(lww), * jwrk,ier) 200 return end spd-1.3.0/fitpack/fpbisp.f0000644000175000017500000000343611633462461012311 00000000000000 subroutine fpbisp(tx,nx,ty,ny,c,kx,ky,x,mx,y,my,z,wx,wy,lx,ly) c ..scalar arguments.. integer nx,ny,kx,ky,mx,my c ..array arguments.. integer lx(mx),ly(my) real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(mx),y(my),z(mx*my), * wx(mx,kx+1),wy(my,ky+1) c ..local scalars.. integer kx1,ky1,l,l1,l2,m,nkx1,nky1 real arg,sp,tb,te c ..local arrays.. real h(6) c ..subroutine references.. c fpbspl c .. kx1 = kx+1 nkx1 = nx-kx1 tb = tx(kx1) te = tx(nkx1+1) l = kx1 l1 = l+1 do 40 i=1,mx arg = x(i) if(arg.lt.tb) arg = tb if(arg.gt.te) arg = te 10 if(arg.lt.tx(l1) .or. l.eq.nkx1) go to 20 l = l1 l1 = l+1 go to 10 20 call fpbspl(tx,nx,kx,arg,l,h) lx(i) = l-kx1 do 30 j=1,kx1 wx(i,j) = h(j) 30 continue 40 continue ky1 = ky+1 nky1 = ny-ky1 tb = ty(ky1) te = ty(nky1+1) l = ky1 l1 = l+1 do 80 i=1,my arg = y(i) if(arg.lt.tb) arg = tb if(arg.gt.te) arg = te 50 if(arg.lt.ty(l1) .or. l.eq.nky1) go to 60 l = l1 l1 = l+1 go to 50 60 call fpbspl(ty,ny,ky,arg,l,h) ly(i) = l-ky1 do 70 j=1,ky1 wy(i,j) = h(j) 70 continue 80 continue m = 0 do 130 i=1,mx l = lx(i)*nky1 do 90 i1=1,kx1 h(i1) = wx(i,i1) 90 continue do 120 j=1,my l1 = l+ly(j) sp = 0. do 110 i1=1,kx1 l2 = l1 do 100 j1=1,ky1 l2 = l2+1 sp = sp+c(l2)*h(i1)*wy(j,j1) 100 continue l1 = l1+nky1 110 continue m = m+1 z(m) = sp 120 continue 130 continue return end spd-1.3.0/fitpack/fprppo.f0000644000175000017500000000300311633462460012321 00000000000000 subroutine fprppo(nu,nv,if1,if2,cosi,ratio,c,f,ncoff) c given the coefficients of a constrained bicubic spline, as determined c in subroutine fppola, subroutine fprppo calculates the coefficients c in the standard b-spline representation of bicubic splines. c .. c ..scalar arguments.. real ratio integer nu,nv,if1,if2,ncoff c ..array arguments real c(ncoff),f(ncoff),cosi(5,nv) c ..local scalars.. integer i,iopt,ii,j,k,l,nu4,nvv c .. nu4 = nu-4 nvv = nv-7 iopt = if1+1 do 10 i=1,ncoff f(i) = 0. 10 continue i = 0 do 120 l=1,nu4 ii = i if(l.gt.iopt) go to 80 go to (20,40,60),l 20 do 30 k=1,nvv i = i+1 f(i) = c(1) 30 continue j = 1 go to 100 40 do 50 k=1,nvv i = i+1 f(i) = c(1)+c(2)*cosi(1,k)+c(3)*cosi(2,k) 50 continue j = 3 go to 100 60 do 70 k=1,nvv i = i+1 f(i) = c(1)+ratio*(c(2)*cosi(1,k)+c(3)*cosi(2,k))+ * c(4)*cosi(3,k)+c(5)*cosi(4,k)+c(6)*cosi(5,k) 70 continue j = 6 go to 100 80 if(l.eq.nu4 .and. if2.ne.0) go to 120 do 90 k=1,nvv i = i+1 j = j+1 f(i) = c(j) 90 continue 100 do 110 k=1,3 ii = ii+1 i = i+1 f(i) = f(ii) 110 continue 120 continue do 130 i=1,ncoff c(i) = f(i) 130 continue return end spd-1.3.0/fitpack/fpgrsp.f0000644000175000017500000004643011633462460012327 00000000000000 subroutine fpgrsp(ifsu,ifsv,ifbu,ifbv,iback,u,mu,v,mv,r,mr,dr, * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,spu,spv, * right,q,au,av1,av2,bu,bv,a0,a1,b0,b1,c0,c1,cosi,nru,nrv) c .. c ..scalar arguments.. real p,sq,fp integer ifsu,ifsv,ifbu,ifbv,iback,mu,mv,mr,iop0,iop1,nu,nv,nc, * mm,mvnu c ..array arguments.. real u(mu),v(mv),r(mr),dr(6),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv), * spu(mu,4),spv(mv,4),right(mm),q(mvnu),au(nu,5),av1(nv,6),c0(nv), * av2(nv,4),a0(2,mv),b0(2,nv),cosi(2,nv),bu(nu,5),bv(nv,5),c1(nv), * a1(2,mv),b1(2,nv) integer nru(mu),nrv(mv) c ..local scalars.. real arg,co,dr01,dr02,dr03,dr11,dr12,dr13,fac,fac0,fac1,pinv,piv, * si,term,one,three,half integer i,ic,ii,ij,ik,iq,irot,it,ir,i0,i1,i2,i3,j,jj,jk,jper, * j0,j1,k,k1,k2,l,l0,l1,l2,mvv,ncof,nrold,nroldu,nroldv,number, * numu,numu1,numv,numv1,nuu,nu4,nu7,nu8,nu9,nv11,nv4,nv7,nv8,n1 c ..local arrays.. real h(5),h1(5),h2(4) c ..function references.. integer min0 real cos,sin c ..subroutine references.. c fpback,fpbspl,fpgivs,fpcyt1,fpcyt2,fpdisc,fpbacp,fprota c .. c let c | (spu) | | (spv) | c (au) = | -------------- | (av) = | -------------- | c | sqrt(1/p) (bu) | | sqrt(1/p) (bv) | c c | r ' 0 | c q = | ------ | c | 0 ' 0 | c c with c : the (nu-4) x (nv-4) matrix which contains the b-spline c coefficients. c r : the mu x mv matrix which contains the function values. c spu,spv: the mu x (nu-4), resp. mv x (nv-4) observation matrices c according to the least-squares problems in the u-,resp. c v-direction. c bu,bv : the (nu-7) x (nu-4),resp. (nv-7) x (nv-4) matrices c containing the discontinuity jumps of the derivatives c of the b-splines in the u-,resp.v-variable at the knots c the b-spline coefficients of the smoothing spline are then calculated c as the least-squares solution of the following over-determined linear c system of equations c c (1) (av) c (au)' = q c c subject to the constraints c c (2) c(i,nv-3+j) = c(i,j), j=1,2,3 ; i=1,2,...,nu-4 c c (3) if iop0 = 0 c(1,j) = dr(1) c iop0 = 1 c(1,j) = dr(1) c c(2,j) = dr(1)+(dr(2)*cosi(1,j)+dr(3)*cosi(2,j))* c tu(5)/3. = c0(j) , j=1,2,...nv-4 c c (4) if iop1 = 0 c(nu-4,j) = dr(4) c iop1 = 1 c(nu-4,j) = dr(4) c c(nu-5,j) = dr(4)+(dr(5)*cosi(1,j)+dr(6)*cosi(2,j)) c *(tu(nu-4)-tu(nu-3))/3. = c1(j) c c set constants one = 1 three = 3 half = 0.5 c initialization nu4 = nu-4 nu7 = nu-7 nu8 = nu-8 nu9 = nu-9 nv4 = nv-4 nv7 = nv-7 nv8 = nv-8 nv11 = nv-11 nuu = nu4-iop0-iop1-2 if(p.gt.0.) pinv = one/p c it depends on the value of the flags ifsu,ifsv,ifbu,ifbv,iop0,iop1 c and on the value of p whether the matrices (spu), (spv), (bu), (bv), c (cosi) still must be determined. if(ifsu.ne.0) go to 30 c calculate the non-zero elements of the matrix (spu) which is the ob- c servation matrix according to the least-squares spline approximation c problem in the u-direction. l = 4 l1 = 5 number = 0 do 25 it=1,mu arg = u(it) 10 if(arg.lt.tu(l1) .or. l.eq.nu4) go to 15 l = l1 l1 = l+1 number = number+1 go to 10 15 call fpbspl(tu,nu,3,arg,l,h) do 20 i=1,4 spu(it,i) = h(i) 20 continue nru(it) = number 25 continue ifsu = 1 c calculate the non-zero elements of the matrix (spv) which is the ob- c servation matrix according to the least-squares spline approximation c problem in the v-direction. 30 if(ifsv.ne.0) go to 85 l = 4 l1 = 5 number = 0 do 50 it=1,mv arg = v(it) 35 if(arg.lt.tv(l1) .or. l.eq.nv4) go to 40 l = l1 l1 = l+1 number = number+1 go to 35 40 call fpbspl(tv,nv,3,arg,l,h) do 45 i=1,4 spv(it,i) = h(i) 45 continue nrv(it) = number 50 continue ifsv = 1 if(iop0.eq.0 .and. iop1.eq.0) go to 85 c calculate the coefficients of the interpolating splines for cos(v) c and sin(v). do 55 i=1,nv4 cosi(1,i) = 0. cosi(2,i) = 0. 55 continue if(nv7.lt.4) go to 85 do 65 i=1,nv7 l = i+3 arg = tv(l) call fpbspl(tv,nv,3,arg,l,h) do 60 j=1,3 av1(i,j) = h(j) 60 continue cosi(1,i) = cos(arg) cosi(2,i) = sin(arg) 65 continue call fpcyt1(av1,nv7,nv) do 80 j=1,2 do 70 i=1,nv7 right(i) = cosi(j,i) 70 continue call fpcyt2(av1,nv7,right,right,nv) do 75 i=1,nv7 cosi(j,i+1) = right(i) 75 continue cosi(j,1) = cosi(j,nv7+1) cosi(j,nv7+2) = cosi(j,2) cosi(j,nv4) = cosi(j,3) 80 continue 85 if(p.le.0.) go to 150 c calculate the non-zero elements of the matrix (bu). if(ifbu.ne.0 .or. nu8.eq.0) go to 90 call fpdisc(tu,nu,5,bu,nu) ifbu = 1 c calculate the non-zero elements of the matrix (bv). 90 if(ifbv.ne.0 .or. nv8.eq.0) go to 150 call fpdisc(tv,nv,5,bv,nv) ifbv = 1 c substituting (2),(3) and (4) into (1), we obtain the overdetermined c system c (5) (avv) (cc) (auu)' = (qq) c from which the nuu*nv7 remaining coefficients c c(i,j) , i=2+iop0,3+iop0,...,nu-5-iop1,j=1,2,...,nv-7. c the elements of (cc), are then determined in the least-squares sense. c simultaneously, we compute the resulting sum of squared residuals sq. 150 dr01 = dr(1) dr11 = dr(4) do 155 i=1,mv a0(1,i) = dr01 a1(1,i) = dr11 155 continue if(nv8.eq.0 .or. p.le.0.) go to 165 do 160 i=1,nv8 b0(1,i) = 0. b1(1,i) = 0. 160 continue 165 mvv = mv if(iop0.eq.0) go to 195 fac = (tu(5)-tu(4))/three dr02 = dr(2)*fac dr03 = dr(3)*fac do 170 i=1,nv4 c0(i) = dr01+dr02*cosi(1,i)+dr03*cosi(2,i) 170 continue do 180 i=1,mv number = nrv(i) fac = 0. do 175 j=1,4 number = number+1 fac = fac+c0(number)*spv(i,j) 175 continue a0(2,i) = fac 180 continue if(nv8.eq.0 .or. p.le.0.) go to 195 do 190 i=1,nv8 number = i fac = 0. do 185 j=1,5 fac = fac+c0(number)*bv(i,j) number = number+1 185 continue b0(2,i) = fac*pinv 190 continue mvv = mv+nv8 195 if(iop1.eq.0) go to 225 fac = (tu(nu4)-tu(nu4+1))/three dr12 = dr(5)*fac dr13 = dr(6)*fac do 200 i=1,nv4 c1(i) = dr11+dr12*cosi(1,i)+dr13*cosi(2,i) 200 continue do 210 i=1,mv number = nrv(i) fac = 0. do 205 j=1,4 number = number+1 fac = fac+c1(number)*spv(i,j) 205 continue a1(2,i) = fac 210 continue if(nv8.eq.0 .or. p.le.0.) go to 225 do 220 i=1,nv8 number = i fac = 0. do 215 j=1,5 fac = fac+c1(number)*bv(i,j) number = number+1 215 continue b1(2,i) = fac*pinv 220 continue mvv = mv+nv8 c we first determine the matrices (auu) and (qq). then we reduce the c matrix (auu) to an unit upper triangular form (ru) using givens c rotations without square roots. we apply the same transformations to c the rows of matrix qq to obtain the mv x nuu matrix g. c we store matrix (ru) into au and g into q. 225 l = mvv*nuu c initialization. sq = 0. if(l.eq.0) go to 245 do 230 i=1,l q(i) = 0. 230 continue do 240 i=1,nuu do 240 j=1,5 au(i,j) = 0. 240 continue l = 0 245 nrold = 0 n1 = nrold+1 do 420 it=1,mu number = nru(it) c find the appropriate column of q. 250 do 260 j=1,mvv right(j) = 0. 260 continue if(nrold.eq.number) go to 280 if(p.le.0.) go to 410 c fetch a new row of matrix (bu). do 270 j=1,5 h(j) = bu(n1,j)*pinv 270 continue i0 = 1 i1 = 5 go to 310 c fetch a new row of matrix (spu). 280 do 290 j=1,4 h(j) = spu(it,j) 290 continue c find the appropriate column of q. do 300 j=1,mv l = l+1 right(j) = r(l) 300 continue i0 = 1 i1 = 4 310 j0 = n1 j1 = nu7-number c take into account that we eliminate the constraints (3) 315 if(j0-1.gt.iop0) go to 335 fac0 = h(i0) do 320 j=1,mv right(j) = right(j)-fac0*a0(j0,j) 320 continue if(mv.eq.mvv) go to 330 j = mv do 325 jj=1,nv8 j = j+1 right(j) = right(j)-fac0*b0(j0,jj) 325 continue 330 j0 = j0+1 i0 = i0+1 go to 315 c take into account that we eliminate the constraints (4) 335 if(j1-1.gt.iop1) go to 360 fac1 = h(i1) do 340 j=1,mv right(j) = right(j)-fac1*a1(j1,j) 340 continue if(mv.eq.mvv) go to 350 j = mv do 345 jj=1,nv8 j = j+1 right(j) = right(j)-fac1*b1(j1,jj) 345 continue 350 j1 = j1+1 i1 = i1-1 go to 335 360 irot = nrold-iop0-1 if(irot.lt.0) irot = 0 c rotate the new row of matrix (auu) into triangle. if(i0.gt.i1) go to 390 do 385 i=i0,i1 irot = irot+1 piv = h(i) if(piv.eq.0.) go to 385 c calculate the parameters of the givens transformation. call fpgivs(piv,au(irot,1),co,si) c apply that transformation to the rows of matrix (qq). iq = (irot-1)*mvv do 370 j=1,mvv iq = iq+1 call fprota(co,si,right(j),q(iq)) 370 continue c apply that transformation to the columns of (auu). if(i.eq.i1) go to 385 i2 = 1 i3 = i+1 do 380 j=i3,i1 i2 = i2+1 call fprota(co,si,h(j),au(irot,i2)) 380 continue 385 continue c we update the sum of squared residuals. 390 do 395 j=1,mvv sq = sq+right(j)**2 395 continue 400 if(nrold.eq.number) go to 420 410 nrold = n1 n1 = n1+1 go to 250 420 continue if(nuu.eq.0) go to 800 c we determine the matrix (avv) and then we reduce her to an unit c upper triangular form (rv) using givens rotations without square c roots. we apply the same transformations to the columns of matrix c g to obtain the (nv-7) x (nu-6-iop0-iop1) matrix h. c we store matrix (rv) into av1 and av2, h into c. c the nv7 x nv7 triangular unit upper matrix (rv) has the form c | av1 ' | c (rv) = | ' av2 | c | 0 ' | c with (av2) a nv7 x 4 matrix and (av1) a nv11 x nv11 unit upper c triangular matrix of bandwidth 5. ncof = nuu*nv7 c initialization. do 430 i=1,ncof c(i) = 0. 430 continue do 440 i=1,nv4 av1(i,5) = 0. do 440 j=1,4 av1(i,j) = 0. av2(i,j) = 0. 440 continue jper = 0 nrold = 0 do 770 it=1,mv number = nrv(it) 450 if(nrold.eq.number) go to 480 if(p.le.0.) go to 760 c fetch a new row of matrix (bv). n1 = nrold+1 do 460 j=1,5 h(j) = bv(n1,j)*pinv 460 continue c find the appropiate row of g. do 465 j=1,nuu right(j) = 0. 465 continue if(mv.eq.mvv) go to 510 l = mv+n1 do 470 j=1,nuu right(j) = q(l) l = l+mvv 470 continue go to 510 c fetch a new row of matrix (spv) 480 h(5) = 0. do 490 j=1,4 h(j) = spv(it,j) 490 continue c find the appropiate row of g. l = it do 500 j=1,nuu right(j) = q(l) l = l+mvv 500 continue c test whether there are non-zero values in the new row of (avv) c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4. 510 if(nrold.lt.nv11) go to 710 if(jper.ne.0) go to 550 c initialize the matrix (av2). jk = nv11+1 do 540 i=1,4 ik = jk do 520 j=1,5 if(ik.le.0) go to 530 av2(ik,i) = av1(ik,j) ik = ik-1 520 continue 530 jk = jk+1 540 continue jper = 1 c if one of the non-zero elements of the new row corresponds to one of c the b-splines n(j;v),j=nv7+1,...,nv4, we take account of condition c (2) for setting up this row of (avv). the row is stored in h1( the c part with respect to av1) and h2 (the part with respect to av2). 550 do 560 i=1,4 h1(i) = 0. h2(i) = 0. 560 continue h1(5) = 0. j = nrold-nv11 do 600 i=1,5 j = j+1 l0 = j 570 l1 = l0-4 if(l1.le.0) go to 590 if(l1.le.nv11) go to 580 l0 = l1-nv11 go to 570 580 h1(l1) = h(i) go to 600 590 h2(l0) = h2(l0) + h(i) 600 continue c rotate the new row of (avv) into triangle. if(nv11.le.0) go to 670 c rotations with the rows 1,2,...,nv11 of (avv). do 660 j=1,nv11 piv = h1(1) i2 = min0(nv11-j,4) if(piv.eq.0.) go to 640 c calculate the parameters of the givens transformation. call fpgivs(piv,av1(j,1),co,si) c apply that transformation to the columns of matrix g. ic = j do 610 i=1,nuu call fprota(co,si,right(i),c(ic)) ic = ic+nv7 610 continue c apply that transformation to the rows of (avv) with respect to av2. do 620 i=1,4 call fprota(co,si,h2(i),av2(j,i)) 620 continue c apply that transformation to the rows of (avv) with respect to av1. if(i2.eq.0) go to 670 do 630 i=1,i2 i1 = i+1 call fprota(co,si,h1(i1),av1(j,i1)) 630 continue 640 do 650 i=1,i2 h1(i) = h1(i+1) 650 continue h1(i2+1) = 0. 660 continue c rotations with the rows nv11+1,...,nv7 of avv. 670 do 700 j=1,4 ij = nv11+j if(ij.le.0) go to 700 piv = h2(j) if(piv.eq.0.) go to 700 c calculate the parameters of the givens transformation. call fpgivs(piv,av2(ij,j),co,si) c apply that transformation to the columns of matrix g. ic = ij do 680 i=1,nuu call fprota(co,si,right(i),c(ic)) ic = ic+nv7 680 continue if(j.eq.4) go to 700 c apply that transformation to the rows of (avv) with respect to av2. j1 = j+1 do 690 i=j1,4 call fprota(co,si,h2(i),av2(ij,i)) 690 continue 700 continue c we update the sum of squared residuals. do 705 i=1,nuu sq = sq+right(i)**2 705 continue go to 750 c rotation into triangle of the new row of (avv), in case the elements c corresponding to the b-splines n(j;v),j=nv7+1,...,nv4 are all zero. 710 irot =nrold do 740 i=1,5 irot = irot+1 piv = h(i) if(piv.eq.0.) go to 740 c calculate the parameters of the givens transformation. call fpgivs(piv,av1(irot,1),co,si) c apply that transformation to the columns of matrix g. ic = irot do 720 j=1,nuu call fprota(co,si,right(j),c(ic)) ic = ic+nv7 720 continue c apply that transformation to the rows of (avv). if(i.eq.5) go to 740 i2 = 1 i3 = i+1 do 730 j=i3,5 i2 = i2+1 call fprota(co,si,h(j),av1(irot,i2)) 730 continue 740 continue c we update the sum of squared residuals. do 745 i=1,nuu sq = sq+right(i)**2 745 continue 750 if(nrold.eq.number) go to 770 760 nrold = nrold+1 go to 450 770 continue c test whether the b-spline coefficients must be determined. if(iback.ne.0) return c backward substitution to obtain the b-spline coefficients as the c solution of the linear system (rv) (cr) (ru)' = h. c first step: solve the system (rv) (c1) = h. k = 1 do 780 i=1,nuu call fpbacp(av1,av2,c(k),nv7,4,c(k),5,nv) k = k+nv7 780 continue c second step: solve the system (cr) (ru)' = (c1). k = 0 do 795 j=1,nv7 k = k+1 l = k do 785 i=1,nuu right(i) = c(l) l = l+nv7 785 continue call fpback(au,right,nuu,5,right,nu) l = k do 790 i=1,nuu c(l) = right(i) l = l+nv7 790 continue 795 continue c calculate from the conditions (2)-(3)-(4), the remaining b-spline c coefficients. 800 ncof = nu4*nv4 j = ncof do 805 l=1,nv4 q(l) = dr01 q(j) = dr11 j = j-1 805 continue i = nv4 j = 0 if(iop0.eq.0) go to 815 do 810 l=1,nv4 i = i+1 q(i) = c0(l) 810 continue 815 if(nuu.eq.0) go to 835 do 830 l=1,nuu ii = i do 820 k=1,nv7 i = i+1 j = j+1 q(i) = c(j) 820 continue do 825 k=1,3 ii = ii+1 i = i+1 q(i) = q(ii) 825 continue 830 continue 835 if(iop1.eq.0) go to 845 do 840 l=1,nv4 i = i+1 q(i) = c1(l) 840 continue 845 do 850 i=1,ncof c(i) = q(i) 850 continue c calculate the quantities c res(i,j) = (r(i,j) - s(u(i),v(j)))**2 , i=1,2,..,mu;j=1,2,..,mv c fp = sumi=1,mu(sumj=1,mv(res(i,j))) c fpu(r) = sum''i(sumj=1,mv(res(i,j))) , r=1,2,...,nu-7 c tu(r+3) <= u(i) <= tu(r+4) c fpv(r) = sumi=1,mu(sum''j(res(i,j))) , r=1,2,...,nv-7 c tv(r+3) <= v(j) <= tv(r+4) fp = 0. do 890 i=1,nu fpu(i) = 0. 890 continue do 900 i=1,nv fpv(i) = 0. 900 continue ir = 0 nroldu = 0 c main loop for the different grid points. do 950 i1=1,mu numu = nru(i1) numu1 = numu+1 nroldv = 0 do 940 i2=1,mv numv = nrv(i2) numv1 = numv+1 ir = ir+1 c evaluate s(u,v) at the current grid point by making the sum of the c cross products of the non-zero b-splines at (u,v), multiplied with c the appropiate b-spline coefficients. term = 0. k1 = numu*nv4+numv do 920 l1=1,4 k2 = k1 fac = spu(i1,l1) do 910 l2=1,4 k2 = k2+1 term = term+fac*spv(i2,l2)*c(k2) 910 continue k1 = k1+nv4 920 continue c calculate the squared residual at the current grid point. term = (r(ir)-term)**2 c adjust the different parameters. fp = fp+term fpu(numu1) = fpu(numu1)+term fpv(numv1) = fpv(numv1)+term fac = term*half if(numv.eq.nroldv) go to 930 fpv(numv1) = fpv(numv1)-fac fpv(numv) = fpv(numv)+fac 930 nroldv = numv if(numu.eq.nroldu) go to 940 fpu(numu1) = fpu(numu1)-fac fpu(numu) = fpu(numu)+fac 940 continue nroldu = numu 950 continue return end spd-1.3.0/fitpack/curev.f0000644000175000017500000000655011633462460012151 00000000000000 subroutine curev(idim,t,n,c,nc,k,u,m,x,mx,ier) c subroutine curev evaluates in a number of points u(i),i=1,2,...,m c a spline curve s(u) of degree k and dimension idim, given in its c b-spline representation. c c calling sequence: c call curev(idim,t,n,c,nc,k,u,m,x,mx,ier) c c input parameters: c idim : integer, giving the dimension of the spline curve. c t : array,length n, which contains the position of the knots. c n : integer, giving the total number of knots of s(u). c c : array,length nc, which contains the b-spline coefficients. c nc : integer, giving the total number of coefficients of s(u). c k : integer, giving the degree of s(u). c u : array,length m, which contains the points where s(u) must c be evaluated. c m : integer, giving the number of points where s(u) must be c evaluated. c mx : integer, giving the dimension of the array x. mx >= m*idim c c output parameters: c x : array,length mx,giving the value of s(u) at the different c points. x(idim*(i-1)+j) will contain the j-th coordinate c of the i-th point on the curve. c ier : error flag c ier = 0 : normal return c ier =10 : invalid input data (see restrictions) c c restrictions: c m >= 1 c mx >= m*idim c t(k+1) <= u(i) <= u(i+1) <= t(n-k) , i=1,2,...,m-1. c c other subroutines required: fpbspl. c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer idim,n,nc,k,m,mx,ier c ..array arguments.. real t(n),c(nc),u(m),x(mx) c ..local scalars.. integer i,j,jj,j1,k1,l,ll,l1,mm,nk1 real arg,sp,tb,te c ..local array.. real h(6) c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 if(m-1) 100,30,10 10 do 20 i=2,m if(u(i).lt.u(i-1)) go to 100 20 continue 30 if(mx.lt.(m*idim)) go to 100 ier = 0 c fetch tb and te, the boundaries of the approximation interval. k1 = k+1 nk1 = n-k1 tb = t(k1) te = t(nk1+1) l = k1 l1 = l+1 c main loop for the different points. mm = 0 do 80 i=1,m c fetch a new u-value arg. arg = u(i) if(arg.lt.tb) arg = tb if(arg.gt.te) arg = te c search for knot interval t(l) <= arg < t(l+1) 40 if(arg.lt.t(l1) .or. l.eq.nk1) go to 50 l = l1 l1 = l+1 go to 40 c evaluate the non-zero b-splines at arg. 50 call fpbspl(t,n,k,arg,l,h) c find the value of s(u) at u=arg. ll = l-k1 do 70 j1=1,idim jj = ll sp = 0. do 60 j=1,k1 jj = jj+1 sp = sp+c(jj)*h(j) 60 continue mm = mm+1 x(mm) = sp ll = ll+n 70 continue 80 continue 100 return end spd-1.3.0/fitpack/curfit.f0000644000175000017500000003275411633462461012327 00000000000000 subroutine curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp, * wrk,lwrk,iwrk,ier) c given the set of data points (x(i),y(i)) and the set of positive c numbers w(i),i=1,2,...,m,subroutine curfit determines a smooth spline c approximation of degree k on the interval xb <= x <= xe. c if iopt=-1 curfit calculates the weighted least-squares spline c according to a given set of knots. c if iopt>=0 the number of knots of the spline s(x) and the position c t(j),j=1,2,...,n is chosen automatically by the routine. the smooth- c ness of s(x) is then achieved by minimalizing the discontinuity c jumps of the k-th derivative of s(x) at the knots t(j),j=k+2,k+3,..., c n-k-1. the amount of smoothness is determined by the condition that c f(p)=sum((w(i)*(y(i)-s(x(i))))**2) be <= s, with s a given non- c negative constant, called the smoothing factor. c the fit s(x) is given in the b-spline representation (b-spline coef- c ficients c(j),j=1,2,...,n-k-1) and can be evaluated by means of c subroutine splev. c c calling sequence: c call curfit(iopt,m,x,y,w,xb,xe,k,s,nest,n,t,c,fp,wrk, c * lwrk,iwrk,ier) c c parameters: c iopt : integer flag. on entry iopt must specify whether a weighted c least-squares spline (iopt=-1) or a smoothing spline (iopt= c 0 or 1) must be determined. if iopt=0 the routine will start c with an initial set of knots t(i)=xb, t(i+k+1)=xe, i=1,2,... c k+1. if iopt=1 the routine will continue with the knots c found at the last call of the routine. c attention: a call with iopt=1 must always be immediately c preceded by another call with iopt=1 or iopt=0. c unchanged on exit. c m : integer. on entry m must specify the number of data points. c m > k. unchanged on exit. c x : real array of dimension at least (m). before entry, x(i) c must be set to the i-th value of the independent variable x, c for i=1,2,...,m. these values must be supplied in strictly c ascending order. unchanged on exit. c y : real array of dimension at least (m). before entry, y(i) c must be set to the i-th value of the dependent variable y, c for i=1,2,...,m. unchanged on exit. c w : real array of dimension at least (m). before entry, w(i) c must be set to the i-th value in the set of weights. the c w(i) must be strictly positive. unchanged on exit. c see also further comments. c xb,xe : real values. on entry xb and xe must specify the boundaries c of the approximation interval. xb<=x(1), xe>=x(m). c unchanged on exit. c k : integer. on entry k must specify the degree of the spline. c 1<=k<=5. it is recommended to use cubic splines (k=3). c the user is strongly dissuaded from choosing k even,together c with a small s-value. unchanged on exit. c s : real.on entry (in case iopt>=0) s must specify the smoothing c factor. s >=0. unchanged on exit. c for advice on the choice of s see further comments. c nest : integer. on entry nest must contain an over-estimate of the c total number of knots of the spline returned, to indicate c the storage space available to the routine. nest >=2*k+2. c in most practical situation nest=m/2 will be sufficient. c always large enough is nest=m+k+1, the number of knots c needed for interpolation (s=0). unchanged on exit. c n : integer. c unless ier =10 (in case iopt >=0), n will contain the c total number of knots of the spline approximation returned. c if the computation mode iopt=1 is used this value of n c should be left unchanged between subsequent calls. c in case iopt=-1, the value of n must be specified on entry. c t : real array of dimension at least (nest). c on succesful exit, this array will contain the knots of the c spline,i.e. the position of the interior knots t(k+2),t(k+3) c ...,t(n-k-1) as well as the position of the additional knots c t(1)=t(2)=...=t(k+1)=xb and t(n-k)=...=t(n)=xe needed for c the b-spline representation. c if the computation mode iopt=1 is used, the values of t(1), c t(2),...,t(n) should be left unchanged between subsequent c calls. if the computation mode iopt=-1 is used, the values c t(k+2),...,t(n-k-1) must be supplied by the user, before c entry. see also the restrictions (ier=10). c c : real array of dimension at least (nest). c on succesful exit, this array will contain the coefficients c c(1),c(2),..,c(n-k-1) in the b-spline representation of s(x) c fp : real. unless ier=10, fp contains the weighted sum of c squared residuals of the spline approximation returned. c wrk : real array of dimension at least (m*(k+1)+nest*(7+3*k)). c used as working space. if the computation mode iopt=1 is c used, the values wrk(1),...,wrk(n) should be left unchanged c between subsequent calls. c lwrk : integer. on entry,lwrk must specify the actual dimension of c the array wrk as declared in the calling (sub)program.lwrk c must not be too small (see wrk). unchanged on exit. c iwrk : integer array of dimension at least (nest). c used as working space. if the computation mode iopt=1 is c used,the values iwrk(1),...,iwrk(n) should be left unchanged c between subsequent calls. c ier : integer. unless the routine detects an error, ier contains a c non-positive value on exit, i.e. c ier=0 : normal return. the spline returned has a residual sum of c squares fp such that abs(fp-s)/s <= tol with tol a relat- c ive tolerance set to 0.001 by the program. c ier=-1 : normal return. the spline returned is an interpolating c spline (fp=0). c ier=-2 : normal return. the spline returned is the weighted least- c squares polynomial of degree k. in this extreme case fp c gives the upper bound fp0 for the smoothing factor s. c ier=1 : error. the required storage space exceeds the available c storage space, as specified by the parameter nest. c probably causes : nest too small. if nest is already c large (say nest > m/2), it may also indicate that s is c too small c the approximation returned is the weighted least-squares c spline according to the knots t(1),t(2),...,t(n). (n=nest) c the parameter fp gives the corresponding weighted sum of c squared residuals (fp>s). c ier=2 : error. a theoretically impossible result was found during c the iteration proces for finding a smoothing spline with c fp = s. probably causes : s too small. c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=3 : error. the maximal number of iterations maxit (set to 20 c by the program) allowed for finding a smoothing spline c with fp=s has been reached. probably causes : s too small c there is an approximation returned but the corresponding c weighted sum of squared residuals does not satisfy the c condition abs(fp-s)/s < tol. c ier=10 : error. on entry, the input data are controlled on validity c the following restrictions must be satisfied. c -1<=iopt<=1, 1<=k<=5, m>k, nest>2*k+2, w(i)>0,i=1,2,...,m c xb<=x(1)=(k+1)*m+nest*(7+3*k) c if iopt=-1: 2*k+2<=n<=min(nest,m+k+1) c xb=0: s>=0 c if s=0 : nest >= m+k+1 c if one of these conditions is found to be violated,control c is immediately repassed to the calling program. in that c case there is no approximation returned. c c further comments: c by means of the parameter s, the user can control the tradeoff c between closeness of fit and smoothness of fit of the approximation. c if s is too large, the spline will be too smooth and signal will be c lost ; if s is too small the spline will pick up too much noise. in c the extreme cases the program will return an interpolating spline if c s=0 and the weighted least-squares polynomial of degree k if s is c very large. between these extremes, a properly chosen s will result c in a good compromise between closeness of fit and smoothness of fit. c to decide whether an approximation, corresponding to a certain s is c satisfactory the user is highly recommended to inspect the fits c graphically. c recommended values for s depend on the weights w(i). if these are c taken as 1/d(i) with d(i) an estimate of the standard deviation of c y(i), a good s-value should be found in the range (m-sqrt(2*m),m+ c sqrt(2*m)). if nothing is known about the statistical error in y(i) c each w(i) can be set equal to one and s determined by trial and c error, taking account of the comments above. the best is then to c start with a very large value of s ( to determine the least-squares c polynomial and the corresponding upper bound fp0 for s) and then to c progressively decrease the value of s ( say by a factor 10 in the c beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the c approximation shows more detail) to obtain closer fits. c to economize the search for a good s-value the program provides with c different modes of computation. at the first call of the routine, or c whenever he wants to restart with the initial set of knots the user c must set iopt=0. c if iopt=1 the program will continue with the set of knots found at c the last call of the routine. this will save a lot of computation c time if curfit is called repeatedly for different values of s. c the number of knots of the spline returned and their location will c depend on the value of s and on the complexity of the shape of the c function underlying the data. but, if the computation mode iopt=1 c is used, the knots returned may also depend on the s-values at c previous calls (if these were smaller). therefore, if after a number c of trials with different s-values and iopt=1, the user can finally c accept a fit as satisfactory, it may be worthwhile for him to call c curfit once more with the selected value for s but now with iopt=0. c indeed, curfit may then return an approximation of the same quality c of fit but with fewer knots and therefore better if data reduction c is also an important objective for the user. c c other subroutines required: c fpback,fpbspl,fpchec,fpcurf,fpdisc,fpgivs,fpknot,fprati,fprota c c references: c dierckx p. : an algorithm for smoothing, differentiation and integ- c ration of experimental data using spline functions, c j.comp.appl.maths 1 (1975) 165-184. c dierckx p. : a fast algorithm for smoothing data on a rectangular c grid while using spline functions, siam j.numer.anal. c 19 (1982) 1286-1304. c dierckx p. : an improved algorithm for curve fitting with spline c functions, report tw54, dept. computer science,k.u. c leuven, 1981. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author: c p.dierckx c dept. computer science, k.u. leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c creation date : may 1979 c latest update : march 1987 c c .. c ..scalar arguments.. real xb,xe,s,fp integer iopt,m,k,nest,n,lwrk,ier c ..array arguments.. real x(m),y(m),w(m),t(nest),c(nest),wrk(lwrk) integer iwrk(nest) c ..local scalars.. real tol integer i,ia,ib,ifp,ig,iq,iz,j,k1,k2,lwest,maxit,nmin c .. c we set up the parameters tol and maxit maxit = 20 tol = 0.1e-02 c before starting computations a data check is made. if the input data c are invalid, control is immediately repassed to the calling program. ier = 10 if(k.le.0 .or. k.gt.5) go to 50 k1 = k+1 k2 = k1+1 if(iopt.lt.(-1) .or. iopt.gt.1) go to 50 nmin = 2*k1 if(m.lt.k1 .or. nest.lt.nmin) go to 50 lwest = m*k1+nest*(7+3*k) if(lwrk.lt.lwest) go to 50 if(xb.gt.x(1) .or. xe.lt.x(m) .or. w(1).le.0.) go to 50 do 10 i=2,m if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 50 10 continue if(iopt.ge.0) go to 30 if(n.lt.nmin .or. n.gt.nest) go to 50 j = n do 20 i=1,k1 t(i) = xb t(j) = xe j = j-1 20 continue call fpchec(x,m,t,n,k,ier) if(ier) 50,40,50 30 if(s.lt.0.) go to 50 if(s.eq.0. .and. nest.lt.(m+k1)) go to 50 ier = 0 c we partition the working space and determine the spline approximation. 40 ifp = 1 iz = ifp+nest ia = iz+nest ib = ia+nest*k1 ig = ib+nest*k2 iq = ig+nest*k2 call fpcurf(iopt,x,y,w,m,xb,xe,k,s,nest,tol,maxit,k1,k2,n,t,c,fp, * wrk(ifp),wrk(iz),wrk(ia),wrk(ib),wrk(ig),wrk(iq),iwrk,ier) 50 return end spd-1.3.0/fitpack/spalde.f0000644000175000017500000000446411633462461012300 00000000000000 subroutine spalde(t,n,c,k1,x,d,ier) c subroutine spalde evaluates at a point x all the derivatives c (j-1) c d(j) = s (x) , j=1,2,...,k1 c of a spline s(x) of order k1 (degree k=k1-1), given in its b-spline c representation. c c calling sequence: c call spalde(t,n,c,k1,x,d,ier) c c input parameters: c t : array,length n, which contains the position of the knots. c n : integer, giving the total number of knots of s(x). c c : array,length n, which contains the b-spline coefficients. c k1 : integer, giving the order of s(x) (order=degree+1) c x : real, which contains the point where the derivatives must c be evaluated. c c output parameters: c d : array,length k1, containing the derivative values of s(x). c ier : error flag c ier = 0 : normal return c ier =10 : invalid input data (see restrictions) c c restrictions: c t(k1) <= x <= t(n-k1+1) c c further comments: c if x coincides with a knot, right derivatives are computed c ( left derivatives if x = t(n-k1+1) ). c c other subroutines required: fpader. c c references : c de boor c : on calculating with b-splines, j. approximation theory c 6 (1972) 50-62. c cox m.g. : the numerical evaluation of b-splines, j. inst. maths c applics 10 (1972) 134-149. c dierckx p. : curve and surface fitting with splines, monographs on c numerical analysis, oxford university press, 1993. c c author : c p.dierckx c dept. computer science, k.u.leuven c celestijnenlaan 200a, b-3001 heverlee, belgium. c e-mail : Paul.Dierckx@cs.kuleuven.ac.be c c latest update : march 1987 c c ..scalar arguments.. integer n,k1,ier real x c ..array arguments.. real t(n),c(n),d(k1) c ..local scalars.. integer l,nk1 c .. c before starting computations a data check is made. if the input data c are invalid control is immediately repassed to the calling program. ier = 10 nk1 = n-k1 if(x.lt.t(k1) .or. x.gt.t(nk1+1)) go to 300 c search for knot interval t(l) <= x < t(l+1) l = k1 100 if(x.lt.t(l+1) .or. l.eq.nk1) go to 200 l = l+1 go to 100 200 if(t(l).ge.t(l+1)) go to 300 ier = 0 c calculate the derivatives. call fpader(t,n,c,k1,x,l,d) 300 return end spd-1.3.0/fitpack/fpadpo.f0000644000175000017500000000333611633462461012276 00000000000000 subroutine fpadpo(idim,t,n,c,nc,k,cp,np,cc,t1,t2) c given a idim-dimensional spline curve of degree k, in its b-spline c representation ( knots t(j),j=1,...,n , b-spline coefficients c(j), c j=1,...,nc) and given also a polynomial curve in its b-spline c representation ( coefficients cp(j), j=1,...,np), subroutine fpadpo c calculates the b-spline representation (coefficients c(j),j=1,...,nc) c of the sum of the two curves. c c other subroutine required : fpinst c c .. c ..scalar arguments.. integer idim,k,n,nc,np c ..array arguments.. real t(n),c(nc),cp(np),cc(nc),t1(n),t2(n) c ..local scalars.. integer i,ii,j,jj,k1,l,l1,n1,n2,nk1,nk2 c .. k1 = k+1 nk1 = n-k1 c initialization j = 1 l = 1 do 20 jj=1,idim l1 = j do 10 ii=1,k1 cc(l1) = cp(l) l1 = l1+1 l = l+1 10 continue j = j+n l = l+k1 20 continue if(nk1.eq.k1) go to 70 n1 = k1*2 j = n l = n1 do 30 i=1,k1 t1(i) = t(i) t1(l) = t(j) l = l-1 j = j-1 30 continue c find the b-spline representation of the given polynomial curve c according to the given set of knots. nk2 = nk1-1 do 60 l=k1,nk2 l1 = l+1 j = 1 do 40 i=1,idim call fpinst(0,t1,n1,cc(j),k,t(l1),l,t2,n2,cc(j),n) j = j+n 40 continue do 50 i=1,n2 t1(i) = t2(i) 50 continue n1 = n2 60 continue c find the b-spline representation of the resulting curve. 70 j = 1 do 90 jj=1,idim l = j do 80 i=1,nk1 c(l) = cc(l)+c(l) l = l+1 80 continue j = j+n 90 continue return end spd-1.3.0/fitpack/fpsurf.f0000644000175000017500000005265611633462461012343 00000000000000 subroutine fpsurf(iopt,m,x,y,z,w,xb,xe,yb,ye,kxx,kyy,s,nxest, * nyest,eta,tol,maxit,nmax,km1,km2,ib1,ib3,nc,intest,nrest, * nx0,tx,ny0,ty,c,fp,fp0,fpint,coord,f,ff,a,q,bx,by,spx,spy,h, * index,nummer,wrk,lwrk,ier) c .. c ..scalar arguments.. real xb,xe,yb,ye,s,eta,tol,fp,fp0 integer iopt,m,kxx,kyy,nxest,nyest,maxit,nmax,km1,km2,ib1,ib3, * nc,intest,nrest,nx0,ny0,lwrk,ier c ..array arguments.. real x(m),y(m),z(m),w(m),tx(nmax),ty(nmax),c(nc),fpint(intest), * coord(intest),f(nc),ff(nc),a(nc,ib1),q(nc,ib3),bx(nmax,km2), * by(nmax,km2),spx(m,km1),spy(m,km1),h(ib3),wrk(lwrk) integer index(nrest),nummer(m) c ..local scalars.. real acc,arg,cos,dmax,fac1,fac2,fpmax,fpms,f1,f2,f3,hxi,p,pinv, * piv,p1,p2,p3,sigma,sin,sq,store,wi,x0,x1,y0,y1,zi,eps, * rn,one,con1,con9,con4,half,ten integer i,iband,iband1,iband3,iband4,ibb,ichang,ich1,ich3,ii, * in,irot,iter,i1,i2,i3,j,jrot,jxy,j1,kx,kx1,kx2,ky,ky1,ky2,l, * la,lf,lh,lwest,lx,ly,l1,l2,n,ncof,nk1x,nk1y,nminx,nminy,nreg, * nrint,num,num1,nx,nxe,nxx,ny,nye,nyy,n1,rank c ..local arrays.. real hx(6),hy(6) c ..function references.. real abs,fprati,sqrt integer min0 c ..subroutine references.. c fpback,fpbspl,fpgivs,fpdisc,fporde,fprank,fprota c .. c set constants one = 0.1e+01 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 half = 0.5e0 ten = 0.1e+02 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position. c c **************************************************************** c c given a set of knots we compute the least-squares spline sinf(x,y), c c and the corresponding weighted sum of squared residuals fp=f(p=inf). c c if iopt=-1 sinf(x,y) is the requested approximation. c c if iopt=0 or iopt=1 we check whether we can accept the knots: c c if fp <=s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares spline until finally fp<=s. c c the initial choice of knots depends on the value of s and iopt. c c if iopt=0 we first compute the least-squares polynomial of degree c c kx in x and ky in y; nx=nminx=2*kx+2 and ny=nminy=2*ky+2. c c fp0=f(0) denotes the corresponding weighted sum of squared c c residuals c c if iopt=1 we start with the knots found at the last call of the c c routine, except for the case that s>=fp0; then we can compute c c the least-squares polynomial directly. c c eventually the independent variables x and y (and the corresponding c c parameters) will be switched if this can reduce the bandwidth of the c c system to be solved. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c ichang denotes whether(1) or not(-1) the directions have been inter- c changed. ichang = -1 x0 = xb x1 = xe y0 = yb y1 = ye kx = kxx ky = kyy kx1 = kx+1 ky1 = ky+1 nxe = nxest nye = nyest eps = sqrt(eta) if(iopt.lt.0) go to 20 c calculation of acc, the absolute tolerance for the root of f(p)=s. acc = tol*s if(iopt.eq.0) go to 10 if(fp0.gt.s) go to 20 c initialization for the least-squares polynomial. 10 nminx = 2*kx1 nminy = 2*ky1 nx = nminx ny = nminy ier = -2 go to 30 20 nx = nx0 ny = ny0 c main loop for the different sets of knots. m is a save upper bound c for the number of trials. 30 do 420 iter=1,m c find the position of the additional knots which are needed for the c b-spline representation of s(x,y). l = nx do 40 i=1,kx1 tx(i) = x0 tx(l) = x1 l = l-1 40 continue l = ny do 50 i=1,ky1 ty(i) = y0 ty(l) = y1 l = l-1 50 continue c find nrint, the total number of knot intervals and nreg, the number c of panels in which the approximation domain is subdivided by the c intersection of knots. nxx = nx-2*kx1+1 nyy = ny-2*ky1+1 nrint = nxx+nyy nreg = nxx*nyy c find the bandwidth of the observation matrix a. c if necessary, interchange the variables x and y, in order to obtain c a minimal bandwidth. iband1 = kx*(ny-ky1)+ky l = ky*(nx-kx1)+kx if(iband1.le.l) go to 130 iband1 = l ichang = -ichang do 60 i=1,m store = x(i) x(i) = y(i) y(i) = store 60 continue store = x0 x0 = y0 y0 = store store = x1 x1 = y1 y1 = store n = min0(nx,ny) do 70 i=1,n store = tx(i) tx(i) = ty(i) ty(i) = store 70 continue n1 = n+1 if(nx-ny) 80,120,100 80 do 90 i=n1,ny tx(i) = ty(i) 90 continue go to 120 100 do 110 i=n1,nx ty(i) = tx(i) 110 continue 120 l = nx nx = ny ny = l l = nxe nxe = nye nye = l l = nxx nxx = nyy nyy = l l = kx kx = ky ky = l kx1 = kx+1 ky1 = ky+1 130 iband = iband1+1 c arrange the data points according to the panel they belong to. call fporde(x,y,m,kx,ky,tx,nx,ty,ny,nummer,index,nreg) c find ncof, the number of b-spline coefficients. nk1x = nx-kx1 nk1y = ny-ky1 ncof = nk1x*nk1y c initialize the observation matrix a. do 140 i=1,ncof f(i) = 0. do 140 j=1,iband a(i,j) = 0. 140 continue c initialize the sum of squared residuals. fp = 0. c fetch the data points in the new order. main loop for the c different panels. do 250 num=1,nreg c fix certain constants for the current panel; jrot records the column c number of the first non-zero element in a row of the observation c matrix according to a data point of the panel. num1 = num-1 lx = num1/nyy l1 = lx+kx1 ly = num1-lx*nyy l2 = ly+ky1 jrot = lx*nk1y+ly c test whether there are still data points in the panel. in = index(num) 150 if(in.eq.0) go to 250 c fetch a new data point. wi = w(in) zi = z(in)*wi c evaluate for the x-direction, the (kx+1) non-zero b-splines at x(in). call fpbspl(tx,nx,kx,x(in),l1,hx) c evaluate for the y-direction, the (ky+1) non-zero b-splines at y(in). call fpbspl(ty,ny,ky,y(in),l2,hy) c store the value of these b-splines in spx and spy respectively. do 160 i=1,kx1 spx(in,i) = hx(i) 160 continue do 170 i=1,ky1 spy(in,i) = hy(i) 170 continue c initialize the new row of observation matrix. do 180 i=1,iband h(i) = 0. 180 continue c calculate the non-zero elements of the new row by making the cross c products of the non-zero b-splines in x- and y-direction. i1 = 0 do 200 i=1,kx1 hxi = hx(i) j1 = i1 do 190 j=1,ky1 j1 = j1+1 h(j1) = hxi*hy(j)*wi 190 continue i1 = i1+nk1y 200 continue c rotate the row into triangle by givens transformations . irot = jrot do 220 i=1,iband irot = irot+1 piv = h(i) if(piv.eq.0.) go to 220 c calculate the parameters of the givens transformation. call fpgivs(piv,a(irot,1),cos,sin) c apply that transformation to the right hand side. call fprota(cos,sin,zi,f(irot)) if(i.eq.iband) go to 230 c apply that transformation to the left hand side. i2 = 1 i3 = i+1 do 210 j=i3,iband i2 = i2+1 call fprota(cos,sin,h(j),a(irot,i2)) 210 continue 220 continue c add the contribution of the row to the sum of squares of residual c right hand sides. 230 fp = fp+zi**2 c find the number of the next data point in the panel. 240 in = nummer(in) go to 150 250 continue c find dmax, the maximum value for the diagonal elements in the reduced c triangle. dmax = 0. do 260 i=1,ncof if(a(i,1).le.dmax) go to 260 dmax = a(i,1) 260 continue c check whether the observation matrix is rank deficient. sigma = eps*dmax do 270 i=1,ncof if(a(i,1).le.sigma) go to 280 270 continue c backward substitution in case of full rank. call fpback(a,f,ncof,iband,c,nc) rank = ncof do 275 i=1,ncof q(i,1) = a(i,1)/dmax 275 continue go to 300 c in case of rank deficiency, find the minimum norm solution. c check whether there is sufficient working space 280 lwest = ncof*iband+ncof+iband if(lwrk.lt.lwest) go to 780 do 290 i=1,ncof ff(i) = f(i) do 290 j=1,iband q(i,j) = a(i,j) 290 continue lf =1 lh = lf+ncof la = lh+iband call fprank(q,ff,ncof,iband,nc,sigma,c,sq,rank,wrk(la), * wrk(lf),wrk(lh)) do 295 i=1,ncof q(i,1) = q(i,1)/dmax 295 continue c add to the sum of squared residuals, the contribution of reducing c the rank. fp = fp+sq 300 if(ier.eq.(-2)) fp0 = fp c test whether the least-squares spline is an acceptable solution. if(iopt.lt.0) go to 820 fpms = fp-s if(abs(fpms).le.acc) if(fp) 815,815,820 c test whether we can accept the choice of knots. if(fpms.lt.0.) go to 430 c test whether we cannot further increase the number of knots. if(ncof.gt.m) go to 790 ier = 0 c search where to add a new knot. c find for each interval the sum of squared residuals fpint for the c data points having the coordinate belonging to that knot interval. c calculate also coord which is the same sum, weighted by the position c of the data points considered. 310 do 320 i=1,nrint fpint(i) = 0. coord(i) = 0. 320 continue do 360 num=1,nreg num1 = num-1 lx = num1/nyy l1 = lx+1 ly = num1-lx*nyy l2 = ly+1+nxx jrot = lx*nk1y+ly in = index(num) 330 if(in.eq.0) go to 360 store = 0. i1 = jrot do 350 i=1,kx1 hxi = spx(in,i) j1 = i1 do 340 j=1,ky1 j1 = j1+1 store = store+hxi*spy(in,j)*c(j1) 340 continue i1 = i1+nk1y 350 continue store = (w(in)*(z(in)-store))**2 fpint(l1) = fpint(l1)+store coord(l1) = coord(l1)+store*x(in) fpint(l2) = fpint(l2)+store coord(l2) = coord(l2)+store*y(in) in = nummer(in) go to 330 360 continue c find the interval for which fpint is maximal on the condition that c there still can be added a knot. 370 l = 0 fpmax = 0. l1 = 1 l2 = nrint if(nx.eq.nxe) l1 = nxx+1 if(ny.eq.nye) l2 = nxx if(l1.gt.l2) go to 810 do 380 i=l1,l2 if(fpmax.ge.fpint(i)) go to 380 l = i fpmax = fpint(i) 380 continue c test whether we cannot further increase the number of knots. if(l.eq.0) go to 785 c calculate the position of the new knot. arg = coord(l)/fpint(l) c test in what direction the new knot is going to be added. if(l.gt.nxx) go to 400 c addition in the x-direction. jxy = l+kx1 fpint(l) = 0. fac1 = tx(jxy)-arg fac2 = arg-tx(jxy-1) if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370 j = nx do 390 i=jxy,nx tx(j+1) = tx(j) j = j-1 390 continue tx(jxy) = arg nx = nx+1 go to 420 c addition in the y-direction. 400 jxy = l+ky1-nxx fpint(l) = 0. fac1 = ty(jxy)-arg fac2 = arg-ty(jxy-1) if(fac1.gt.(ten*fac2) .or. fac2.gt.(ten*fac1)) go to 370 j = ny do 410 i=jxy,ny ty(j+1) = ty(j) j = j-1 410 continue ty(jxy) = arg ny = ny+1 c restart the computations with the new set of knots. 420 continue c test whether the least-squares polynomial is a solution of our c approximation problem. 430 if(ier.eq.(-2)) go to 830 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline sp(x,y) c c ***************************************************** c c we have determined the number of knots and their position. we now c c compute the b-spline coefficients of the smoothing spline sp(x,y). c c the observation matrix a is extended by the rows of a matrix, c c expressing that sp(x,y) must be a polynomial of degree kx in x and c c ky in y. the corresponding weights of these additional rows are set c c to 1./p. iteratively we than have to determine the value of p c c such that f(p)=sum((w(i)*(z(i)-sp(x(i),y(i))))**2) be = s. c c we already know that the least-squares polynomial corresponds to c c p=0 and that the least-squares spline corresponds to p=infinity. c c the iteration process which is proposed here makes use of rational c c interpolation. since f(p) is a convex and strictly decreasing c c function of p, it can be approximated by a rational function r(p)= c c (u*p+v)/(p+w). three values of p(p1,p2,p3) with corresponding values c c of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used to calculate the c c new value of p such that r(p)=s. convergence is guaranteed by taking c c f1 > 0 and f3 < 0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc kx2 = kx1+1 c test whether there are interior knots in the x-direction. if(nk1x.eq.kx1) go to 440 c evaluate the discotinuity jumps of the kx-th order derivative of c the b-splines at the knots tx(l),l=kx+2,...,nx-kx-1. call fpdisc(tx,nx,kx2,bx,nmax) 440 ky2 = ky1 + 1 c test whether there are interior knots in the y-direction. if(nk1y.eq.ky1) go to 450 c evaluate the discontinuity jumps of the ky-th order derivative of c the b-splines at the knots ty(l),l=ky+2,...,ny-ky-1. call fpdisc(ty,ny,ky2,by,nmax) c initial value for p. 450 p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = 0. do 460 i=1,ncof p = p+a(i,1) 460 continue rn = ncof p = rn/p c find the bandwidth of the extended observation matrix. iband3 = kx1*nk1y iband4 = iband3 +1 ich1 = 0 ich3 = 0 c iteration process to find the root of f(p)=s. do 770 iter=1,maxit pinv = one/p c store the triangularized observation matrix into q. do 480 i=1,ncof ff(i) = f(i) do 470 j=1,iband q(i,j) = a(i,j) 470 continue ibb = iband+1 do 480 j=ibb,iband4 q(i,j) = 0. 480 continue if(nk1y.eq.ky1) go to 560 c extend the observation matrix with the rows of a matrix, expressing c that for x=cst. sp(x,y) must be a polynomial in y of degree ky. do 550 i=ky2,nk1y ii = i-ky1 do 550 j=1,nk1x c initialize the new row. do 490 l=1,iband h(l) = 0. 490 continue c fill in the non-zero elements of the row. jrot records the column c number of the first non-zero element in the row. do 500 l=1,ky2 h(l) = by(ii,l)*pinv 500 continue zi = 0. jrot = (j-1)*nk1y+ii c rotate the new row into triangle by givens transformations without c square roots. do 540 irot=jrot,ncof piv = h(1) i2 = min0(iband1,ncof-irot) if(piv.eq.0.) if(i2) 550,550,520 c calculate the parameters of the givens transformation. call fpgivs(piv,q(irot,1),cos,sin) c apply that givens transformation to the right hand side. call fprota(cos,sin,zi,ff(irot)) if(i2.eq.0) go to 550 c apply that givens transformation to the left hand side. do 510 l=1,i2 l1 = l+1 call fprota(cos,sin,h(l1),q(irot,l1)) 510 continue 520 do 530 l=1,i2 h(l) = h(l+1) 530 continue h(i2+1) = 0. 540 continue 550 continue 560 if(nk1x.eq.kx1) go to 640 c extend the observation matrix with the rows of a matrix expressing c that for y=cst. sp(x,y) must be a polynomial in x of degree kx. do 630 i=kx2,nk1x ii = i-kx1 do 630 j=1,nk1y c initialize the new row do 570 l=1,iband4 h(l) = 0. 570 continue c fill in the non-zero elements of the row. jrot records the column c number of the first non-zero element in the row. j1 = 1 do 580 l=1,kx2 h(j1) = bx(ii,l)*pinv j1 = j1+nk1y 580 continue zi = 0. jrot = (i-kx2)*nk1y+j c rotate the new row into triangle by givens transformations . do 620 irot=jrot,ncof piv = h(1) i2 = min0(iband3,ncof-irot) if(piv.eq.0.) if(i2) 630,630,600 c calculate the parameters of the givens transformation. call fpgivs(piv,q(irot,1),cos,sin) c apply that givens transformation to the right hand side. call fprota(cos,sin,zi,ff(irot)) if(i2.eq.0) go to 630 c apply that givens transformation to the left hand side. do 590 l=1,i2 l1 = l+1 call fprota(cos,sin,h(l1),q(irot,l1)) 590 continue 600 do 610 l=1,i2 h(l) = h(l+1) 610 continue h(i2+1) = 0. 620 continue 630 continue c find dmax, the maximum value for the diagonal elements in the c reduced triangle. 640 dmax = 0. do 650 i=1,ncof if(q(i,1).le.dmax) go to 650 dmax = q(i,1) 650 continue c check whether the matrix is rank deficient. sigma = eps*dmax do 660 i=1,ncof if(q(i,1).le.sigma) go to 670 660 continue c backward substitution in case of full rank. call fpback(q,ff,ncof,iband4,c,nc) rank = ncof go to 675 c in case of rank deficiency, find the minimum norm solution. 670 lwest = ncof*iband4+ncof+iband4 if(lwrk.lt.lwest) go to 780 lf = 1 lh = lf+ncof la = lh+iband4 call fprank(q,ff,ncof,iband4,nc,sigma,c,sq,rank,wrk(la), * wrk(lf),wrk(lh)) 675 do 680 i=1,ncof q(i,1) = q(i,1)/dmax 680 continue c compute f(p). fp = 0. do 720 num = 1,nreg num1 = num-1 lx = num1/nyy ly = num1-lx*nyy jrot = lx*nk1y+ly in = index(num) 690 if(in.eq.0) go to 720 store = 0. i1 = jrot do 710 i=1,kx1 hxi = spx(in,i) j1 = i1 do 700 j=1,ky1 j1 = j1+1 store = store+hxi*spy(in,j)*c(j1) 700 continue i1 = i1+nk1y 710 continue fp = fp+(w(in)*(z(in)-store))**2 in = nummer(in) go to 690 720 continue c test whether the approximation sp(x,y) is an acceptable solution. fpms = fp-s if(abs(fpms).le.acc) go to 820 c test whether the maximum allowable number of iterations has been c reached. if(iter.eq.maxit) go to 795 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 740 if((f2-f3).gt.acc) go to 730 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p = p1*con9 + p2*con1 go to 770 730 if(f2.lt.0.) ich3 = 1 740 if(ich1.ne.0) go to 760 if((f1-f2).gt.acc) go to 750 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 770 if(p.ge.p3) p = p2*con1 + p3*con9 go to 770 750 if(f2.gt.0.) ich1 = 1 c test whether the iteration process proceeds as theoretically c expected. 760 if(f2.ge.f1 .or. f2.le.f3) go to 800 c find the new value of p. p = fprati(p1,f1,p2,f2,p3,f3) 770 continue c error codes and messages. 780 ier = lwest go to 830 785 ier = 5 go to 830 790 ier = 4 go to 830 795 ier = 3 go to 830 800 ier = 2 go to 830 810 ier = 1 go to 830 815 ier = -1 fp = 0. 820 if(ncof.ne.rank) ier = -rank c test whether x and y are in the original order. 830 if(ichang.lt.0) go to 930 c if not, interchange x and y once more. l1 = 1 do 840 i=1,nk1x l2 = i do 840 j=1,nk1y f(l2) = c(l1) l1 = l1+1 l2 = l2+nk1x 840 continue do 850 i=1,ncof c(i) = f(i) 850 continue do 860 i=1,m store = x(i) x(i) = y(i) y(i) = store 860 continue n = min0(nx,ny) do 870 i=1,n store = tx(i) tx(i) = ty(i) ty(i) = store 870 continue n1 = n+1 if(nx-ny) 880,920,900 880 do 890 i=n1,ny tx(i) = ty(i) 890 continue go to 920 900 do 910 i=n1,nx ty(i) = tx(i) 910 continue 920 l = nx nx = ny ny = l 930 if(iopt.lt.0) go to 940 nx0 = nx ny0 = ny 940 return end spd-1.3.0/fitpack/fpbspl.f0000644000175000017500000000134011633462461012304 00000000000000 subroutine fpbspl(t,n,k,x,l,h) c subroutine fpbspl evaluates the (k+1) non-zero b-splines of c degree k at t(l) <= x < t(l+1) using the stable recurrence c relation of de boor and cox. c .. c ..scalar arguments.. real x integer n,k,l c ..array arguments.. real t(n),h(6) c ..local scalars.. real f,one integer i,j,li,lj c ..local arrays.. real hh(5) c .. one = 0.1e+01 h(1) = one do 20 j=1,k do 10 i=1,j hh(i) = h(i) 10 continue h(1) = 0. do 20 i=1,j li = l+i lj = li-j f = hh(i)/(t(li)-t(lj)) h(i) = h(i)+f*(t(li)-x) h(i+1) = f*(x-t(lj)) 20 continue return end spd-1.3.0/fitpack/fpcons.f0000644000175000017500000003526411633462461012322 00000000000000 subroutine fpcons(iopt,idim,m,u,mx,x,w,ib,ie,k,s,nest,tol,maxit, * k1,k2,n,t,nc,c,fp,fpint,z,a,b,g,q,nrdata,ier) c .. c ..scalar arguments.. real s,tol,fp integer iopt,idim,m,mx,ib,ie,k,nest,maxit,k1,k2,n,nc,ier c ..array arguments.. real u(m),x(mx),w(m),t(nest),c(nc),fpint(nest), * z(nc),a(nest,k1),b(nest,k2),g(nest,k2),q(m,k1) integer nrdata(nest) c ..local scalars.. real acc,con1,con4,con9,cos,fac,fpart,fpms,fpold,fp0,f1,f2,f3, * half,one,p,pinv,piv,p1,p2,p3,rn,sin,store,term,ui,wi integer i,ich1,ich3,it,iter,i1,i2,i3,j,jb,je,jj,j1,j2,j3,kbe, * l,li,lj,l0,mb,me,mm,new,nk1,nmax,nmin,nn,nplus,npl1,nrint,n8 c ..local arrays.. real h(7),xi(10) c ..function references real abs,fprati integer max0,min0 c ..subroutine references.. c fpbacp,fpbspl,fpgivs,fpdisc,fpknot,fprota c .. c set constants one = 0.1e+01 con1 = 0.1e0 con9 = 0.9e0 con4 = 0.4e-01 half = 0.5e0 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 1: determination of the number of knots and their position c c ************************************************************** c c given a set of knots we compute the least-squares curve sinf(u), c c and the corresponding sum of squared residuals fp=f(p=inf). c c if iopt=-1 sinf(u) is the requested curve. c c if iopt=0 or iopt=1 we check whether we can accept the knots: c c if fp <=s we will continue with the current set of knots. c c if fp > s we will increase the number of knots and compute the c c corresponding least-squares curve until finally fp<=s. c c the initial choice of knots depends on the value of s and iopt. c c if s=0 we have spline interpolation; in that case the number of c c knots equals nmax = m+k+1-max(0,ib-1)-max(0,ie-1) c c if s > 0 and c c iopt=0 we first compute the least-squares polynomial curve of c c degree k; n = nmin = 2*k+2 c c iopt=1 we start with the set of knots found at the last c c call of the routine, except for the case that s > fp0; then c c we compute directly the polynomial curve of degree k. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c determine nmin, the number of knots for polynomial approximation. nmin = 2*k1 c find which data points are to be concidered. mb = 2 jb = ib if(ib.gt.0) go to 10 mb = 1 jb = 1 10 me = m-1 je = ie if(ie.gt.0) go to 20 me = m je = 1 20 if(iopt.lt.0) go to 60 c calculation of acc, the absolute tolerance for the root of f(p)=s. acc = tol*s c determine nmax, the number of knots for spline interpolation. kbe = k1-jb-je mmin = kbe+2 mm = m-mmin nmax = nmin+mm if(s.gt.0.) go to 40 c if s=0, s(u) is an interpolating curve. c test whether the required storage space exceeds the available one. n = nmax if(nmax.gt.nest) go to 420 c find the position of the interior knots in case of interpolation. if(mm.eq.0) go to 60 25 i = k2 j = 3-jb+k/2 do 30 l=1,mm t(i) = u(j) i = i+1 j = j+1 30 continue go to 60 c if s>0 our initial choice of knots depends on the value of iopt. c if iopt=0 or iopt=1 and s>=fp0, we start computing the least-squares c polynomial curve which is a spline curve without interior knots. c if iopt=1 and fp0>s we start computing the least squares spline curve c according to the set of knots found at the last call of the routine. 40 if(iopt.eq.0) go to 50 if(n.eq.nmin) go to 50 fp0 = fpint(n) fpold = fpint(n-1) nplus = nrdata(n) if(fp0.gt.s) go to 60 50 n = nmin fpold = 0. nplus = 0 nrdata(1) = m-2 c main loop for the different sets of knots. m is a save upper bound c for the number of trials. 60 do 200 iter = 1,m if(n.eq.nmin) ier = -2 c find nrint, tne number of knot intervals. nrint = n-nmin+1 c find the position of the additional knots which are needed for c the b-spline representation of s(u). nk1 = n-k1 i = n do 70 j=1,k1 t(j) = u(1) t(i) = u(m) i = i-1 70 continue c compute the b-spline coefficients of the least-squares spline curve c sinf(u). the observation matrix a is built up row by row and c reduced to upper triangular form by givens transformations. c at the same time fp=f(p=inf) is computed. fp = 0. c nn denotes the dimension of the splines nn = nk1-ib-ie c initialize the b-spline coefficients and the observation matrix a. do 75 i=1,nc z(i) = 0. c(i) = 0. 75 continue if(me.lt.mb) go to 134 if(nn.eq.0) go to 82 do 80 i=1,nn do 80 j=1,k1 a(i,j) = 0. 80 continue 82 l = k1 jj = (mb-1)*idim do 130 it=mb,me c fetch the current data point u(it),x(it). ui = u(it) wi = w(it) do 84 j=1,idim jj = jj+1 xi(j) = x(jj)*wi 84 continue c search for knot interval t(l) <= ui < t(l+1). 86 if(ui.lt.t(l+1) .or. l.eq.nk1) go to 90 l = l+1 go to 86 c evaluate the (k+1) non-zero b-splines at ui and store them in q. 90 call fpbspl(t,n,k,ui,l,h) do 92 i=1,k1 q(it,i) = h(i) h(i) = h(i)*wi 92 continue c take into account that certain b-spline coefficients must be zero. lj = k1 j = nk1-l-ie if(j.ge.0) go to 94 lj = lj+j 94 li = 1 j = l-k1-ib if(j.ge.0) go to 96 li = li-j j = 0 96 if(li.gt.lj) go to 120 c rotate the new row of the observation matrix into triangle. do 110 i=li,lj j = j+1 piv = h(i) if(piv.eq.0.) go to 110 c calculate the parameters of the givens transformation. call fpgivs(piv,a(j,1),cos,sin) c transformations to right hand side. j1 = j do 98 j2 =1,idim call fprota(cos,sin,xi(j2),z(j1)) j1 = j1+n 98 continue if(i.eq.lj) go to 120 i2 = 1 i3 = i+1 do 100 i1 = i3,lj i2 = i2+1 c transformations to left hand side. call fprota(cos,sin,h(i1),a(j,i2)) 100 continue 110 continue c add contribution of this row to the sum of squares of residual c right hand sides. 120 do 125 j2=1,idim fp = fp+xi(j2)**2 125 continue 130 continue if(ier.eq.(-2)) fp0 = fp fpint(n) = fp0 fpint(n-1) = fpold nrdata(n) = nplus c backward substitution to obtain the b-spline coefficients. if(nn.eq.0) go to 134 j1 = 1 do 132 j2=1,idim j3 = j1+ib call fpback(a,z(j1),nn,k1,c(j3),nest) j1 = j1+n 132 continue c test whether the approximation sinf(u) is an acceptable solution. 134 if(iopt.lt.0) go to 440 fpms = fp-s if(abs(fpms).lt.acc) go to 440 c if f(p=inf) < s accept the choice of knots. if(fpms.lt.0.) go to 250 c if n = nmax, sinf(u) is an interpolating spline curve. if(n.eq.nmax) go to 430 c increase the number of knots. c if n=nest we cannot increase the number of knots because of c the storage capacity limitation. if(n.eq.nest) go to 420 c determine the number of knots nplus we are going to add. if(ier.eq.0) go to 140 nplus = 1 ier = 0 go to 150 140 npl1 = nplus*2 rn = nplus if(fpold-fp.gt.acc) npl1 = rn*fpms/(fpold-fp) nplus = min0(nplus*2,max0(npl1,nplus/2,1)) 150 fpold = fp c compute the sum of squared residuals for each knot interval c t(j+k) <= u(i) <= t(j+k+1) and store it in fpint(j),j=1,2,...nrint. fpart = 0. i = 1 l = k2 new = 0 jj = (mb-1)*idim do 180 it=mb,me if(u(it).lt.t(l) .or. l.gt.nk1) go to 160 new = 1 l = l+1 160 term = 0. l0 = l-k2 do 175 j2=1,idim fac = 0. j1 = l0 do 170 j=1,k1 j1 = j1+1 fac = fac+c(j1)*q(it,j) 170 continue jj = jj+1 term = term+(w(it)*(fac-x(jj)))**2 l0 = l0+n 175 continue fpart = fpart+term if(new.eq.0) go to 180 store = term*half fpint(i) = fpart-store i = i+1 fpart = store new = 0 180 continue fpint(nrint) = fpart do 190 l=1,nplus c add a new knot. call fpknot(u,m,t,n,fpint,nrdata,nrint,nest,1) c if n=nmax we locate the knots as for interpolation if(n.eq.nmax) go to 25 c test whether we cannot further increase the number of knots. if(n.eq.nest) go to 200 190 continue c restart the computations with the new set of knots. 200 continue c test whether the least-squares kth degree polynomial curve is a c solution of our approximation problem. 250 if(ier.eq.(-2)) go to 440 cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c part 2: determination of the smoothing spline curve sp(u). c c ********************************************************** c c we have determined the number of knots and their position. c c we now compute the b-spline coefficients of the smoothing curve c c sp(u). the observation matrix a is extended by the rows of matrix c c b expressing that the kth derivative discontinuities of sp(u) at c c the interior knots t(k+2),...t(n-k-1) must be zero. the corres- c c ponding weights of these additional rows are set to 1/p. c c iteratively we then have to determine the value of p such that f(p),c c the sum of squared residuals be = s. we already know that the least c c squares kth degree polynomial curve corresponds to p=0, and that c c the least-squares spline curve corresponds to p=infinity. the c c iteration process which is proposed here, makes use of rational c c interpolation. since f(p) is a convex and strictly decreasing c c function of p, it can be approximated by a rational function c c r(p) = (u*p+v)/(p+w). three values of p(p1,p2,p3) with correspond- c c ing values of f(p) (f1=f(p1)-s,f2=f(p2)-s,f3=f(p3)-s) are used c c to calculate the new value of p such that r(p)=s. convergence is c c guaranteed by taking f1>0 and f3<0. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c evaluate the discontinuity jump of the kth derivative of the c b-splines at the knots t(l),l=k+2,...n-k-1 and store in b. call fpdisc(t,n,k2,b,nest) c initial value for p. p1 = 0. f1 = fp0-s p3 = -one f3 = fpms p = 0. do 252 i=1,nn p = p+a(i,1) 252 continue rn = nn p = rn/p ich1 = 0 ich3 = 0 n8 = n-nmin c iteration process to find the root of f(p) = s. do 360 iter=1,maxit c the rows of matrix b with weight 1/p are rotated into the c triangularised observation matrix a which is stored in g. pinv = one/p do 255 i=1,nc c(i) = z(i) 255 continue do 260 i=1,nn g(i,k2) = 0. do 260 j=1,k1 g(i,j) = a(i,j) 260 continue do 300 it=1,n8 c the row of matrix b is rotated into triangle by givens transformation do 264 i=1,k2 h(i) = b(it,i)*pinv 264 continue do 268 j=1,idim xi(j) = 0. 268 continue c take into account that certain b-spline coefficients must be zero. if(it.gt.ib) go to 274 j1 = ib-it+2 j2 = 1 do 270 i=j1,k2 h(j2) = h(i) j2 = j2+1 270 continue do 272 i=j2,k2 h(i) = 0. 272 continue 274 jj = max0(1,it-ib) do 290 j=jj,nn piv = h(1) c calculate the parameters of the givens transformation. call fpgivs(piv,g(j,1),cos,sin) c transformations to right hand side. j1 = j do 277 j2=1,idim call fprota(cos,sin,xi(j2),c(j1)) j1 = j1+n 277 continue if(j.eq.nn) go to 300 i2 = min0(nn-j,k1) do 280 i=1,i2 c transformations to left hand side. i1 = i+1 call fprota(cos,sin,h(i1),g(j,i1)) h(i) = h(i1) 280 continue h(i2+1) = 0. 290 continue 300 continue c backward substitution to obtain the b-spline coefficients. j1 = 1 do 308 j2=1,idim j3 = j1+ib call fpback(g,c(j1),nn,k2,c(j3),nest) if(ib.eq.0) go to 306 j3 = j1 do 304 i=1,ib c(j3) = 0. j3 = j3+1 304 continue 306 j1 =j1+n 308 continue c computation of f(p). fp = 0. l = k2 jj = (mb-1)*idim do 330 it=mb,me if(u(it).lt.t(l) .or. l.gt.nk1) go to 310 l = l+1 310 l0 = l-k2 term = 0. do 325 j2=1,idim fac = 0. j1 = l0 do 320 j=1,k1 j1 = j1+1 fac = fac+c(j1)*q(it,j) 320 continue jj = jj+1 term = term+(fac-x(jj))**2 l0 = l0+n 325 continue fp = fp+term*w(it)**2 330 continue c test whether the approximation sp(u) is an acceptable solution. fpms = fp-s if(abs(fpms).lt.acc) go to 440 c test whether the maximal number of iterations is reached. if(iter.eq.maxit) go to 400 c carry out one more step of the iteration process. p2 = p f2 = fpms if(ich3.ne.0) go to 340 if((f2-f3).gt.acc) go to 335 c our initial choice of p is too large. p3 = p2 f3 = f2 p = p*con4 if(p.le.p1) p=p1*con9 + p2*con1 go to 360 335 if(f2.lt.0.) ich3=1 340 if(ich1.ne.0) go to 350 if((f1-f2).gt.acc) go to 345 c our initial choice of p is too small p1 = p2 f1 = f2 p = p/con4 if(p3.lt.0.) go to 360 if(p.ge.p3) p = p2*con1 + p3*con9 go to 360 345 if(f2.gt.0.) ich1=1 c test whether the iteration process proceeds as theoretically c expected. 350 if(f2.ge.f1 .or. f2.le.f3) go to 410 c find the new value for p. p = fprati(p1,f1,p2,f2,p3,f3) 360 continue c error codes and messages. 400 ier = 3 go to 440 410 ier = 2 go to 440 420 ier = 1 go to 440 430 ier = -1 440 return end spd-1.3.0/fitpack/fpchec.f0000644000175000017500000000350311633462461012251 00000000000000 subroutine fpchec(x,m,t,n,k,ier) c subroutine fpchec verifies the number and the position of the knots c t(j),j=1,2,...,n of a spline of degree k, in relation to the number c and the position of the data points x(i),i=1,2,...,m. if all of the c following conditions are fulfilled, the error parameter ier is set c to zero. if one of the conditions is violated ier is set to ten. c 1) k+1 <= n-k-1 <= m c 2) t(1) <= t(2) <= ... <= t(k+1) c t(n-k) <= t(n-k+1) <= ... <= t(n) c 3) t(k+1) < t(k+2) < ... < t(n-k) c 4) t(k+1) <= x(i) <= t(n-k) c 5) the conditions specified by schoenberg and whitney must hold c for at least one subset of data points, i.e. there must be a c subset of data points y(j) such that c t(j) < y(j) < t(j+k+1), j=1,2,...,n-k-1 c .. c ..scalar arguments.. integer m,n,k,ier c ..array arguments.. real x(m),t(n) c ..local scalars.. integer i,j,k1,k2,l,nk1,nk2,nk3 real tj,tl c .. k1 = k+1 k2 = k1+1 nk1 = n-k1 nk2 = nk1+1 ier = 10 c check condition no 1 if(nk1.lt.k1 .or. nk1.gt.m) go to 80 c check condition no 2 j = n do 20 i=1,k if(t(i).gt.t(i+1)) go to 80 if(t(j).lt.t(j-1)) go to 80 j = j-1 20 continue c check condition no 3 do 30 i=k2,nk2 if(t(i).le.t(i-1)) go to 80 30 continue c check condition no 4 if(x(1).lt.t(k1) .or. x(m).gt.t(nk2)) go to 80 c check condition no 5 if(x(1).ge.t(k2) .or. x(m).le.t(nk1)) go to 80 i = 1 l = k2 nk3 = nk1-1 if(nk3.lt.2) go to 70 do 60 j=2,nk3 tj = t(j) l = l+1 tl = t(l) 40 i = i+1 if(i.ge.m) go to 80 if(x(i).le.tj) go to 40 if(x(i).ge.tl) go to 80 60 continue 70 ier = 0 80 return end spd-1.3.0/aclocal.m40000644000175000017500000010346311650556153011100 00000000000000# generated automatically by aclocal 1.11.1 -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, # 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl m4_if(m4_defn([AC_AUTOCONF_VERSION]), [2.68],, [m4_warning([this file was generated for autoconf 2.68. You have another version of autoconf. It may work, but is not guaranteed to. If you have problems, you may need to regenerate the build system entirely. To do so, use the procedure documented by the package, typically `autoreconf'.])]) # Copyright (C) 2002, 2003, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_AUTOMAKE_VERSION(VERSION) # ---------------------------- # Automake X.Y traces this macro to ensure aclocal.m4 has been # generated from the m4 files accompanying Automake X.Y. # (This private macro should not be called outside this file.) AC_DEFUN([AM_AUTOMAKE_VERSION], [am__api_version='1.11' dnl Some users find AM_AUTOMAKE_VERSION and mistake it for a way to dnl require some minimum version. Point them to the right macro. m4_if([$1], [1.11.1], [], [AC_FATAL([Do not call $0, use AM_INIT_AUTOMAKE([$1]).])])dnl ]) # _AM_AUTOCONF_VERSION(VERSION) # ----------------------------- # aclocal traces this macro to find the Autoconf version. # This is a private macro too. Using m4_define simplifies # the logic in aclocal, which can simply ignore this definition. m4_define([_AM_AUTOCONF_VERSION], []) # AM_SET_CURRENT_AUTOMAKE_VERSION # ------------------------------- # Call AM_AUTOMAKE_VERSION and AM_AUTOMAKE_VERSION so they can be traced. # This function is AC_REQUIREd by AM_INIT_AUTOMAKE. AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION], [AM_AUTOMAKE_VERSION([1.11.1])dnl m4_ifndef([AC_AUTOCONF_VERSION], [m4_copy([m4_PACKAGE_VERSION], [AC_AUTOCONF_VERSION])])dnl _AM_AUTOCONF_VERSION(m4_defn([AC_AUTOCONF_VERSION]))]) # AM_AUX_DIR_EXPAND -*- Autoconf -*- # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # For projects using AC_CONFIG_AUX_DIR([foo]), Autoconf sets # $ac_aux_dir to `$srcdir/foo'. In other projects, it is set to # `$srcdir', `$srcdir/..', or `$srcdir/../..'. # # Of course, Automake must honor this variable whenever it calls a # tool from the auxiliary directory. The problem is that $srcdir (and # therefore $ac_aux_dir as well) can be either absolute or relative, # depending on how configure is run. This is pretty annoying, since # it makes $ac_aux_dir quite unusable in subdirectories: in the top # source directory, any form will work fine, but in subdirectories a # relative path needs to be adjusted first. # # $ac_aux_dir/missing # fails when called from a subdirectory if $ac_aux_dir is relative # $top_srcdir/$ac_aux_dir/missing # fails if $ac_aux_dir is absolute, # fails when called from a subdirectory in a VPATH build with # a relative $ac_aux_dir # # The reason of the latter failure is that $top_srcdir and $ac_aux_dir # are both prefixed by $srcdir. In an in-source build this is usually # harmless because $srcdir is `.', but things will broke when you # start a VPATH build or use an absolute $srcdir. # # So we could use something similar to $top_srcdir/$ac_aux_dir/missing, # iff we strip the leading $srcdir from $ac_aux_dir. That would be: # am_aux_dir='\$(top_srcdir)/'`expr "$ac_aux_dir" : "$srcdir//*\(.*\)"` # and then we would define $MISSING as # MISSING="\${SHELL} $am_aux_dir/missing" # This will work as long as MISSING is not called from configure, because # unfortunately $(top_srcdir) has no meaning in configure. # However there are other variables, like CC, which are often used in # configure, and could therefore not use this "fixed" $ac_aux_dir. # # Another solution, used here, is to always expand $ac_aux_dir to an # absolute PATH. The drawback is that using absolute paths prevent a # configured tree to be moved without reconfiguration. AC_DEFUN([AM_AUX_DIR_EXPAND], [dnl Rely on autoconf to set up CDPATH properly. AC_PREREQ([2.50])dnl # expand $ac_aux_dir to an absolute path am_aux_dir=`cd $ac_aux_dir && pwd` ]) # AM_CONDITIONAL -*- Autoconf -*- # Copyright (C) 1997, 2000, 2001, 2003, 2004, 2005, 2006, 2008 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 9 # AM_CONDITIONAL(NAME, SHELL-CONDITION) # ------------------------------------- # Define a conditional. AC_DEFUN([AM_CONDITIONAL], [AC_PREREQ(2.52)dnl ifelse([$1], [TRUE], [AC_FATAL([$0: invalid condition: $1])], [$1], [FALSE], [AC_FATAL([$0: invalid condition: $1])])dnl AC_SUBST([$1_TRUE])dnl AC_SUBST([$1_FALSE])dnl _AM_SUBST_NOTMAKE([$1_TRUE])dnl _AM_SUBST_NOTMAKE([$1_FALSE])dnl m4_define([_AM_COND_VALUE_$1], [$2])dnl if $2; then $1_TRUE= $1_FALSE='#' else $1_TRUE='#' $1_FALSE= fi AC_CONFIG_COMMANDS_PRE( [if test -z "${$1_TRUE}" && test -z "${$1_FALSE}"; then AC_MSG_ERROR([[conditional "$1" was never defined. Usually this means the macro was only invoked conditionally.]]) fi])]) # Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2009 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 10 # There are a few dirty hacks below to avoid letting `AC_PROG_CC' be # written in clear, in which case automake, when reading aclocal.m4, # will think it sees a *use*, and therefore will trigger all it's # C support machinery. Also note that it means that autoscan, seeing # CC etc. in the Makefile, will ask for an AC_PROG_CC use... # _AM_DEPENDENCIES(NAME) # ---------------------- # See how the compiler implements dependency checking. # NAME is "CC", "CXX", "GCJ", or "OBJC". # We try a few techniques and use that to set a single cache variable. # # We don't AC_REQUIRE the corresponding AC_PROG_CC since the latter was # modified to invoke _AM_DEPENDENCIES(CC); we would have a circular # dependency, and given that the user is not expected to run this macro, # just rely on AC_PROG_CC. AC_DEFUN([_AM_DEPENDENCIES], [AC_REQUIRE([AM_SET_DEPDIR])dnl AC_REQUIRE([AM_OUTPUT_DEPENDENCY_COMMANDS])dnl AC_REQUIRE([AM_MAKE_INCLUDE])dnl AC_REQUIRE([AM_DEP_TRACK])dnl ifelse([$1], CC, [depcc="$CC" am_compiler_list=], [$1], CXX, [depcc="$CXX" am_compiler_list=], [$1], OBJC, [depcc="$OBJC" am_compiler_list='gcc3 gcc'], [$1], UPC, [depcc="$UPC" am_compiler_list=], [$1], GCJ, [depcc="$GCJ" am_compiler_list='gcc3 gcc'], [depcc="$$1" am_compiler_list=]) AC_CACHE_CHECK([dependency style of $depcc], [am_cv_$1_dependencies_compiler_type], [if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named `D' -- because `-MD' means `put the output # in D'. mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_$1_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n ['s/^#*\([a-zA-Z0-9]*\))$/\1/p'] < ./depcomp` fi am__universal=false m4_case([$1], [CC], [case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac], [CXX], [case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac]) for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with # Solaris 8's {/usr,}/bin/sh. touch sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with `-c' and `-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle `-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # after this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvisualcpp | msvcmsys) # This compiler won't grok `-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_$1_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_$1_dependencies_compiler_type=none fi ]) AC_SUBST([$1DEPMODE], [depmode=$am_cv_$1_dependencies_compiler_type]) AM_CONDITIONAL([am__fastdep$1], [ test "x$enable_dependency_tracking" != xno \ && test "$am_cv_$1_dependencies_compiler_type" = gcc3]) ]) # AM_SET_DEPDIR # ------------- # Choose a directory name for dependency files. # This macro is AC_REQUIREd in _AM_DEPENDENCIES AC_DEFUN([AM_SET_DEPDIR], [AC_REQUIRE([AM_SET_LEADING_DOT])dnl AC_SUBST([DEPDIR], ["${am__leading_dot}deps"])dnl ]) # AM_DEP_TRACK # ------------ AC_DEFUN([AM_DEP_TRACK], [AC_ARG_ENABLE(dependency-tracking, [ --disable-dependency-tracking speeds up one-time build --enable-dependency-tracking do not reject slow dependency extractors]) if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' fi AM_CONDITIONAL([AMDEP], [test "x$enable_dependency_tracking" != xno]) AC_SUBST([AMDEPBACKSLASH])dnl _AM_SUBST_NOTMAKE([AMDEPBACKSLASH])dnl ]) # Generate code to set up dependency tracking. -*- Autoconf -*- # Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. #serial 5 # _AM_OUTPUT_DEPENDENCY_COMMANDS # ------------------------------ AC_DEFUN([_AM_OUTPUT_DEPENDENCY_COMMANDS], [{ # Autoconf 2.62 quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. case $CONFIG_FILES in *\'*) eval set x "$CONFIG_FILES" ;; *) set x $CONFIG_FILES ;; esac shift for mf do # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. # We used to match only the files named `Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`AS_DIRNAME("$mf")` else continue fi # Extract the definition of DEPDIR, am__include, and am__quote # from the Makefile without running `make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` test -z "am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # When using ansi2knr, U may be empty or an underscore; expand it U=`sed -n 's/^U = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`AS_DIRNAME(["$file"])` AS_MKDIR_P([$dirpart/$fdir]) # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done done } ])# _AM_OUTPUT_DEPENDENCY_COMMANDS # AM_OUTPUT_DEPENDENCY_COMMANDS # ----------------------------- # This macro should only be invoked once -- use via AC_REQUIRE. # # This code is only required when automatic dependency tracking # is enabled. FIXME. This creates each `.P' file that we will # need in order to bootstrap the dependency handling code. AC_DEFUN([AM_OUTPUT_DEPENDENCY_COMMANDS], [AC_CONFIG_COMMANDS([depfiles], [test x"$AMDEP_TRUE" != x"" || _AM_OUTPUT_DEPENDENCY_COMMANDS], [AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir"]) ]) # Do all the work for Automake. -*- Autoconf -*- # Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, # 2005, 2006, 2008, 2009 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 16 # This macro actually does too much. Some checks are only needed if # your package does certain things. But this isn't really a big deal. # AM_INIT_AUTOMAKE(PACKAGE, VERSION, [NO-DEFINE]) # AM_INIT_AUTOMAKE([OPTIONS]) # ----------------------------------------------- # The call with PACKAGE and VERSION arguments is the old style # call (pre autoconf-2.50), which is being phased out. PACKAGE # and VERSION should now be passed to AC_INIT and removed from # the call to AM_INIT_AUTOMAKE. # We support both call styles for the transition. After # the next Automake release, Autoconf can make the AC_INIT # arguments mandatory, and then we can depend on a new Autoconf # release and drop the old call support. AC_DEFUN([AM_INIT_AUTOMAKE], [AC_PREREQ([2.62])dnl dnl Autoconf wants to disallow AM_ names. We explicitly allow dnl the ones we care about. m4_pattern_allow([^AM_[A-Z]+FLAGS$])dnl AC_REQUIRE([AM_SET_CURRENT_AUTOMAKE_VERSION])dnl AC_REQUIRE([AC_PROG_INSTALL])dnl if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." AC_SUBST([am__isrc], [' -I$(srcdir)'])_AM_SUBST_NOTMAKE([am__isrc])dnl # test to see if srcdir already configured if test -f $srcdir/config.status; then AC_MSG_ERROR([source directory already configured; run "make distclean" there first]) fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi AC_SUBST([CYGPATH_W]) # Define the identity of the package. dnl Distinguish between old-style and new-style calls. m4_ifval([$2], [m4_ifval([$3], [_AM_SET_OPTION([no-define])])dnl AC_SUBST([PACKAGE], [$1])dnl AC_SUBST([VERSION], [$2])], [_AM_SET_OPTIONS([$1])dnl dnl Diagnose old-style AC_INIT with new-style AM_AUTOMAKE_INIT. m4_if(m4_ifdef([AC_PACKAGE_NAME], 1)m4_ifdef([AC_PACKAGE_VERSION], 1), 11,, [m4_fatal([AC_INIT should be called with package and version arguments])])dnl AC_SUBST([PACKAGE], ['AC_PACKAGE_TARNAME'])dnl AC_SUBST([VERSION], ['AC_PACKAGE_VERSION'])])dnl _AM_IF_OPTION([no-define],, [AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE", [Name of package]) AC_DEFINE_UNQUOTED(VERSION, "$VERSION", [Version number of package])])dnl # Some tools Automake needs. AC_REQUIRE([AM_SANITY_CHECK])dnl AC_REQUIRE([AC_ARG_PROGRAM])dnl AM_MISSING_PROG(ACLOCAL, aclocal-${am__api_version}) AM_MISSING_PROG(AUTOCONF, autoconf) AM_MISSING_PROG(AUTOMAKE, automake-${am__api_version}) AM_MISSING_PROG(AUTOHEADER, autoheader) AM_MISSING_PROG(MAKEINFO, makeinfo) AC_REQUIRE([AM_PROG_INSTALL_SH])dnl AC_REQUIRE([AM_PROG_INSTALL_STRIP])dnl AC_REQUIRE([AM_PROG_MKDIR_P])dnl # We need awk for the "check" target. The system "awk" is bad on # some platforms. AC_REQUIRE([AC_PROG_AWK])dnl AC_REQUIRE([AC_PROG_MAKE_SET])dnl AC_REQUIRE([AM_SET_LEADING_DOT])dnl _AM_IF_OPTION([tar-ustar], [_AM_PROG_TAR([ustar])], [_AM_IF_OPTION([tar-pax], [_AM_PROG_TAR([pax])], [_AM_PROG_TAR([v7])])]) _AM_IF_OPTION([no-dependencies],, [AC_PROVIDE_IFELSE([AC_PROG_CC], [_AM_DEPENDENCIES(CC)], [define([AC_PROG_CC], defn([AC_PROG_CC])[_AM_DEPENDENCIES(CC)])])dnl AC_PROVIDE_IFELSE([AC_PROG_CXX], [_AM_DEPENDENCIES(CXX)], [define([AC_PROG_CXX], defn([AC_PROG_CXX])[_AM_DEPENDENCIES(CXX)])])dnl AC_PROVIDE_IFELSE([AC_PROG_OBJC], [_AM_DEPENDENCIES(OBJC)], [define([AC_PROG_OBJC], defn([AC_PROG_OBJC])[_AM_DEPENDENCIES(OBJC)])])dnl ]) _AM_IF_OPTION([silent-rules], [AC_REQUIRE([AM_SILENT_RULES])])dnl dnl The `parallel-tests' driver may need to know about EXEEXT, so add the dnl `am__EXEEXT' conditional if _AM_COMPILER_EXEEXT was seen. This macro dnl is hooked onto _AC_COMPILER_EXEEXT early, see below. AC_CONFIG_COMMANDS_PRE(dnl [m4_provide_if([_AM_COMPILER_EXEEXT], [AM_CONDITIONAL([am__EXEEXT], [test -n "$EXEEXT"])])])dnl ]) dnl Hook into `_AC_COMPILER_EXEEXT' early to learn its expansion. Do not dnl add the conditional right here, as _AC_COMPILER_EXEEXT may be further dnl mangled by Autoconf and run in a shell conditional statement. m4_define([_AC_COMPILER_EXEEXT], m4_defn([_AC_COMPILER_EXEEXT])[m4_provide([_AM_COMPILER_EXEEXT])]) # When config.status generates a header, we must update the stamp-h file. # This file resides in the same directory as the config header # that is generated. The stamp files are numbered to have different names. # Autoconf calls _AC_AM_CONFIG_HEADER_HOOK (when defined) in the # loop where config.status creates the headers, so we can generate # our stamp files there. AC_DEFUN([_AC_AM_CONFIG_HEADER_HOOK], [# Compute $1's index in $config_headers. _am_arg=$1 _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`AS_DIRNAME(["$_am_arg"])`/stamp-h[]$_am_stamp_count]) # Copyright (C) 2001, 2003, 2005, 2008 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_INSTALL_SH # ------------------ # Define $install_sh. AC_DEFUN([AM_PROG_INSTALL_SH], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl if test x"${install_sh}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; *) install_sh="\${SHELL} $am_aux_dir/install-sh" esac fi AC_SUBST(install_sh)]) # Copyright (C) 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 2 # Check whether the underlying file-system supports filenames # with a leading dot. For instance MS-DOS doesn't. AC_DEFUN([AM_SET_LEADING_DOT], [rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null AC_SUBST([am__leading_dot])]) # Check to see how 'make' treats includes. -*- Autoconf -*- # Copyright (C) 2001, 2002, 2003, 2005, 2009 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 4 # AM_MAKE_INCLUDE() # ----------------- # Check to see how make treats includes. AC_DEFUN([AM_MAKE_INCLUDE], [am_make=${MAKE-make} cat > confinc << 'END' am__doit: @echo this is the am__doit target .PHONY: am__doit END # If we don't find an include directive, just comment out the code. AC_MSG_CHECKING([for style of include used by $am_make]) am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf # Ignore all kinds of additional output from `make'. case `$am_make -s -f confmf 2> /dev/null` in #( *the\ am__doit\ target*) am__include=include am__quote= _am_result=GNU ;; esac # Now try BSD make style include. if test "$am__include" = "#"; then echo '.include "confinc"' > confmf case `$am_make -s -f confmf 2> /dev/null` in #( *the\ am__doit\ target*) am__include=.include am__quote="\"" _am_result=BSD ;; esac fi AC_SUBST([am__include]) AC_SUBST([am__quote]) AC_MSG_RESULT([$_am_result]) rm -f confinc confmf ]) # Fake the existence of programs that GNU maintainers use. -*- Autoconf -*- # Copyright (C) 1997, 1999, 2000, 2001, 2003, 2004, 2005, 2008 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 6 # AM_MISSING_PROG(NAME, PROGRAM) # ------------------------------ AC_DEFUN([AM_MISSING_PROG], [AC_REQUIRE([AM_MISSING_HAS_RUN]) $1=${$1-"${am_missing_run}$2"} AC_SUBST($1)]) # AM_MISSING_HAS_RUN # ------------------ # Define MISSING if not defined so far and test if it supports --run. # If it does, set am_missing_run to use it, otherwise, to nothing. AC_DEFUN([AM_MISSING_HAS_RUN], [AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl AC_REQUIRE_AUX_FILE([missing])dnl if test x"${MISSING+set}" != xset; then case $am_aux_dir in *\ * | *\ *) MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;; *) MISSING="\${SHELL} $am_aux_dir/missing" ;; esac fi # Use eval to expand $SHELL if eval "$MISSING --run true"; then am_missing_run="$MISSING --run " else am_missing_run= AC_MSG_WARN([`missing' script is too old or missing]) fi ]) # Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_MKDIR_P # --------------- # Check for `mkdir -p'. AC_DEFUN([AM_PROG_MKDIR_P], [AC_PREREQ([2.60])dnl AC_REQUIRE([AC_PROG_MKDIR_P])dnl dnl Automake 1.8 to 1.9.6 used to define mkdir_p. We now use MKDIR_P, dnl while keeping a definition of mkdir_p for backward compatibility. dnl @MKDIR_P@ is magic: AC_OUTPUT adjusts its value for each Makefile. dnl However we cannot define mkdir_p as $(MKDIR_P) for the sake of dnl Makefile.ins that do not define MKDIR_P, so we do our own dnl adjustment using top_builddir (which is defined more often than dnl MKDIR_P). AC_SUBST([mkdir_p], ["$MKDIR_P"])dnl case $mkdir_p in [[\\/$]]* | ?:[[\\/]]*) ;; */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;; esac ]) # Helper functions for option handling. -*- Autoconf -*- # Copyright (C) 2001, 2002, 2003, 2005, 2008 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 4 # _AM_MANGLE_OPTION(NAME) # ----------------------- AC_DEFUN([_AM_MANGLE_OPTION], [[_AM_OPTION_]m4_bpatsubst($1, [[^a-zA-Z0-9_]], [_])]) # _AM_SET_OPTION(NAME) # ------------------------------ # Set option NAME. Presently that only means defining a flag for this option. AC_DEFUN([_AM_SET_OPTION], [m4_define(_AM_MANGLE_OPTION([$1]), 1)]) # _AM_SET_OPTIONS(OPTIONS) # ---------------------------------- # OPTIONS is a space-separated list of Automake options. AC_DEFUN([_AM_SET_OPTIONS], [m4_foreach_w([_AM_Option], [$1], [_AM_SET_OPTION(_AM_Option)])]) # _AM_IF_OPTION(OPTION, IF-SET, [IF-NOT-SET]) # ------------------------------------------- # Execute IF-SET if OPTION is set, IF-NOT-SET otherwise. AC_DEFUN([_AM_IF_OPTION], [m4_ifset(_AM_MANGLE_OPTION([$1]), [$2], [$3])]) # Check to make sure that the build environment is sane. -*- Autoconf -*- # Copyright (C) 1996, 1997, 2000, 2001, 2003, 2005, 2008 # Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 5 # AM_SANITY_CHECK # --------------- AC_DEFUN([AM_SANITY_CHECK], [AC_MSG_CHECKING([whether build environment is sane]) # Just in case sleep 1 echo timestamp > conftest.file # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[[\\\"\#\$\&\'\`$am_lf]]*) AC_MSG_ERROR([unsafe absolute working directory name]);; esac case $srcdir in *[[\\\"\#\$\&\'\`$am_lf\ \ ]]*) AC_MSG_ERROR([unsafe srcdir value: `$srcdir']);; esac # Do `set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` if test "$[*]" = "X"; then # -L didn't work. set X `ls -t "$srcdir/configure" conftest.file` fi rm -f conftest.file if test "$[*]" != "X $srcdir/configure conftest.file" \ && test "$[*]" != "X conftest.file $srcdir/configure"; then # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken alias in your environment]) fi test "$[2]" = conftest.file ) then # Ok. : else AC_MSG_ERROR([newly created file is older than distributed files! Check your system clock]) fi AC_MSG_RESULT(yes)]) # Copyright (C) 2001, 2003, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # AM_PROG_INSTALL_STRIP # --------------------- # One issue with vendor `install' (even GNU) is that you can't # specify the program used to strip binaries. This is especially # annoying in cross-compiling environments, where the build's strip # is unlikely to handle the host's binaries. # Fortunately install-sh will honor a STRIPPROG variable, so we # always use install-sh in `make install-strip', and initialize # STRIPPROG with the value of the STRIP variable (set by the user). AC_DEFUN([AM_PROG_INSTALL_STRIP], [AC_REQUIRE([AM_PROG_INSTALL_SH])dnl # Installed binaries are usually stripped using `strip' when the user # run `make install-strip'. However `strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the `STRIP' environment variable to overrule this program. dnl Don't test for $cross_compiling = yes, because it might be `maybe'. if test "$cross_compiling" != no; then AC_CHECK_TOOL([STRIP], [strip], :) fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" AC_SUBST([INSTALL_STRIP_PROGRAM])]) # Copyright (C) 2006, 2008 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 2 # _AM_SUBST_NOTMAKE(VARIABLE) # --------------------------- # Prevent Automake from outputting VARIABLE = @VARIABLE@ in Makefile.in. # This macro is traced by Automake. AC_DEFUN([_AM_SUBST_NOTMAKE]) # AM_SUBST_NOTMAKE(VARIABLE) # --------------------------- # Public sister of _AM_SUBST_NOTMAKE. AC_DEFUN([AM_SUBST_NOTMAKE], [_AM_SUBST_NOTMAKE($@)]) # Check how to create a tarball. -*- Autoconf -*- # Copyright (C) 2004, 2005 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # serial 2 # _AM_PROG_TAR(FORMAT) # -------------------- # Check how to create a tarball in format FORMAT. # FORMAT should be one of `v7', `ustar', or `pax'. # # Substitute a variable $(am__tar) that is a command # writing to stdout a FORMAT-tarball containing the directory # $tardir. # tardir=directory && $(am__tar) > result.tar # # Substitute a variable $(am__untar) that extract such # a tarball read from stdin. # $(am__untar) < result.tar AC_DEFUN([_AM_PROG_TAR], [# Always define AMTAR for backward compatibility. AM_MISSING_PROG([AMTAR], [tar]) m4_if([$1], [v7], [am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -'], [m4_case([$1], [ustar],, [pax],, [m4_fatal([Unknown tar format])]) AC_MSG_CHECKING([how to create a $1 tar archive]) # Loop over all known methods to create a tar archive until one works. _am_tools='gnutar m4_if([$1], [ustar], [plaintar]) pax cpio none' _am_tools=${am_cv_prog_tar_$1-$_am_tools} # Do not fold the above two line into one, because Tru64 sh and # Solaris sh will not grok spaces in the rhs of `-'. for _am_tool in $_am_tools do case $_am_tool in gnutar) for _am_tar in tar gnutar gtar; do AM_RUN_LOG([$_am_tar --version]) && break done am__tar="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$$tardir"' am__tar_="$_am_tar --format=m4_if([$1], [pax], [posix], [$1]) -chf - "'"$tardir"' am__untar="$_am_tar -xf -" ;; plaintar) # Must skip GNU tar: if it does not support --format= it doesn't create # ustar tarball either. (tar --version) >/dev/null 2>&1 && continue am__tar='tar chf - "$$tardir"' am__tar_='tar chf - "$tardir"' am__untar='tar xf -' ;; pax) am__tar='pax -L -x $1 -w "$$tardir"' am__tar_='pax -L -x $1 -w "$tardir"' am__untar='pax -r' ;; cpio) am__tar='find "$$tardir" -print | cpio -o -H $1 -L' am__tar_='find "$tardir" -print | cpio -o -H $1 -L' am__untar='cpio -i -H $1 -d' ;; none) am__tar=false am__tar_=false am__untar=false ;; esac # If the value was cached, stop now. We just wanted to have am__tar # and am__untar set. test -n "${am_cv_prog_tar_$1}" && break # tar/untar a dummy directory, and stop if the command works rm -rf conftest.dir mkdir conftest.dir echo GrepMe > conftest.dir/file AM_RUN_LOG([tardir=conftest.dir && eval $am__tar_ >conftest.tar]) rm -rf conftest.dir if test -s conftest.tar; then AM_RUN_LOG([$am__untar /dev/null 2>&1 && break fi done rm -rf conftest.dir AC_CACHE_VAL([am_cv_prog_tar_$1], [am_cv_prog_tar_$1=$_am_tool]) AC_MSG_RESULT([$am_cv_prog_tar_$1])]) AC_SUBST([am__tar]) AC_SUBST([am__untar]) ]) # _AM_PROG_TAR spd-1.3.0/ChangeLog0000644000175000017500000000023111643121541010766 00000000000000Update 04/10/2011 J. Kieffer (jerome.kieffer@esrf.fr) Changed to autotools for compilation. Use autoreconf then ./configure; make ; make install spd-1.3.0/edfpack/0000755000175000017500000000000011655563114010706 500000000000000spd-1.3.0/edfpack/arc.h0000644000175000017500000001134311633462461011545 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME arc.h SYNOPSIS #include "arc.h" DESCRIPTION Header of the module "arc.c" ***********************************************************************---*/ #ifndef _ARC_ # define _ARC_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include # include # include "reference.h" # include "numio.h" # include "ipol.h" # include "waxs.h" /*===========================================================================*/ /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern int ang_range ( int rsys, int proin, int proout, long dim_1, long dim_2, float off_1, float pix_1, float cen_1, float off_2, float pix_2, float cen_2, float dis, float wvl, float rot1, float rot2, float rot3, WaxsCoord *Wmin, WaxsCoord *Wmax, int * pstatus); PUBLIC extern void ang_limits( WaxsCoord Wmin, WaxsCoord Wmax, WaxsCoord *Amin, WaxsCoord *Amax, int * pstatus); PUBLIC extern void arc_sum ( int rsys, float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float I0Offset_1, float I0PSize_1, float I0Center_1, float I0Offset_2, float I0PSize_2, float I0Center_2, float I0SampleDistance, float I0WaveLength, int I0Pro, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float I1Offset_1, float I1PSize_1, float I1Center_1, float I1Offset_2, float I1PSize_2, float I1Center_2, float I1SampleDistance, float I1WaveLength, float I1DetRot1, float I1DetRot2, float I1DetRot3, int I1Pro, float I1Dummy, float I1DDummy, float AngleMin, float AngleMax, float Shift_1, float Shift_2, int vsum, int ave, int testbit, int * pstatus ), ang_sum ( int rsys, float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float I0Offset_1, float I0PSize_1, float I0Center_1, float I0Offset_2, float I0PSize_2, float I0Center_2, float I0SampleDistance, float I0WaveLength, int I0Pro, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float I1Offset_1, float I1PSize_1, float I1Center_1, float I1Offset_2, float I1PSize_2, float I1Center_2, float I1SampleDistance, float I1WaveLength, float I1DetRot1, float I1DetRot2, float I1DetRot3, int I1Pro, float I1Dummy, float I1DDummy, float AngleMin, float AngleMax, float Shift_1, float Shift_2, int vsum, int ave, int testbit, int * pstatus ); #endif spd-1.3.0/edfpack/cmpr.h0000755000175000017500000000710511633462462011746 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ #ifndef _CMPR_ # define _CMPR_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif #ifndef TRUE # define TRUE 1 # define FALSE 0 #endif # include # include # include # include /*************************************************************************** * Data Compression Methods (cmpr_method) * * The following enum start with 1. 0 is used to specify an invalid value. * * The enum list must end with EndDCompression. * ***************************************************************************/ PUBLIC enum DCompression { InValidDCompression, UnCompressed=1, GzipCompression, ZCompression, EndDCompression }; /*************************************************************************** * Functions * * int cmpr_method is the compression method (DCompression), * * size_t *pconverted are the valid bytes in the output array * ***************************************************************************/ // compress array inp[inplen] to array out[outlen] PUBLIC extern int cmpr_deflate ( void * out, size_t outlen, const void * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ); // decompress array inp[inplen] to array out[outlen] PUBLIC extern int cmpr_inflate ( void * out, size_t outlen, const void * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ); // decompress not more than inplen bytes from file to array out[outlen] PUBLIC extern int cmpr_frinflate ( void * out, size_t outlen, FILE * channel, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ); PUBLIC extern void cmpr_debug ( int debug ); PUBLIC extern const char *cmpr_errval2string(int errval); PUBLIC extern const char *cmpr_version ( void ); #endif spd-1.3.0/edfpack/gamma.h0000644000175000017500000000510211633462461012056 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME gamma.h SYNOPSIS #include "gamma.h" DESCRIPTION Header of the module "gamma.c" ***********************************************************************---*/ #ifndef _GAMMA_ # define _GAMMA_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static // used to declare variables of private type #endif #ifndef PUBLIC # define PUBLIC // used to declare variables of public type #endif /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern double gamma( double X ), // gamma function loggamma( double X ); // logarithm of gamma function (X>0) #endif spd-1.3.0/edfpack/numio.h0000644000175000017500000002126711633462462012136 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME numio.h SYNOPSIS #include "numio.h" DESCRIPTION Header of the module "numio.c" ***********************************************************************---*/ #ifndef _numio_ # define _numio_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static // used to declare variables of private type #endif #ifndef PUBLIC # define PUBLIC // used to declare variables of public type #endif /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include # include "gamma.h" /****************************************************************************** * Constants * ******************************************************************************/ # define NUM_PI 3.1415926535897932384626 /**************************************************************************** * Number Program List Structure Definition * ****************************************************************************/ typedef struct Num_Var { char * Key; /* Pointer to variable key string */ double Value; /* Value of the variable */ int Used; /* number of uses */ struct Num_Var *Previous,*Next; /* prev./next variables */ } NumVar; typedef struct Num_Accu { long Number; /* Accumulator number */ double Value; /* Value of the accumulator */ struct Num_Accu *Previous,*Next; /* prev./next accumulators */ } NumAccu; typedef struct Num_Instr { int Command; /* Command */ int Nargs; /* Number of required parameters */ double Value; /* Value */ double *Address; /* Address */ struct Num_Instr *Previous,*Next; /*prev./next instructs.*/ } NumInstr; typedef struct Num_Prog { char * Name; /* pointer to name string */ NumVar * VariableList; /* list of variables */ NumAccu * AccumulatorList; /* list of accumulators */ NumAccu * CurrentAccumulator; /* pointer to current accumulators */ NumInstr * InstructionList; /* list of instructions */ NumInstr * CompiledList; /* list of compiled instructions */ struct Num_Prog *Previous,*Next; /* previous and next program */ } NumProg; /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern long num_str2long ( const char *str, const char **tail, int *perrval); PUBLIC extern double num_str2double ( const char *str, const char **tail, int *perrval); PUBLIC extern char *num_long2str ( char buffer[], unsigned long buflen, long value, int * perrval ); PUBLIC extern char *num_long2hex ( char buffer[], unsigned long buflen, long value, int * perrval ); PUBLIC extern char *num_double2str ( char buffer[], unsigned long buflen, double value, const char * unit, int ndigits, int * perrval ); PUBLIC extern char *num_double2hex( char buffer[], unsigned long buflen, double value, int ndigits, int * perrval ); PUBLIC extern NumProg *num_str2prog ( const char *name, const char *str, const char **tail, int *perrval, int nvar, ... ); PUBLIC extern int num_chkvar ( NumProg * program, int n, int *perrval ); PUBLIC extern double num_runprog ( NumProg * program, int *perrval, ... ); PUBLIC extern NumProg *num_searchprog ( const char *name, int *perrval ); PUBLIC extern int num_rmprog ( NumProg * program, int *perrval ); PUBLIC extern char *num_errval2str ( char buffer[], unsigned long buflen, int errval ); PUBLIC extern int num_strncasecmp(const char *s1, const char *s2, size_t n); PUBLIC extern void numio_debug ( int debug ); PUBLIC extern char *numio_version ( void ); PUBLIC extern long num_prog_variables ( NumProg *program ); PUBLIC extern long num_prog_accumulators ( NumProg *program ); PUBLIC extern long num_prog_instructions ( NumProg *program, int mode); PUBLIC extern size_t num_prog_variable_size ( NumProg *program ); PUBLIC extern size_t num_prog_accumulator_size ( NumProg *program ); PUBLIC extern size_t num_prog_instruction_size ( NumProg *program, int mode); PUBLIC extern size_t num_prog_size ( NumProg * program ); PUBLIC extern size_t num_prog_size_all ( void ); PUBLIC extern int num_prog_print_variable_list ( FILE * out, NumProg *program, int level, int verbose ); PUBLIC extern int num_prog_print_accumulator_list ( FILE * out, NumProg *program, int level, int verbose ); PUBLIC extern int num_prog_print_instruction_list ( FILE * out, NumProg *program, int mode, int level, int verbose ); PUBLIC extern int num_prog_print_list ( FILE * out, NumProg * program, int level, int verbose ); /*************************************************************************** * Error Values * ***************************************************************************/ # define NumSuccess 0 # define NumMemoryAllocationError 1 # define NumScanError 2 # define NumCommaExpected 3 # define NumBadParenthesis 4 # define NumNoFloatNumber 5 # define NumNoFloatFunction 6 # define NumDomainError 7 # define NumNoIntegerNumber 8 # define NumIntegerOverflow 9 # define NumDivByZero 10 # define NumWriteError 11 # define NumNoVariable 12 # define NumVariableError 13 # define NumProgramError 14 # define NumNoInstruction 15 # define NumNoAccumulator 16 #endif spd-1.3.0/edfpack/project.h0000644000175000017500000000607211633462462012452 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME project.h SYNOPSIS #include "project.h" DESCRIPTION Header of the module "project.c" ***********************************************************************---*/ /**************************************************************************** * Include * ****************************************************************************/ # include # include # include "ipol.h" # include "reference.h" /*************************************************************************** * Functions * ***************************************************************************/ #ifndef _PROJECT_ # define PROJECT_VERSION "project : V1.01 Peter Boesecke 2009-11-10" extern void project_1 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float Df_1, float f1_2, float f3_2, float dummy, float ddummy, int ave ), project_2 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float f1_2, float f3_2, float Df_2, float dummy, float ddummy, int ave ); # define _PROJECT_ #endif /* _PROJECT_ */ /**************************************************************************** * * ****************************************************************************/ spd-1.3.0/edfpack/polarization.c0000644000175000017500000004626011633462461013514 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define POLARIZATION_VERSION "polarization : V1.61 Peter Boesecke 2011-07-11" /*+++------------------------------------------------------------------------ NAME polarization --- routines for polarization correction SYNOPSIS # include waxs.h # include polarization.h HISTORY 2004-07-27 V1.0 2004-07-28 V1.1 polarization_Init(..., int Invert) added 2004-10-31 V1.2 polarization_Init(..., double Factor, ...) added 2010-03-18 V1.3 include reference.h for ProjectionType 2010-12-12-V1.5 unused PolarizationParams removed 2011-06-22 V1.6 orientation recalculation 1..16 added 2011-07-11 V1.61 polarization.h: Ori was double, defined as long int DESCRIPTION The function polarization_factor calculates the polarization factor for coordinates in the SAXS reference system (see *). The image can either be an Ewald-sphere projection of a scattering pattern (waxs-projection) or a flat detector pattern (saxs-projection). Three parameters describe the polarization of the incident beam: the polarization P (0<=P<=1), the ellipticity PChi (-pi/4<=PChi<=pi/4) and the inclination PPsi (0<=PPsi<=pi) of the polarization plane. The ellipticity PChi is zero for linear polarization. For circular polarization its absolute value is pi/4 and smaller for elliptical polarization. The polarization factor is symmetric for PChi and therefore independent of the helicity. The angle PPsi describes a ccw rotation of the polarization plane around axis x_3 with respect to the x_1 axis in orientation 1. Orientation 1 corresponds to a righhanded coordinate system with the axes x_1, x_2 and x_3 where x_1 is horizontal and pointing to the right, axis x_2 is pointing upwards and axis x_3 against the observer and against the travelling direction of the incident beam. The image is observed in the x_1, x_2 plane. For a different orientation an internal OPsi is recalculated accordingly: orientation OPsi 1 : 1, 2, 3 PPsi 2 : -1, 2, 3 -PPsi+pi 3 : 1,-2, 3 -PPsi 4 : -1,-2, 3 PPsi-pi 5 : 2, 1, 3 -PPsi+pi/2 6 : 2,-1, 3 PPsi-pi/2 7 : -2, 1, 3 PPsi+pi/2 8 : -2,-1, 3 -PPsi-pi/2 9 : 1, 2,-3 PPsi 10: -1, 2,-3 -PPsi+pi 11: 1,-2,-3 -PPsi 12: -1,-2,-3 PPsi-pi 13: 2, 1,-3 -PPsi+pi/2 14: 2,-1,-3 PPsi-pi/2 15: -2, 1,-3 PPsi+pi/2 16: -2,-1,-3 -PPsi-pi/2 In the following, 3d vectors are followed by '~', the length of a vector is just its name: e.g. kin = ||kin~||. Vectors with unit length are followed by '^', e.g. kin^ = kin~/kin. kin~ : wavevector of incident beam (i) kout~ : wavevector of scattered beam s~ = kout~ - kin~ : scattering vector The scattering is elastic. The wavenumber k of kin~ and kout~ is: (ii) k = 1/wavelength = kin = kout Scattering Geometry The input image must be an Ewald sphere projection of the scattering pattern as created with saxs_waxs. The unit vectors in lab space are: e1^, e2^, e3^. Axis 3 in lab space is parallel to axis 3 of the projection. The azimuths of the axes 1 and 2 of the projections are identical to the azimuths of the axes 1 and 2 in lab space. For details see waxs.c. The incident beam (kin~) is antiparallel to axis3. (iii) kin~ = -kin * e3^ The saxs-coordinates sp_1 and sp_2 of the input image are: (iv) sp_1 = s * cos(alpha) sp_2 = s * sin(alpha) From sp_1 and sp_2 the direction kout^ of the scattered beam is calculated using the routine waxs_sp2kdir: ( sin(2Theta)*cos(alpha) ) ( kout1 ) (v) kout^ = | sin(2Theta)*sin(alpha) | = | kout2 | ( -cos(2Theta) ) ( kout3 ) *) coordinates in the SAXS reference system: sp_1 = k * ((x_1+off_1) - cen_1) * (pix_1/dis) sp_2 = k * ((x_2+off_2) - cen_2) * (pix_2/dis) where x_1, x_2 are the pixel coordinates, off_1,off_2, the offsets, cen_1,cen_2 the point of normal incidence ("poni", "center"), pix_1,pix_2, the pixel sizes, dis the distance between the sample and the point of normal incidence and k the wavenumber (1/wavelength). SAXS-coordinates are correspondingly defined in the unprojected and in the projected image. Polarization factor The E-vector Eout of the scattered beam kout is proportional to the projection of the E-vector Ein of the incident beam kin to the transversal plane of the scattered beam: (vi) Eout = f * ( Ein - kout^ (kout^*Ein) ) The scattered intensity Iout is given by (vii) Iout = where Eout* denotes the complex conjugate of Eout. Applying eq. vii to eq. vi gives the result (viii) Iout = f*f ( - <(kout^ * Ein)*(kout^ * Ein*)> ) Die incident wave is transverse to axis 3 and can be described with ( a1*exp(i*(phi1-2*pi*ny*t)) ) (ix) Ein = | a2*exp(i*(phi2-2*pi*ny*t)) | ( 0 ) where a1 and a2 are the real electric amplitudes, phi1 and phi2 the phases, ny the frequency and t the time. The description of polarization follows the notation of Born and Wolf [1]. Inserting eq. 9 into eq. viii returns the result Iout = f*f * ( (1-kout1*kout1) * (s0+s1)/2 (x) + (1-kout2*kout2) * (s0-s1)/2 - kout1*kout2 * s2 ) where s0, s1 and s2 are the Stokes parameter of the incident wave. The Stokes parameters describe the polarization of the incident wave and are related to a1, a2 and delta=phi1-phi2 in the following way. (xi a) = (so+s1)/2 (xi b) = (so-s1)/2 (xi c) <2*a1*a2*cos(delta)> = s2 (xi d) <2*a1*a2*sin(delta)> = s3 The Stokes parameter of the incident wave can be separated into an unpolarized s(1) and a polarized part s(2): (xii a) s = s(1) + s(2) = ( s0, s1, s2, s3 ) (xii b) s(1) = ( (1-P)*s0, 0, 0, 0 ) (xii c) s(2) = ( P*s0, s1, s2, s3 ) where P is the polarization (0<=P<=1). If P is 0 the wave is totally unpolarized, if P is 1 the wave is totally polarized. The polarized portion s(2) can be described by the Poincaré notation: (xiii a) s0(2)+s1(2) = P*so+s1 = P*so*(1+cos(2*PChi)*cos(2*PPsi)) (xiii b) s0(2)-s1(2) = P*so-s1 = P*so*(1-cos(2*PChi)*cos(2*PPsi)) (xiii c) s2(2) = s2 = P*so*cos(2*PChi)*sin(2*PPsi) with P : degree of polarization (0<=P<=1) PChi : ellipticity (after Poincaré) (-pi/4<=PChi<=+pi/4) PChi=-pi/4 left hand (cw) circular polarization PChi<0 left hand polarization PChi==0 linear polarization PChi>0 right hand polarization PChi=pi/4 right hand (ccw) circular polarization PPsi : inclination of the plane of polarization (after Poincaré) (0<=PPsi0 right hand polarization // PChi=pi/4 right hand (ccw) circular polarization ppsi = 0.0; // inclination of the plane of polarization (after Poincaré) // (0<=PPsiInit) return; fprintf(out," Init = %d\n", pParams->Init); fprintf(out," Ori = %ld\n", pParams->Ori); fprintf(out," P = %lg\n", pParams->P); fprintf(out," PChi = %lg\n", pParams->PChi); fprintf(out," PPsi = %lg\n", pParams->PPsi); fprintf(out," Factor = %lg\n", pParams->Factor); fprintf(out," Invert = %d\n", pParams->Invert); fprintf(out," halfOnePlusCos2ChiCos2Psi = %lg\n", pParams->halfOnePlusCos2ChiCos2Psi); fprintf(out," halfOneMinusCos2ChiCos2Psi = %lg\n", pParams->halfOneMinusCos2ChiCos2Psi); fprintf(out," Cos2ChiSin2Psi = %lg\n", pParams->Cos2ChiSin2Psi); waxs_PrintParams( out, pParams->wparams ); } // polarization_PrintParams /*+++------------------------------------------------------------------------ NAME polarization_Init --- Initialisation of parameters SYNOPSIS int polarization_Init ( PParams * pParams, long ori, double k, double rot1, double rot2, double rot3, double P, double PChi, double PPsi, double Factor, int Invert ); DESCRIPTION It initializes all static parameters. ARGUMENTS ori : orientation (default: 1) k : wavenumber rot1, rot2, rot3 : detector rotations as defined in waxs.c P : degree of polarization (0<=P<=1) PChi : ellipticity (after Poincaré) (-pi/4<=PChi<=+pi/4) PChi=-pi/4 left hand (cw) circular polarization PChi<0 left hand polarization PChi==0 linear polarization PChi>0 right hand polarization PChi=pi/4 right hand (ccw) circular polarization PPsi : inclination of the plane of polarization (after Poincaré) (0<=PPsiInit = 0; // Initialize waxs (not rotated) if ( waxs_Init ( &(pParams->wparams), k, rot1, rot2, rot3 ) ) return( -1 ); // Polarization if ( ( P < 0.0 ) || ( P > 1.0 ) ) return( -1 ); pParams->P = P; // Orientation change if (ori<0) ori=raster_inversion ( -ori ); pParams->Ori = ori; switch (ori) { case 2: // 2 : -1, 2, 3 -PPsi+R_PI case 10: // 10: -1, 2,-3 -PPsi+R_PI OPsi=-PPsi+R_PI; break; case 3: // 3 : 1,-2, 3 -PPsi case 11: // 11: 1,-2,-3 -PPsi OPsi=-PPsi; break; case 4: // 4 : -1,-2, 3 PPsi-R_PI case 12: // 12: -1,-2,-3 PPsi-R_PI OPsi=PPsi-R_PI; break; case 5: // 5 : 2, 1, 3 -PPsi+R_PI/2 case 13: // 13: 2, 1,-3 -PPsi+R_PI/2 OPsi=-PPsi+R_PI/2; case 6: // 6 : 2,-1, 3 PPsi-R_PI/2 case 14: // 14: 2,-1,-3 PPsi-R_PI/2 OPsi=PPsi-R_PI/2; break; case 7: // 7 : -2, 1, 3 PPsi+R_PI/2 case 15: // 15: -2, 1,-3 PPsi+R_PI/2 OPsi=PPsi+R_PI/2; break; case 8: // 8 : -2,-1, 3 -PPsi-R_PI/2 case 16: // 16: -2,-1,-3 -PPsi-R_PI/2 OPsi=-PPsi-R_PI/2; break; default: // 1 : 1, 2, 3 PPsi // 9 : 1, 2,-3 PPsi OPsi=PPsi; } // Poincaré parameters if ( ( PChi<-quarterpi-qpi_eps ) || ( PChi>quarterpi+qpi_eps ) ) return( -1 ); pParams->PChi = PChi; pParams->PPsi = OPsi; if ( Factor <= 0 ) return( -1 ); pParams->Factor=Factor; pParams->Invert=Invert; Cos2Chi=cos(2.0*PChi); Sin2Chi=sin(2.0*PChi); Cos2Psi=cos(2.0*OPsi); Sin2Psi=sin(2.0*OPsi); pParams->halfOnePlusCos2ChiCos2Psi = (1.0+Cos2Chi*Cos2Psi)*0.5; pParams->halfOneMinusCos2ChiCos2Psi = (1.0-Cos2Chi*Cos2Psi)*0.5; pParams->Cos2ChiSin2Psi = Cos2Chi*Sin2Psi; pParams->Init = 1; return( 0 ); } // polarization_Init /*+++------------------------------------------------------------------------ NAME polarization_factor --- calculates the polarization factor SYNOPSIS double polarization_factor ( PParams * pParams, WaxsCoord wc, int projection ) DESCRIPTION Calculates the polarization factor from the saxs-coordinate wc of the Ewald sphere-projection. ARGUMENT WaxsCoord wc : World Coordinate (SAXS or WAXS) int projection : World Coordinate type (ProjectionType) IO_NoPro : invalid (0) IO_ProSaxs : flat detector (SAXS-coordinate) (1) IO_ProWaxs : Ewald sphere-projection (WAXS-coordinate) (2) Attention, analogue definition of ProjectionType in SaxsImage.h, do not change order. RETURN VALUE double polarization factor >= 0: in case of an error the returned value is negative ----------------------------------------------------------------------------*/ double polarization_factor ( PParams * pParams, WaxsCoord wc, int projection ) { double kvec[3]; WaxsDir kdir; double Iu, Ip; double Value; if (!pParams) return(-2); // pParams initialized if (!pParams->Init) return( -1 ); switch ( projection ) { case IO_ProSaxs: // calculate kdir from scattering vector s kdir = waxs_s2kdir ( &(pParams->wparams), wc ); break; case IO_ProWaxs: // calculate kdir from Ewald - sphere projection kdir = waxs_sp2kdir ( &(pParams->wparams), wc ); break; default: return( -1 ); } if (kdir.status) return( -1 ); kvec[0] = kdir.sinTwoTheta*kdir.cosAlpha; kvec[1] = kdir.sinTwoTheta*kdir.sinAlpha; kvec[2] = -kdir.cosTwoTheta; // unpolarized part Iu = (1.0-pParams->P)*0.5*(1.0+kvec[2]*kvec[2]); Ip = pParams->P*( (1.0-kvec[0]*kvec[0])*pParams->halfOnePlusCos2ChiCos2Psi + (1.0-kvec[1]*kvec[1])*pParams->halfOneMinusCos2ChiCos2Psi + kvec[0]*kvec[1] *pParams->Cos2ChiSin2Psi ); Value = (Iu+Ip)*pParams->Factor; if (pParams->Invert) { if (Value>0) Value=1.0/Value; else return( -1 ); } return( Value ); } // polarization_factor spd-1.3.0/edfpack/ipol.h0000644000175000017500000002324611633462461011750 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME ipol.h SYNOPSIS #include "ipol.h" DESCRIPTION Header of the module "ipol.c" The header contains the following standard definitions: Array element access: ABSPTR, NEXTCOL, NEXTROW, NEXTCOLROW Dummy value definitions: MinDDummy, AccDummy, VarDummy Dummy value macros: DDSET, DUMMYDEFINED, NODUMMYDEFINED, DUMMY, NODUMMY, UPDATE Functions for linear two dimensional interpolation/integration: Isum2ldwE --- Area integral (+dummies, +limit checks, +weight, +variance) Isum2ldw --- Area integral (+dummies, +limit checks, +weight) Ipol2ldw --- Area interpolation (+dummies, +limit checks, +weight) Ipol2ld --- Area interpolation (+dummies, +limit checks) Ipol2 --- Area interpolation (-dummies, -limit checks) Ipolmin --- set/return minimum accepted coverage ratio Ipolmode --- set/return interpolation mode Ipolmode2str --- return interpolation mode string Ipolweight --- set/return weighting method Ipolweight2str --- return weighting method string IpolRebin2 --- rebinning of an array ***********************************************************************---*/ #ifndef _IPOL_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include /*************************************************************************** * MACROS * ***************************************************************************/ /*--------------------------------------------------------------------------- The constant IPOLEPS defines the interval around an array element in which no interpolation takes place. ---------------------------------------------------------------------------*/ # define IPOLEPS 1e-4 /*--------------------------------------------------------------------------- The constants IPOL_NORMAL and IPOL_ANTIALIASED are used to set the interpolation mode with the routine Ipolmod. ---------------------------------------------------------------------------*/ # define IPOL_NORMAL 1 # define IPOL_ANTIALIASED 2 /*--------------------------------------------------------------------------- The constants IPOL_EQUAL and IPOL_WEIGHTED are used to set the weight mode with the routine Ipolweight ---------------------------------------------------------------------------*/ # define IPOL_EQUAL 4 # define IPOL_WEIGHTED 8 /*--------------------------------------------------------------------------- Some internal macros ---------------------------------------------------------------------------*/ # define IPOL_ABS( x) ( ( x)> 0 ? ( x) : -( x) ) # define IPOL_MAX2( x1, x2) ( ( x1)>( x2) ? ( x1) : ( x2) ) # define IPOL_MIN2( n1, n2) ( ( n1)<( n2) ? ( n1) : ( n2) ) /*--------------------------------------------------------------------------- IDX Calculation of the integer part and the rest of a float pixel index. IDX calculates to the float value f the closest integer number I less than f and the difference R = f - (float) I. Usage : float f; int I; float R; IDX( f, I, R ); ---------------------------------------------------------------------------*/ #define IDX(f,I,R) (I)=floor(f);(R)=(f)-(float)(I) /*--------------------------------------------------------------------------- The following macros calcuate the pointers to array elements. - ABSPTR calculates the pointer to the array element (column=i_1, row=i_2) from the base Data of the array. The next three macros are used for interpolation between neighbouring data point. -NEXTCOL returns the pointer to the element in the next column of the same row -NEXTROW returns the pointer to the element in the next row of the same column -NEXTCOLROW returns the pointer to the element in the next column of the next row. Usage: Data[Dim_1,Dim_2] : array of size Dim_1,Dim_2; int i_1,i_2 : array indices *pdata, *pvalnxtcoli, *pvalnxtrow, *pvalnxtcolrow; pdata = ABSPTR(Data,Dim_1,Dim_2,i_1,i_2); pvalnxtcol = NEXTCOL(pdata,Dim_1,Dim_2); pvalnxtrow = NEXTROW(pdata,Dim_1,Dim_2); pvalnxtcolrow = NEXTCOLROW(pdata,Dim_1,Dim_2); ---------------------------------------------------------------------------*/ #define ABSPTR(A,D1,D2,I1,I2) (A)+((I1)+((I2)*(D1))) #define NEXTCOL(pA,D1,D2) (pA)+1 #define NEXTROW(pA,D1,D2) (pA)+(D1) #define NEXTCOLROW(pA,D1,D2) (pA)+(1+(D1)) /*---------------------------------------------------------------------------- Dummy Value Definitions MinDDummy minimum possible value for DDummy AccDummy relative accuracy VarDummy unchangeable dummy value of variance array DDSET(Dummy) calculation of a good DDummy value to Dummy DUMMY(Value, Dummy, DDummy) TRUE if value is a Dummy NODUMMY(Value, Dummy, DDummy) TRUE if value is not a Dummy UPDATE(Destination,Value,Dummy,DDummy) adds Value to Destination if not Dummy Usage: DDummy = DDSET(Dummy); if DUMMYDEFINED (Dummy, DDummy) ... if DUMMY(Value, Dummy, DDummy) { do something } else { do something else }; if NODUMMY(Value, Dummy, DDummy) { do something } else { do something else }; UPDATE( Destination, Value, Dummy, DDummy); ---------------------------------------------------------------------------*/ # define MinDDummy 0.1 # define AccDummy 1e-5 # define VarDummy -1.0 # define DDSET(D) IPOL_MAX2(MinDDummy,IPOL_ABS(D)*AccDummy) # define DUMMYDEFINED( D, DD) ((IPOL_ABS(D)>IPOL_MAX2(DD,MinDDummy)) ? 1 : 0) # define NODUMMYDEFINED(D, DD) ((IPOL_ABS(D)>IPOL_MAX2(DD,MinDDummy)) ? 0 : 1) # define DUMMY( V, D, DD) ((IPOL_ABS((V)-(D))<=DD)&&DUMMYDEFINED(D,DD)) # define NODUMMY( V, D, DD) ((IPOL_ABS((V)-(D))>DD)||NODUMMYDEFINED(D,DD)) # define UPDATE( DE, V, D, DD) if (DUMMY(DE,(D),(DD))) DE=(V); else DE+=(V) /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern void Ipol2 ( float *Data, int Dim_1, int Dim_2, float f_1, float f_2, float *value), IpolRebin2 ( float *Data, int Dim_1, int Dim_2, float *DataOut, int *pOutDim_1, int *pOutDim_2, float Dummy, float DDummy, int Bin_1, int Bin_2, int Average ); PUBLIC extern int Isum2ldwE ( float *Data, float *VarDat, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight, float *varsum, float *varweight), Isum2ldw ( float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight), Ipol2ldw ( float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f_1, float f_2, float *sum, float *weight), Ipol2ld ( float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f_1, float f_2, float *value), Ipol2d ( float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f_1, float f_2, float *value); PUBLIC extern float Ipolmin ( float minimum ); PUBLIC extern int Ipolmode ( int mode ), Ipolweight ( int method ); PUBLIC extern const char *Ipolmode2str ( int mode ), *Ipolweight2str ( int method ); # define _IPOL_ #endif /* _IPOL_ */ /**************************************************************************** * * ****************************************************************************/ spd-1.3.0/edfpack/gamma.c0000644000175000017500000001146211633462461012057 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++ NAME gamma.c --- Gamma Function SYNOPSIS double gamma( double X ); HISTORY 2000-11-28 V1.0 Peter Boesecke translated from PEARL function GAMMA PB 19-APR-1988 from COLLECTED ALGORITHMS FROM CACM 31-P 1- 0 ALGORITHM 31 (in ALGOL ) 2000-12-01 V1.01 calculation corrected 2000-12-04 V1.02 -> gamma.c, .h 2000-12-06 V1.03 Stirling's formula for x>20 ---*/ /**************************************************************************** * Include * ****************************************************************************/ # include "gamma.h" # define GAMMA_PI 3.1415926535897932384626 double _loggamma( double x ) { // by Stirling's formula Knuth I: 111 double invx, invx2, invx3, invx5, invx7; double sum=0.0; x -= 1.0; if (x <= 1.0) return( 1.0 ); invx = 1.0 / x; invx2 = invx * invx; invx3 = invx2 * invx; invx5 = invx3 * invx2; invx7 = invx5 * invx2; sum = ((x + 0.5) * log(x)) - x; sum += log(2*GAMMA_PI) * 0.5; sum += (invx / 12.0) - (invx3 / 360.0); sum += (invx5 / 1260.0) - (invx7 / 1680.0); return ( sum ); } /* _loggamma */ /*+++------------------------------------------------------------------------ NAME gamma --- gamma function SYNOPSIS double gamma( double X ); DESCRIPTION For 2<=x<=3 gamma is approximated. In this interval the absolut error abs(eps(x))<0.25*1e-7. For x>3 gamma(x) is calculated by iteration gamma(x) = (x-1) * (x-2) * ... * (x-n)*gamma(x-n), with 2<=(x-n)<=3. For x<2 gamma(x) = gamma(x+n) / ( x*(x+1)...(x+n-1) ) again with 2<=(x-n)<=3. For x=0 or a negative integer gamma(x) is set to DBL_MAX. RETURN VALUE gamma(x) ----------------------------------------------------------------------------*/ double gamma( double X ) { const double EPSMIN = 1e-30; const double EPS = 1e-6; const double DUMVAL = DBL_MAX; const double a0=.9999999758, a1=.4227874605, a2=.4117741955, a3=.0821117404; const double a4=.0721101567, a5=.0044511400, a6=.0051589951, a7=.0016063118; double GAMMA_WERT; double H,Y; H = 1.0; Y = X; while ( (fabs(Y-2.0)) >= EPS ) { if ( fabs(Y)=20.0) { H = exp(_loggamma( Y )); break; } else if (Y>=3.0) { Y = Y-1.0;H=H*Y; } else { Y=Y-2.0; H = (((((((a7*Y+a6)*Y+a5)*Y+a4)*Y+a3)*Y+a2)*Y+a1)*Y+a0)*H; break; } } GAMMA_WERT = H; return ( GAMMA_WERT ); } /* gamma */ /*+++------------------------------------------------------------------------ NAME loggamma --- natural logarithm of gamma function SYNOPSIS double loggamma( double X ); DESCRIPTION Calculation of the natural logarithm of gamma for positive X. For X==0 or negative X DBL_MAX is returned. RETURN VALUE loggamma(x) ----------------------------------------------------------------------------*/ double loggamma( double X ) { const double EPSMIN = 1e-30; const double EPS = 1e-6; const double DUMVAL = DBL_MAX; const double a0=.9999999758, a1=.4227874605, a2=.4117741955, a3=.0821117404; const double a4=.0721101567, a5=.0044511400, a6=.0051589951, a7=.0016063118; double LOGGAMMA_WERT; double logH, Y; logH = 0.0; Y = X; while ( (fabs(Y-2.0)) >= EPS ) { if ( Y=20.0) { logH = _loggamma( Y ); break; } else if (Y>=3.0) { Y = Y-1.0;logH=logH+log(Y); } else { Y=Y-2.0; logH = logH + log(((((((a7*Y+a6)*Y+a5)*Y+a4)*Y+a3)*Y+a2)*Y+a1)*Y+a0); break; } } LOGGAMMA_WERT = logH; return ( LOGGAMMA_WERT ); } /* loggamma */ spd-1.3.0/edfpack/reference.h0000644000175000017500000004166211635105403012735 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++------------------------------------------------------------------------ NAME reference --- macros for transformations between reference systems PURPOSE Definition of transformation macros and procedures between reference systems. All macros may contain several instructions separated by a semicolon. If necessary, e.g. in an if-statement, they MUST be put into parentheses: if (condition) {ARRAYREF(Off,Ps);} HISTORY 2009-10-02 PB V2.31 extracted from SaxsDefinitions.h V2.30 2010-03-18 PB V2.32 Reference systems and projections (from SaxsOptions.h) 2011-04-07 PB V2.33 CSWAP2, OSWAP2, RASREG added. 2011-05-14 PB V2.34 Axis types (from SaxsOptions.h) 2011-07-24 PB V2.35 Reference system Tangens added (IO_Tangens) DESCRIPTION ----------------------------------------------------------------------------*/ /**************************************************************************** * reference.h ****************************************************************************/ #ifndef _REFERENCE_ # define REFERENCE_VERSION "reference : V2.34 Peter Boesecke 2011-05-14" /* --------------------------------------------------------------------------- General Constants - TRUE 1, - FALSE 0 ---------------------------------------------------------------------------*/ # ifndef FALSE # define FALSE 0 # define TRUE 1 # endif /*--------------------------------------------------------------------------- The following macro calculates the absolute value of the argument Usage: absolut = ABS(-3.2); ---------------------------------------------------------------------------*/ # define ABS( x) ( ( x)> 0 ? ( x) : -( x) ) /*--------------------------------------------------------------------------- The following macros calculate the maximum and minimum of the arguments Usage: minimum = MIN2(-3.2, 5.7); maximum = MAX2( 3.2, 5.9); minimum = MIN3( 2.2, 4.7, 0.3 ); maximum = MAX3( 1.0, 3.0, -3.54 ); minimum = MIN4( 2.2, 4.7, 0.3 , 4.5 ); maximum = MAX4( 1.0, 3.0, -3.54 , 8.9 ); ---------------------------------------------------------------------------*/ #define MAX2( x1, x2) ( ( x1)>( x2) ? ( x1) : ( x2) ) #define MIN2( n1, n2) ( ( n1)<( n2) ? ( n1) : ( n2) ) #define MAX3( y1, y2, y3) ( MAX2( MAX2( ( y1), ( y2) ), ( y3) ) ) #define MIN3( y1, y2, y3) ( MIN2( MIN2( ( y1), ( y2) ), ( y3) ) ) #define MAX4( z1, z2, z3, z4 ) MAX2( MAX2( ( z1), ( z2)), MAX2( ( z3), ( z4)) ) #define MIN4( z1, z2, z3, z4 ) MIN2( MIN2( ( z1), ( z2)), MIN2( ( z3), ( z4)) ) /*--------------------------------------------------------------------------- Conventions ----------- pixel index : Machine dependent numbering of pixels inside an array. The machine dependent numbering starts with INDEXSTART. pixel number : Machine independent numbering of a pixel. The machine indedpendend numbering starts with NUMBERSTART. pixel coordinate : Machine independent coordinate of a pixel array. ARRAYSTART is the pixel coordinate of the center of the pixel with the index INDEXSTART. world coordinate : Machine independent coordinate of a pixel array. The actually used world coordinates are chosen with the reference system. World coordinates are defined as affine transformations of pixel coordinates: world coordinate = (pixel coordinate + OFFSET) * Ps A pixel is covering the interval [pixel number - 0.5 .. pixel number + 0.5]. Binning does not change world coordinates. Coordinate Systems ------------------ The positioning of several pixel arrays to each other is chosen by the reference system. All basic lengths (pixel size, wave length, sample distance etc.) are given in meters. Four different systems are used: ARRAY coordinate = pixel coordinate IMAGE coordinate = array coordinate + offset CENTER coordinate = image coordinate - center REAL coordinate = image coordinate * pixel size NORMAL coordinate = (image coordinate - center) * pixel size TANGENS coordinate = (image coordinate - center) * (pixel size/sample distance) SAXS coordinate = (image coordinate - center) * (pixel size/sample distance) * (WaveLength0/wave length) The principal coordinate system is IMAGE. REFERENCE system : coordinate system that is used for calculations USER system : coordinate system that is used for keyboard I/O by the user. Description of macros --------------------- Only the following macros and constants should be used for transformations between the different coordinate systems. INDEXSTART = lowest pixel index (machine dependent) NUMBERSTART = lowest pixel number (machine independent) ARRAYSTART = pixel coordinate of center of pixel INDEXSTART LOWERBORDER = distance between pixel center and its lower border DAI = ARRAYSTART - INDEXSTART = Difference (ARRAYSTART, INDEXSTART) WaveLength0 = reference wavelength in meters used in SAXS reference system WAVENUMBER Calculates the wavenumber as it is used for reference system coordinates Example Lower left corner has coordinates (0.5,0.5): INDEXSTART 0, ARRAYSTART 1.0, LOWERBORDER (-0.5), DAI 1.0 Lower left corner has coordinates (0.0,0.0): INDEXSTART 0, ARRAYSTART 0.5, LOWERBORDER (-0.5), DAI 0.5 The world coordinates of the array boundaries are: lower boundary = WORLD(INDEXSTART+LOWERBORDER,Off,Ps); upper boundary = WORLD(INDEXSTART+DIM+LOWERBORDER,Off,Ps); The world coordinates of the first and the last column (row) of an array are: lower column = WORLD(INDEXSTART,Off,Ps); upper column = WORLD(INDEXSTART+DIM-1,Off,Ps); ARRAYREF, IMAGEREF, CENTERREF, REALREF, NORMALREF, SAXSREF, WORLD, INDEX The preprocessor macros ARRAYREF, IMAGEREF, CENTERREF, REALREF, NORMALREF, TANGENSREF and SAXSREF calculate offsets and pixel sizes to allow a direct affin transformation between pixel indices and world coordinates. The transformations are done with WORLD and INDEX. The calculated internal offsets (Off) and pixel sizes (Ps) must not be confused with the basic offsets and pixel sizes which are given in pixel coordinates and meters. Usage (transformation of coordinates) : float Off, Ps; float Offset, PSize, Center, SampleDistance, WaveLength; float IIndex; float WArray, WImage, WCenter, WReal, WNormal, WSaxs; {ARRAYREF(Off,Ps);} WArray = WORLD( IIndex, Off, Ps ); IIndex = INDEX( WArray, Off, Ps ); {IMAGEREF(Off,Ps,Offset);} WImage = WORLD( IIndex, Off, Ps ); IIndex = INDEX( WImage, Off, Ps ); {CENTERREF(Off,Ps,Offset,Center);} WCenter = WORLD( IIndex, Off, Ps ); IIndex = INDEX( WCenter, Off, Ps ); {REALREF(Off,Ps,Offset,PSize);} WReal = WORLD( IIndex, Off, Ps ); IIndex = INDEX( WReal, Off, Ps ); {NORMALREF(Off,Ps,Offset,PSize,Center);} WNormal = WORLD( IIndex, Off, Ps ); IIndex = INDEX( WNormal, Off, Ps ); {TANGENSREF(Off,Ps,Offset,PSize,Center,SampleDistance);} WTangens = WORLD( IIndex, Off, Ps ); IIndex = INDEX( WSaxs, Off, Ps ); {SAXSREF(Off,Ps,Offset,PSize,Center,SampleDistance,WaveLength);} WSaxs = WORLD( IIndex, Off, Ps ); IIndex = INDEX( WSaxs, Off, Ps ); A2INDEX, I2INDEX, C2INDEX, R2INDEX, N2INDEX, T2INDEX, S2INDEX, INDEX2A, INDEX2I, INDEX2C, INDEX2R, INDEX2N, INDEX2T, INDEX2S The preprocessor macros A2INDEX, I2INDEX, C2INDEX, R2INDEX, N2INDEX, T2INDEX and S2INDEX transform a world coordinate W directly into a pixel index IIndex. INDEX2A, INDEX2I, INDEX2C, INDEX2R, INDEX2N, INDEX2T and INDEX2S transform a pixel index directly into a world coordinate W. Usage (direct transformation of coordinates) : float Offset, PSize, Center, SampleDistance, WaveLength; float IIndex; float WArray, WImage, WCenter, WReal, WNormal, WSaxs; IIndex = A2INDEX(WArray); IIndex = I2INDEX(WImage,Offset); IIndex = C2INDEX(WCenter,Offset,Center); IIndex = R2INDEX(WReal,Offset,PSize); IIndex = N2INDEX(WNormal,Offset,PSize,Center); IIndex = T2INDEX(WSaxs,Offset,PSize,Center,SampleDistance); IIndex = S2INDEX(WSaxs,Offset,PSize,Center,SampleDistance,WaveLength); WArray = INDEX2A(IIndex); WImage = INDEX2I(IIndex,Offset); WCenter = INDEX2C(IIndex,Offset,Center); WReal = INDEX2R(IIndex,Offset,PSize); WNormal = INDEX2N(IIndex,Offset,PSize,Center); WTangens = INDEX2S(IIndex,Offset,PSize,Center,SampleDistance); WSaxs = INDEX2S(IIndex,Offset,PSize,Center,SampleDistance,WaveLength); REF2USER, USER2REF Transformation between a user system coordinate and a reference system coordinate Usage (transformation between user system and reference system ) : float ROff, RPs, UOff, UPs; float Offset, PSize, Center, SampleDistance, WaveLength; float RW, UW; {IMAGEREF(UOff,UPs,Offset);} {SAXSREF(ROff,RPs,Offset,PSize,Center,SampleDistance,WaveLength);} UW = REF2USER(RW,ROff,RPs,UOff,UPs); RW = USER2REF(UW,ROff,RPs,UOff,UPs); etc. AREBIN Calculation of new offset, bin size, pixel size and center coordinate after a binning by factor Bin Usage (binning) : AREBIN(Offset,BSize,PSize,Center,Bin) I2OFFSET, C2OFFSET, R2OFFSET, N2OFFSET, T2OFFSET, S2OFFSET Calculation of the offset value. The input value must be the coordinate of the lower edge of the region or pixel (Image, Center, Real, Normal and Saxs). An offset cannot be calculated for Array. Usage : Offset = I2OFFSET(WImage); Offset = C2OFFSET(WNormal,Center); Offset = R2OFFSET(WReal,PSize); Offset = N2OFFSET(WNormal,PSize,Center); Offset = T2OFFSET(WSaxs,PSize,Center,SampleDistance); Offset = S2OFFSET(WSaxs,PSize,Center,SampleDistance,WaveLength); R2PSIZE, N2PSIZE, T2PSIZE, S2PSIZE Calculation of the pixel size from a distance in Real coordinates, Normal coordinates and Saxs coordinates. Usage : PSize = R2PSIZE(WRealDistance); PSize = N2PSIZE(WNormalDistance); PSize = T2PSIZE(WSaxsDistance,SampleDistance); PSize = S2PSIZE(WSaxsDistance,SampleDistance,WaveLength); R2CENTER Calculation of center from a Real coordinate Usage : Center = R2CENTER(WReal,PSize) RASREG Calculation of the raster region. RasReg is the outer dimension of a region, i.e. the dimension of a region with binning size 1 and offset 0 that covers the region exactly. Usage : RasReg = RASREG(BSize,Offset,Dim) OSWAP2 Calculation of a new offset value after a swap of a data REGION. The new offset is calculated in such a way that REGIONs are swapped coherently. Usage : Offset' = OSWAP2(RasReg,BSize,Offset,Dim) CSWAP2 Calculation of a new center coordinate after a swap of the data ARRAY. The new center coordinate is calculated in such a way that it points to the same pixel as before the swap. PSize and Dim do not change when the array is swapped, the Offset can be changed. Usage : Center' = CSWAP2(Offset',Center,Offset,Dim) CSWAP Like CSWAP2 but keeping the offset. Usage : Center' = CSWAP(Center,Offset,Dim); N2S Transformation of a Normal coordinate to a Saxs coordinate Usage : WSaxs = N2S(WNormal,SampleDistance,WaveLength); ----------------------------------------------------------------------------*/ /* reference systems */ # define IO_NoRSys 0 # define IO_Array 1 # define IO_Image 2 # define IO_Center 3 # define IO_Region 4 # define IO_Real 5 # define IO_Normal 6 # define IO_Tangens 7 # define IO_Saxs 8 /* projections */ # define IO_NoPro 0 # define IO_ProSaxs 1 # define IO_ProWaxs 2 /* axis types */ # define IO_NoAxisType 0 # define IO_AxisTypeDistance 1 # define IO_AxisTypeAngle 2 # define IO_AxisTypeNumerator 3 /* array specifications */ # define INDEXSTART 0 # define NUMBERSTART 1 // define ARRAYSTART 1.0 +++++++++++++++++++ # define ARRAYSTART 0.5 # define LOWERBORDER (-0.5) // define DAI 1.0 +++++++++++++++++++ # define DAI 0.5 # define WaveLength0 1e-9 # define WAVENUMBER(W) (WaveLength0/(W)) /* transformation of coordinates*/ # define WORLD( I, Off, Ps) (((I)+(Off))*(Ps)) # define INDEX( W, Off, Ps) (((W)/(Ps))-(Off)) # define ARRAYREF(Off,Ps) Off=DAI; Ps=1.0 # define IMAGEREF(Off,Ps,O) Off=(O)+DAI; Ps=1.0 # define CENTERREF(Off,Ps,O,C) Off=(O)-(C)+DAI; Ps=1.0; # define REALREF(Off,Ps,O,P) Off=(O)+DAI; Ps=(P) # define NORMALREF(Off,Ps,O,P,C) Off=(O)-(C)+DAI; Ps=(P); # define TANGENSREF(Off,Ps,O,P,C,S) NORMALREF(Off,Ps,(O),((P)/(S)),(C)) # define SAXSREF(Off,Ps,O,P,C,S,W) NORMALREF(Off,Ps,(O),((P)/(S))*WAVENUMBER(W),(C)) /* direct transformations */ # define A2INDEX(I) ((I)-DAI) # define I2INDEX(I,O) ((I)-(O)-DAI) # define C2INDEX(I,O,C) I2INDEX(I,(O)-(C)) # define R2INDEX(I,O,P) ((((I)/(P))-(O))-DAI) # define N2INDEX(I,O,P,C) R2INDEX((I),(O)-(C),(P)) # define T2INDEX(I,O,P,C,S) N2INDEX((I),(O),((P)/(S)),(C)) # define S2INDEX(I,O,P,C,S,W) N2INDEX((I),(O),((P)/(S))*WAVENUMBER(W),(C)) # define INDEX2A(I) ((I)+DAI) # define INDEX2I(I,O) ((I)+(O)+DAI) # define INDEX2C(I,O,C) INDEX2I(I,(O)-(C)) # define INDEX2R(I,O,P) (((I)+(O)+DAI)*(P)) # define INDEX2N(I,O,P,C) INDEX2R((I),(O)-(C),(P)) # define INDEX2T(I,O,P,C,S) INDEX2N((I),(O),((P)/(S)),(C)) # define INDEX2S(I,O,P,C,S,W) INDEX2N((I),(O),((P)/(S))*WAVENUMBER(W),(C)) /* transformation of coordinates between user system and reference system */ # define REF2USER(RW,ROff,RPs,UOff,UPs) WORLD(INDEX(RW,ROff,RPs),UOff,UPs) # define USER2REF(UW,ROff,RPs,UOff,UPs) WORLD(INDEX(UW,UOff,UPs),ROff,RPs) /* transformation of distances between user system and reference system */ # define DREF2DUSER(DRW,RPs,UPs) ((DRW) * ((UPs)/(RPs))) # define DUSER2DREF(DUW,RPs,UPs) ((DUW) * ((RPs)/(UPs))) /* binning */ # define AREBIN(O,B,P,C,Bin) \ O=( ((ARRAYSTART+LOWERBORDER)*(1.0-MAX2(1,Bin))+(O))/MAX2(1,Bin) ); \ B=( (B)*MAX2(1,Bin) ); P=( (P)*MAX2(1,Bin) ); C=( (C)/MAX2(1,Bin) ) /* calculation of Offset */ # define I2OFFSET(I) ((I) - (ARRAYSTART + LOWERBORDER) ) # define C2OFFSET(I,C) ((I) + (C) - (ARRAYSTART + LOWERBORDER) ) # define R2OFFSET(I,P) ((I)/(P) - (ARRAYSTART + LOWERBORDER) ) # define N2OFFSET(I,P,C) (((I)/(P)) + (C) - (ARRAYSTART + LOWERBORDER) ) # define T2OFFSET(I,P,C,S) \ ( (((I)/(P))*(S)) + (C) - (ARRAYSTART + LOWERBORDER) ) # define S2OFFSET(I,P,C,S,W) \ ( (((I)/(P))*(S)*WAVENUMBER(W)) + (C) - (ARRAYSTART + LOWERBORDER) ) /* calculation of PSize */ # define R2PSIZE(D) (D) # define N2PSIZE(D) R2PSIZE(D) # define T2PSIZE(D,S) ( ((D) * (S)) ) # define S2PSIZE(D,S,W) ( ((D) * (S)) / WAVENUMBER(W) ) # define PSIZE2R(P) (P) # define PSIZE2N(P) PSIZE2R(P) # define PSIZE2T(P,S) ( ((P) / (S)) ) # define PSIZE2S(P,S,W) ( ((P) / (S)) * WAVENUMBER(W) ) /* calculation of Center */ # define R2CENTER(I,P) ((I)/(P)) # define CENTER2R(I,P) ((I)*(P)) /* calculation of the raster region from the full image without offset */ # define RASREG(B,D) ( INDEX2R((INDEXSTART)+(LOWERBORDER)+(D),0,B) ) /* calculation of new offset and center after swapping the data array */ # define OSWAP2(R,B,O,D) ( ( (R) / (B) ) - ( (O) + (D) ) ) # define CSWAP2(OO,C,O,D) ( (OO) + (O) + (D) - (C) ) /* calculation of new center after swapping the data array and keeping offset */ # define CSWAP(C,O,D) ( CSWAP2(O,C,O,D) ) /* direct transformations between reference systems */ # define N2S(I,S,W) (((I)/(S))*WAVENUMBER(W)) # define S2N(I,S,W) (((I)*(S))/WAVENUMBER(W)) /*------------------------------------------------------------------------- Center Value Definitions SETCTRDEF ( Dim ) calculation of a default center point to dimension Dim Usage: Center_1 = SETCTRDEF( Dim[1] ); Center_2 = SETCTRDEF( Dim[2] ); ---------------------------------------------------------------------------*/ //# define SETCTRDEF(D ) ( ( (float) (D ) + DAI ) * 0.5 ) # define SETCTRDEF(D ) ( ( (float) (D ) - 1 ) * 0.5 + ARRAYSTART ) /*-------------------------------------------------------------------------*/ # define _REFERENCE_ #endif /* _REFERENCE_ */ /**************************************************************************** * * ****************************************************************************/ spd-1.3.0/edfpack/r2t.c0000644000175000017500000004502011633462462011502 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define R2T_VERSION "r2t : V1.0 Peter Boesecke 2010-05-25" /*--------------------------------------------------------------------------- NAME r2t - conversion between beam distance/center and sample distance/center SYNOPSIS DESCRIPTION This modul provides routines to translate between saxs parameters and fit2d parameters: pixel size, center (PoNI), sample distance, detector rotation angles pixel size, beam center, beam distance, detector tilt angles The rotations matrices and angles are calculated with the modules rot3d and tilt3d. Both parameter sets have been chosen for different purposes. The saxs rotation angles have been chosen to describe scattering patterns that are obvserved with an arbitrarily rotated flat 2 dimensional ideal detector. The fit2d parameters have been chosen to describe scattering patterns that are observed with a flat 2 dimensional ideal detector that is slightly misoriented with respect to the primary beam. The saxs description assumes that the rotation angles of the detector are exact, e.g. have been calibrated. The scattering pattern in the laboratory space is interpreted according to them. After adding a third tilt angle to the fit2d parameters both descriptions allow to calculate the exact positions of all detector pixels in the laboratory space. The transformations between both parameter sets are bijective for tilts less pi/2. In the fit2d description the beam center diverges to infinity for tilt2=pi/2 (detector plane parallel to 90 deg). Both programs use the same laboratory and detector coordinates: The coordinate system is right-handed with axis 1 horizontal, axis 2 vertical and axis 3 pointing against the primary beam. Rotations and tilts are ccw. The pixel sizes (pix and bpix) are identical. The coordinate system with orientation 1 is defined in the following way: The unit vectors along the three axes are: e1^, e2^, e3^. The detector in rest position (tilts and rotations are 0) is in the plane e1^, e2^. origin (0,0) at lower left corner of the detector axis 1: horizontally to the right axis 2: vertically up axis 3: against primary beam ^ 2 (vertical) | | | | +------> 1 (horizontal) \ \ \ _| 3 (against primary beam) The fit2d tilts calibrate the detector pattern for the rotation angles zero, while the saxs rotation angles orient the detector in space, e.g. with a goniometer. The fit2d description is therefore not very well suited for large tilts, e.g. when the detector is turned pi/2 around the goniometer center, where the primary beam does not intersect with the detector plane. Due to that different parameters have been chosen: -fit2d: The intersection point of the beam with the detector is the beam center. The tilts are done around this point. The tilt correction calculates an image like it would be seen by a detector that is exactly perpendicular to the primary beam. Then, the detector normal at the beam center points to the sample, or more generally spoken, to the goniometer center. It corresponds to the point of normal incidence of the ideal perpendicularly oriented detector. The fit2d parameters are: the intersection point of the primary beam with the detector (here called "beam center"), the distance between the goniometer center and this point (here called "beam distance"), the tilt of the detector plane against the sample ("tilt2") and the azimuthal angle ("tilt1") of the tilt2-axis on the detector plane. Both axes (tilt1 and tilt2) can be determined with image analysis by interpreting the shape of powder rings on the detector. The third angle ("tilt3") that rotates the detector in the laboratory around the primary beam is missing in the fit2d description. It is added here to define bijective transformations between saxs and fit2d parameters. fit2d: bpix, beam center, beam distance, tilt1, tilt2, tilt3 fit2d (rotations around detector axes, origin in detector plane): rotation angle of tilting plane on detector (ccw around axis3): | cos(tilt1) -sin(tilt1) 0.0 | T1(tilt1) = | sin(tilt1) cos(tilt1) 0.0 | | 0.0 0.0 1.0 | inclination detector plane (ccw around axis1' after Tilt1): | 1.0 0.0 0.0 | T2(tilt2) = | 0.0 cos(tilt2) -sin(tilt2) | | 0.0 sin(tilt2) cos(tilt2) | rotation angle of detector (ccw around axis 3): | cos(tilt3) -sin(tilt3) 0.0 | T3(tilt3) = | sin(tilt3) cos(tilt3) 0.0 | | 0.0 0.0 1.0 | principal (output) ranges: tilt1 ] - Pi .. +Pi] tilt2 [ 0 .. +Pi] tilt3 ] - Pi .. +Pi] all tilts: Tilt(tilt1,tilt2,tilt3) = T3(tilt3).T1(tilt1).T2(tilt2).T1(-tilt1) -saxs: The point on the detector plane where the normal intersects the goniometer center (sample) is called point of normal incidence ("PoNI", historically called "center"). The distance between this point and the sample is the "sample distance". The detector rotations are done sequentially in the laboratory space around the goniometer center, first rotation around laboratory axis 1 ("detector rotation 1"), second rotation around laboratory axis 2 ("detector rotation 2") and third rotation around laboratory axis 3 ("detector rotation 3"). saxs: pix, PoNI ("center"), sample distance, rot1, rot2, rot3 saxs (rotations around lab axes, origin in sample (goniometer center)): around lab axis 1: | 1.0 0.0 0.0 | R1(rot1) = | 0.0 cos(rot1) -sin(rot1) | | 0.0 sin(rot1) cos(rot1) | around lab axis 2: | cos(rot2) 0.0 sin(rot2) | R2(rot2) = | 0.0 1.0 0.0 | | -sin(rot2) 0.0 cos(rot2) | around lab axis 3: | cos(rot3) -sin(rot3) 0.0 | R3(rot3) = | sin(rot3) cos(rot3) 0.0 | | 0.0 0.0 1.0 | all rotations: ROT(rot1,rot2,rot3) = R3(rot3).R2(rot2).R1(rot1) r11 = R[0][0] = cos(rot2) cos(rot3) r12 = R[1][0] = sin(rot1) sin(rot2) cos(rot3) - cos(rot1) sin(rot3) r13 = R[2][0] = cos(rot1) sin(rot2) cos(rot3) + sin(rot1) sin(rot3) r21 = R[0][1] = cos(rot2) sin(rot3) r22 = R[1][1] = cos(rot1) cos(rot3) + sin(rot1) sin(rot2) sin(rot3) r23 = R[2][1] = cos(rot1) sin(rot2) sin(rot3) - sin(rot1) cos(rot3) r31 = R[0][2] = -sin(rot2) r32 = R[1][2] = sin(rot1) cos(rot2) r33 = R[2][2] = cos(rot1) cos(rot2) principal (output) ranges: rot1 ] -Pi .. +Pi ] rot2 [ -Pi/2 .. +Pi/2 ] rot3 ] -Pi .. +Pi ] Bcen1[pix1_, cen1_, dis_, R_] := (cen1 pix1 ( R[1][0] R[0][1] - R[0][0] R[1][1]) + dis (-R[2][0] R[1][1] + R[1][0] R[2][1]))/ (pix1 (R[1][0] R[0][1] - R[0][0] R[1][1])) Bcen2[pix2_, cen2_, dis_, R_] := (cen2 pix2 (R[1][0] R[0][1] - R[0][0] R[1][1]) + dis (R[2][0] R[0][1] - R[0][0] R[2][1]))/ (pix2 (R[1][0] R[0][1] - R[0][0] R[1][1])) Bdis[dis_, R_] := dis ((R[2][1] ( R[1][0] R[0][2] - R[0][0] R[1][2]) + R[2][0] (-R[1][1] R[0][2] + R[0][1] R[1][2]))/ (-R[1][0] R[0][1] + R[0][0] R[1][1]) + R[2][2]) Cen1[pix1_, bcen1_, bdis_, R_] := bcen1 + (bdis (R[2][0] R[1][1] - R[1][0] R[2][1]))/ (pix1 (R[2][0] ( R[1][1] R[0][2] - R[0][1] R[1][2]) + R[1][0] (-R[2][1] R[0][2] + R[0][1] R[2][2]) + R[0][0] ( R[2][1] R[1][2] - R[1][1] R[2][2]))) Cen2[pix2_, bcen2_, bdis_, R_] := bcen2 + (bdis (-R[2][0] R[0][1] + R[0][0] R[2][1]))/ (pix2 ( R[2][0] ( R[1][1] R[0][2] - R[0][1] R[1][2]) + R[1][0] (-R[2][1] R[0][2] + R[0][1] R[2][2]) + R[0][0] ( R[2][1] R[1][2] - R[1][1] R[2][2]))) Dis[bdis_, R_] := (bdis (-R[1][0] R[0][1] + R[0][0] R[1][1]))/ (R[2][0] (-R[1][1] R[0][2] + R[0][1] R[1][2]) + R[1][0] ( R[2][1] R[0][2] - R[0][1] R[2][2]) + R[0][0] (-R[2][1] R[1][2] + R[1][1] R[2][2])) Bcen1[pix1_, cen1_, dis_, R_] := (cen1 pix1 ( R12 R21 - R11 R22) + dis (-R13 R22 + R12 R23))/ (pix1 (R12 R21 - R11 R22)) Bcen2[pix2_, cen2_, dis_, R_] := (cen2 pix2 (R12 R21 - R11 R22) + dis (R13 R21 - R11 R23))/ (pix2 (R12 R21 - R11 R22)) Bdis[dis_, R_] := dis ((R23 ( R12 R31 - R11 R32) + R13 (-R22 R31 + R21 R32))/ (-R12 R21 + R11 R22) + R33) Cen1[pix1_, bcen1_, bdis_, R_] := bcen1 + (bdis (R13 R22 - R12 R23))/ (pix1 (R13 ( R22 R31 - R21 R32) + R12 (-R23 R31 + R21 R33) + R11 ( R23 R32 - R22 R33))) Cen2[pix2_, bcen2_, bdis_, R_] := bcen2 + (bdis (-R13 R21 + R11 R23))/ (pix2 (R13 ( R22 R31 - R21 R32) + R12 (-R23 R31 + R21 R33) + R11 ( R23 R32 - R22 R33))) Dis[bdis_, R_] := (bdis (-R12 R21 + R11 R22))/ (R13 (-R22 R31 + R21 R32) + R12 ( R23 R31 - R21 R33) + R11 (-R23 R32 + R22 R33)) History 2010-05-17 Peter Boesecke creation 2010-05-25 V1.0 Peter Boesecke 2011-04-18 V1.0 PB r2t_version() added ---------------------------------------------------------------------------*/ /*************************************************************************** * Include * ***************************************************************************/ # include "r2t.h" /**************************************************************************** * Static Variables and Numbers * ****************************************************************************/ static double r2t_eps=1e-8; /**************************************************************************** * Routines * ****************************************************************************/ /*-------------------------------------------------------------------------- NAME r2t_version --- returns pointer to the version string SYNOPSIS const char *r2t_version ( void ); DESCRPTION Returns pointer to the version string. --------------------------------------------------------------------------*/ const char *r2t_version ( void ) { return ( R2T_VERSION ); } /* r2t_version */ /*+++------------------------------------------------------------------------ NAME r2t_bcen1 --- calculate beam center 1 SYNOPSIS int r2t_bcen1( double *bcen1, double pix1, double cen1, double dis, double R[3][3] ); DESCRIPTION bcen1 = (cen1 pix1 ( R[1][0] R[0][1] - R[0][0] R[1][1]) + dis (-R[2][0] R[1][1] + R[1][0] R[2][1]))/ (pix1 (R[1][0] R[0][1] - R[0][0] R[1][1])) RETURN VALUE status ----------------------------------------------------------------------------*/ int r2t_bcen1( double *bcen1, double pix1, double cen1, double dis, double R[3][3] ) { int status=-1; double denom; if (!R||!bcen1) { fprintf( stderr, "ERROR: r2t_bcen1: NULL pointer\n" ); goto r2t_bcen1_error; } denom = pix1*(R[1][0]*R[0][1] - R[0][0]*R[1][1]); if ( fabs(denom). */ /*+++*********************************************************************** NAME rot3d.h SYNOPSIS #include "rot3d.h" DESCRIPTION Header of the module "rot3d.c" Calculate a 3d rotation matrix for rot1, rot2, rot3 or its inverse. Calculate rot1, rot2 and rot3 from a 3d rotation matrix. ***********************************************************************---*/ #ifndef _rot3d_ # define _rot3d_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include /**************************************************************************** * Enums and Structures * ****************************************************************************/ /**************************************************************************** * Functions * ****************************************************************************/ PUBLIC extern const char *rot3d_version ( void ); PUBLIC extern double rot3d_determinante ( double A[3][3] ); PUBLIC extern int rot3d_angles(double ROT[3], double R[3][3]); PUBLIC extern int rot3d_matrix(double ROT[3], double R[3][3]); PUBLIC extern int rot3d_inverse_matrix(double ROT[3], double R[3][3]); /***************************************************************************/ #endif spd-1.3.0/edfpack/waxs.c0000644000175000017500000014663611635105403011763 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define WAXS_VERSION "waxs : V1.12 Peter Boesecke 2011-07-23" /*+++------------------------------------------------------------------------ NAME waxs --- Transformation between coordinates of rotated detectors SYNOPSIS # include waxs.h HISTORY 2001-04-19 V1.0 Peter Boesecke 2002-05-09 V1.1 PB kdir2sp, waxs_Waxs 2004-07-27 V1.2 PB sp2kdir and kdir2sp renamed to waxs_sp2kdir and waxs_kdir2sp, _fprint_dir renamed to waxs_PrintDir, WaxsDir, waxs_sp2kdir, waxs_kdir2sp, waxs_PrintDir, waxs_s2kdir and waxs_kdir2s defined in waxs.h 2004-12-07 V1.3 PB cylindrical symmetry: SymType, SymRot and InvSymRot added to WaxsParams, new waxs_SymInit, waxs_ssym2kdir, waxs_kdir2ssym waxs_saxs and waxs_waxs call waxs_ssym2kdir and waxs_kdir2ssym if SymType is set. waxs_Init initializes SymType, SymRot and InvSymRot with 0. The symmetry axis is always projected to axis 1. 2004-12-08 V1.4 PB SymType 1 and 2 2004-12-11 V1.5 PB waxs_Uni2Iso, waxs_Iso2Uni -> test status <- 2007-04-19 V1.6 PB -Wall compiler warnings resolved 2009-01-09 V1.7a PB waxs_PrintVector, waxs_kdir2svec, waxs_Saxs2Vector, _svec_set added 2010-03-18 V1.8 PB waxs_Range, waxs_Transform, waxs_not_init added waxs_Range and waxs_Transform arguments changed 2010-05-31 V1.9 PB waxs_kdir2svec: calculation of s corrected 2010-05-31 V1.10 PB no global WaxsParams 2011-06-27 V1.11 PB new waxs_S2S, waxs_get_transform and waxs_Transform updated, waxs_Saxs -> waxs_Waxs2Saxs, waxs_Waxs -> waxs_Saxs2Waxs, all conversion function with input and output params 2011-07-23 V1.12 PB rename functions waxs_Saxs2Saxs -> waxs_S2S, waxs_Waxs2Saxs -> waxs_Sp2S, waxs_Saxs2Waxs -> waxs_S2Sp, waxs_Uni2Iso, waxs_Iso2Uni -> no change DESCRIPTION These routines calculate the projection of the Ewald sphere for a scattering pattern that was taken with an inclined 2d-detector and project it to a plane surface. The radial distance from the center of this surface is the length of the scattering vector s. The azimuthal angle is proportional to the azimuthal angle of the scattered beam. In the following, 3d vectors are followed by '~', the length of a vector is just its name: e.g. kin = ||kin~||. Vectors with unit length are followed by '^', e.g. kin^ = kin~/kin. kin~ : wavevector of incident beam (i) kout~ : wavevector of scattered beam s~ = kout~ - kin~ : scattering vector The scattering is elastic. The wavenumber k of kin~ and kout~ is: (ii) k = 1/wavelength = kin = kout Scattering Geometry and Orientation of Detector The angles rot1, rot2 and rot3 define the orientation of the detector in the lab coordinate system with orientation 1. The unit vectors along the three axes are: e1^, e2^, e3^. The rotations are applied sequentially. The first rotation is around axis 1, the second around axis 2 and the third around axis3. All rotations are counter clockwise. The coordinate system with orientation 1 is defined in the following way: origin (0,0) at lower left corner of the image axis 1: horizontally to the right axis 2: vertically up axis 3: against beam direction ^ 2 (vertical) | | | | +------> 1 (horizontal) \ \ \ _| 3 (against primary beam) ID01: -x <=> axis 1, y <=> axis 2, -z <=> axis 3 ID02: x <=> axis 1, -y <=> axis 3, z <=> axis 2 The primary beam (kin~) is antiparallel to axis3. (iii) kin~ = -kin * e3^ The direction of the scattered beam relative to the coordinate system of the inclined detector image is: The direction of the scattered beam expressed in saxs-coordinates (see *) of the inclined detector is: ( sc_1 ) (iv) sc~ = | sc_2 | ( -k ) Here, sc_1 and sc_2 are saxs-coordinates of the detector image with respect to the point of normal incidence ("center"). k is the wavenumber. The direction kout^ is calculated by (v) kout^ = A * sc^ where A is the rotation matrix that describes the inclination of the detector. With eq. i to eq. v the scattering vector becomes (vi) s~ = k * kout^ + k * e3^ kout^ can also be expressed by the scattering angle 2Theta and the azimuthal angle alpha: ( sin(2Theta)*cos(alpha) ) (vii) kout^ = A * sc^ = | sin(2Theta)*sin(alpha) | ( -cos(2Theta) ) The output image is the projection of s on a plane surface. The coordinates are sp_1 and sp_2: (viii) sp_1 = s * cos(alpha) sp_2 = s * sin(alpha) From eq. viii s and cos(alpha) can be calculated: (ix) s = sqrt(sp_1^2+sp_2^2) cos(alpha) = sp_1/s, sin(alpha) = sp_2/s Eq. vi allows to calculate sin(2Theta) and cos(2Theta) from s and k: (x) s^2 = k^2 * (kout^ + e3^)^2 = k^2 * (1 + 2*kout^*e3^ + 1) = k^2 * 2 * (1 + kout^*e3^) = k^2 * 2 * (1 - cos(2Theta)) = k^2 * 2 * 2*sin(Theta)^2 (xi) 2*sin(Theta)^2 = s^2/(2*k^2) (xii) cos(2Theta) = 1-s^2/(2*k^2) sin(2Theta) = sqrt( 2*s^2/(2*k^2) - (s^2/(2*k^2))^2 ) Eq. ix and xii allow the calculation of 2Theta and alpha from the saxs- coordinates (sp_1, sp_2) of the projection. kout can then be calculated with eq. vii. The saxs-coordinates (sc_1,sc_2) on the inclined detector are given by: ( sin(2Theta)*cos(alpha) ) ( sc^_1 ) (xiii) sc^ = InvA * kout^ = InvA * | sin(2Theta)*sin(alpha) | = | sc^_2 | ( -cos(2Theta) ) ( sc^_3 ) (xiv) ( k * sc^_1/sc^_3 ) ( sc_1 ) sc~ = | k * sc^_2/sc^_3 | = | sc_2 | ( -k ) ( sc_3 ) *) SAXS-Coordinates sc_1 = k * ((x_1+off_1) - cen_1) * (pix_1/dis) sc_2 = k * ((x_2+off_2) - cen_2) * (pix_2/dis) where x_1, x_2 are the pixel coordinates, off_1,off_2, the offsets, cen_1,cen_2 the point of normal incidence ("poni", "center"), pix_1,pix_2, the pixel sizes, dis the distance between the sample and the point of normal incidence and k the wavenumber (1/wavelength). For small scattering angles (sqrt(sc_1^2+sc_2^2) << k) (sc_1,sc_2,-k) approximates the scattering vector. The detector orientation is defined by three sequential ccw-rotations around axis 1 (rot1), axis 2 (rot2) and axis 3 (rot3). rotation around axis 1: | 1.0 0.0 0.0 | ROT_1 = | 0.0 cos(angle) -sin(angle) | | 0.0 sin(angle) cos(angle) | axis 2: | cos(angle) 0.0 sin(angle) | ROT_2 = | 0.0 1.0 0.0 | | -sin(angle) 0.0 cos(angle) | axis 3: | cos(angle) -sin(angle) 0.0 | ROT_3 = | sin(angle) cos(angle) 0.0 | | 0.0 0.0 1.0 | Extension to Cylindrical Symmetry The above described projection can also be interpreted as a transformation of the scattering pattern to the s_1-s_2-plane in reciprocal space. In this interpretation the described pattern is only correct if the sample does not have any preferred orientation, i.e. if the scattering is isotropic, like for a powder. If the sample has cylindrical symmetry around a symmetry axis sym^ some parts of the reciprocal space close to the symmetry axis are not visible by the detector and cannot be projected. If this type of interpretation is chosen, the symmetry type symtype must be given and the symmetry axis must be defined with a rotation matrix SymRot in analogy to the detector rotation: symrot1, symrot2, symrot3. The default is 0 for all rotations. symtype 0 means isotropic sample (default), symtype 1 means cylindrical symmetry around axis sym_1^. The scattering pattern is projected to the ssym_1-ssym_2 plane defined by the symmetry rotation matrix. a) Scattering pattern to projection (saxs->waxs) The scattering vector s~ in lab space is calculated with eq. vi. It is projected to the symmetry axis sym^ using the scalar product: (I) ssym_1 = sym_1^ * s~ where sym_1^ is (1) (II) sym_1^ = SymRot * |0| (0) In this case axis 1 of SymRot is the symmetry axis. The length perpendicular to sym_1^ is calculated from the condition that the length of the projected vector ssym_1 must be s: (III) ssym_2 = +-sqrt(s^2-ssym_1^2) (positive and negative solution) The third component is zero. b) Projection to scattering pattern (waxs->saxs) The backprojection from a projection has to fulfill the following conditions: - the length of the scattering vector s in the projection is constant - the component sp~ of the scattering vector s that is parallel to the axis of cylindrical symmetry sym_1~ symmetry is constant - the k-vector lengths are constant: k1=k0=k (IV) s~ = sp~ + ss~ => s^2 = sp^2 + ss^2 (V) k1~ = k0~ + s~ => k^2 = k^2 + 2*k0~*s~ + s^2 In the system of the symmetry axis sym_1~ sp~ and ss~ can be written as ( ssym_1 ) ( 0 ) (VI) sp~ = | 0 | and ss~ = | ssym_2 | ( 0 ) ( ssym_3 ) ssym_1 = s~*sym_1^ k0~ = InvSymRot * kin~ By substitution of sp~ and ss~ in eq. IV using eq. VI and by removing k^2 from both sides of eq. V and by rearranging both sides of the equations one gets: (IVa) ssym_2^2 + ssym_3^2 = s^2 - sp^2 = B (Va) k0_2*ssym_2 + k0_3*ssym_3 = - (s^2/2 + k0~*sp~) = A A, B and k0~ are known numbers. The equation IVa and Va can be used to calculate ss~ (s_2 and s_3). The solutions for ssym_3 are: A*k0_3 +- k0_2*sqrt( (k0_2^2+k0_3^2)*B-A^2 ) (VII) ssym_3 = ------------------------------------------- k0_2^2+k0_3^2 ssym_2 can be calculated with eq. Va, s_1 is known. Finally, the components of s~ must be expressed in the lab coordinate system: ( ssym_1 ) (VIII) s~ = SymRot * | ssym_2 | ( ssym_3 ) Extension to General Case in 3 Dimensions ... ----------------------------------------------------------------------------*/ /****************************************************************************** * Include Files * ******************************************************************************/ # include "waxs.h" /****************************************************************************** * Private Constants * ******************************************************************************/ # define R_PI 3.1415926535897932384626 // static const double deg2rad = R_PI/180.0; static const double rad2deg = 180.0/R_PI; // static const double pi = R_PI; // static const double halfpi = R_PI*0.5; // static const double twopi = R_PI*2.0; // static const double one = 1.0; static const double eps = 1e-30; /****************************************************************************** * Private Variables * ******************************************************************************/ /****************************************************************************** * Routines * ******************************************************************************/ void _fprint_mat ( FILE * out, double A[3][3] ) { int i,j; for (j=0;j<3;j++) { for (i=0;i<3;i++) { fprintf(out," %15.3f", A[i][j]); } fprintf(out,"\n"); } } // _fprint_mat void _fprint_vec ( FILE * out, double V[3] ) { int i; for (i=0;i<3;i++) fprintf(out," %15g\n", V[i] ); } // _fprint_vec void waxs_PrintDir ( FILE * out, WaxsDir Beam ) { fprintf(out," sinAlpha = %g\n", Beam.sinAlpha ); fprintf(out," cosAlpha = %g (%g deg)\n", Beam.cosAlpha, atan2(Beam.sinAlpha,Beam.cosAlpha)*rad2deg ); fprintf(out," sinTwoTheta = %g\n", Beam.sinTwoTheta ); fprintf(out," cosTwoTheta = %g (%g deg)\n", Beam.cosTwoTheta, atan2(Beam.sinTwoTheta,Beam.cosTwoTheta)*rad2deg ); } // waxs_PrintDir void waxs_PrintParams ( FILE * out, WParams Params ) { WParams *pParams = &Params; if ( !pParams->Init) return; fprintf(out," Init = %d\n", pParams->Init); _fprint_mat ( out, pParams->Rot ); _fprint_mat ( out, pParams->InvRot ); fprintf(out," k = %g\n", pParams->k); fprintf(out," halfdk2 = %g\n", pParams->halfdk2); fprintf(out," SymType = %d\n", pParams->SymType); _fprint_mat ( out, pParams->SymRot ); _fprint_mat ( out, pParams->InvSymRot ); } // waxs_PrintParams void waxs_PrintCoord ( FILE * out, WaxsCoord sp ) { WaxsCoord *pCoord = &sp; fprintf(out," status = %d\n", pCoord->status); fprintf(out," s_1 = %g\n", pCoord->s_1); fprintf(out," s_2 = %g\n", pCoord->s_2); } // waxs_PrintCoord void waxs_PrintVector ( FILE * out, WaxsVector svec ) { WaxsVector *pVector = &svec; fprintf(out," status = %d\n", pVector->status); fprintf(out," s_1 = %g\n", pVector->s_1); fprintf(out," s_2 = %g\n", pVector->s_2); fprintf(out," s_3 = %g\n", pVector->s_3); } // waxs_PrintVector /*+++------------------------------------------------------------------------ NAME rotation_matrix_3 --- calculates the 3-dimensional rotation matrix SYNOPSIS void rotation_matrix_3 ( double Rot[3][3], int axis, double angle ) DESCRIPTION Calculates the 3-dimensional rotation matrix for a ccw rotation of angle degrees around axis (axis = 1 | 2 | 3, double Rot[3][3]). RETURN VALUE none ----------------------------------------------------------------------------*/ void rotation_matrix_3 ( double Rot[3][3], int axis, double angle ) { switch (axis) { case 1: Rot[0][0] = 1.0; Rot[1][0] = 0.0; Rot[2][0] = 0.0; Rot[0][1] = 0.0; Rot[1][1] = cos(angle); Rot[2][1] = -sin(angle); Rot[0][2] = 0.0; Rot[1][2] = sin(angle); Rot[2][2] = cos(angle); break; case 2: Rot[0][0] = cos(angle); Rot[1][0] = 0.0; Rot[2][0] = sin(angle); Rot[0][1] = 0.0; Rot[1][1] = 1.0; Rot[2][1] = 0.0; Rot[0][2] = -sin(angle); Rot[1][2] = 0.0; Rot[2][2] = cos(angle); break; case 3: Rot[0][0] = cos(angle); Rot[1][0] = -sin(angle); Rot[2][0] = 0.0; Rot[0][1] = sin(angle); Rot[1][1] = cos(angle); Rot[2][1] = 0.0; Rot[0][2] = 0.0; Rot[1][2] = 0.0; Rot[2][2] = 1.0; break; default: printf("ERROR in rotation_matrix_3: axis = %d, 1<=axis<=3 required.\n", axis); exit(-1); } return; } // rotation_matrix_3 /*+++------------------------------------------------------------------------ NAME mat_mul_3 --- product of two 3-dimensional matrices SYNOPSIS void mat_mul_3 ( double Out[3][3], double A[3][3], double B[3][3] ) DESCRIPTION Out[3][3] = A[3][3]*B[3][3] RETURN VALUE none ----------------------------------------------------------------------------*/ void mat_mul_3 ( double Out[3][3], double A[3][3], double B[3][3] ) { int i,j,k; for (j=0;j<3;j++) for (k=0;k<3;k++) { Out[j][k] = 0.0; for (i=0;i<3;i++) Out[j][k] += A[i][k] * B[j][i]; } return; } // mat_mul_3 /*+++------------------------------------------------------------------------ NAME vec_mul --- multiplication of a 3x3 matrix with a 3d vector SYNOPSIS void vec_mul ( double VOut[3], double A[3][3], double V[3] ) DESCRIPTION VOut[3] = A[3][3]*V[3] RETURN VALUE none ----------------------------------------------------------------------------*/ void vec_mul ( double VOut[3], double A[3][3], double V[3] ) { int i,j; for (j=0;j<3;j++) { VOut[j] = 0.0; for (i=0;i<3;i++) VOut[j] += A[i][j] * V[i]; } return; } // vec_mul /*+++------------------------------------------------------------------------ NAME scalar_product --- scalar product of two 3-dimensional vectors SYNOPSIS double scalar_product ( double V[3], double W[3] ); DESCRIPTION Calculates the scalar product of V and W RETURN VALUE V[0]*W[0]+V[1]*W[1]+V[2]*W[2] ----------------------------------------------------------------------------*/ double scalar_product ( double V[3], double W[3] ) { double value; int i; value=0.0; for (i=0;i<3;i++) value += V[i] * W[i]; return(value); } // scalar_product /*+++------------------------------------------------------------------------ NAME _beam_set --- set WaxsDir SYNOPSIS WaxsDir _beam_set( WaxsDir *pbeam, int status ) DESCRIPTION Changes error status in WaxsDir to status. Other parameters are not changed. RETURN VALUE WaxsDir *pBeam with error status ----------------------------------------------------------------------------*/ WaxsDir _beam_set( WaxsDir *pbeam, int status ) { pbeam->status = status; return( *pbeam ); } // _beam_set /*+++------------------------------------------------------------------------ NAME _s_set --- set error status in WaxsCoord SYNOPSIS WaxsCoord _s_set( WaxsCoord *ps, int status ) DESCRIPTION Changes error status in WaxsCoord to status. Other parameters are not changed. RETURN VALUE WaxsCoord *ps with error status ----------------------------------------------------------------------------*/ WaxsCoord _s_set( WaxsCoord *ps, int status ) { ps->status = status; return( *ps ); } // _s_set /*+++------------------------------------------------------------------------ NAME _svec_set --- set error status in WaxsVector SYNOPSIS WaxsVector _svec_set( WaxsVector *psvec, int status ) DESCRIPTION Changes error status in WaxsVector to status. Other parameters are not changed. RETURN VALUE WaxsVector *psvec with error status ----------------------------------------------------------------------------*/ WaxsVector _svec_set( WaxsVector *psvec, int status ) { psvec->status = status; return( *psvec ); } // _svec_set /*+++------------------------------------------------------------------------ NAME waxs_sp2kdir --- calculates the angles of kout SYNOPSIS WaxsDir waxs_sp2kdir ( WaxsCoord sp ) DESCRIPTION Calculates the unit vector of the scattered beam in lab coordinates from the saxs-coordinates (sp_1, sp_2) of the Ewald-sphere projection. RETURN VALUE .status==0 : sinTwoTheta, cosTwoTheta, sinAlpha, cosAlpha angles in rad (external angles) .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsDir waxs_sp2kdir ( WParams * pParams, WaxsCoord sp ) { WaxsDir Beam; double s, s2, s2d2k2; double tmp; if (!pParams) return(_beam_set(&Beam,-2)); // pParams initialized if (!pParams->Init) return(_beam_set(&Beam,-1)); s2 = sp.s_1*sp.s_1+sp.s_2*sp.s_2; s = sqrt(s2); s2d2k2 = s2*pParams->halfdk2; Beam.cosTwoTheta = 1.0 - s2d2k2; tmp = 2.0*s2d2k2-s2d2k2*s2d2k2; if (tmp<0.0) { if (tmp>-eps) { tmp=0.0; } else { return(_beam_set(&Beam,-2)); } } Beam.sinTwoTheta = sqrt(tmp); if (s>eps) { Beam.cosAlpha = sp.s_1/s; Beam.sinAlpha = sp.s_2/s; } else { Beam.cosAlpha = 0.0; Beam.sinAlpha = 0.0; } return( _beam_set( &Beam, 0 ) ); } // waxs_sp2kdir /*+++------------------------------------------------------------------------ NAME waxs_s2kdir --- calculates the angles of kout SYNOPSIS WaxsDir waxs_s2kdir ( WaxsCoord s ) DESCRIPTION Calculates the unit vector of the scattered beam in lab coordinates from the saxs-coordinate (s_1, s_2) of the inclined detector image RETURN VALUE .status==0 : sinTwoTheta, cosTwoTheta, sinAlpha, cosAlpha angles in rad (external angles) .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsDir waxs_s2kdir ( WParams * pParams, WaxsCoord s ) { WaxsDir Beam; double veclen; double kvec[3]; double kvecout[3]; if (!pParams) return(_beam_set(&Beam,-2)); // pParams initialized if (!pParams->Init) return( _beam_set( &Beam,-1 ) ); veclen = sqrt(s.s_1*s.s_1+s.s_2*s.s_2+pParams->k*pParams->k); kvec[0] = s.s_1/veclen; kvec[1] = s.s_2/veclen; kvec[2] = -pParams->k/veclen; vec_mul ( kvecout, pParams->Rot, kvec ); Beam.cosTwoTheta = -kvecout[2]; Beam.sinTwoTheta = sqrt(kvecout[0]*kvecout[0]+kvecout[1]*kvecout[1]); if (fabs(Beam.sinTwoTheta)>eps) { Beam.cosAlpha = kvecout[0]/Beam.sinTwoTheta; Beam.sinAlpha = kvecout[1]/Beam.sinTwoTheta; } else { Beam.cosAlpha = 0.0; Beam.sinAlpha = 0.0; } return( _beam_set( &Beam, 0 ) ); } // waxs_s2kdir /*+++------------------------------------------------------------------------ NAME waxs_kdir2sp --- calc's the saxs-coordinates of the Ewald-sphere projection SYNOPSIS WaxsCoord waxs_kdir2sp ( WaxsDir kdir ) DESCRIPTION Calculates the saxs-coordinates (sp_1, sp_2) of the Ewald-sphere projection from the unit vector Beam of the scattered beam in lab coordinates RETURN VALUE .status==0 : sp_1, sp_2 .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_kdir2sp ( WParams * pParams, WaxsDir Beam ) { WaxsCoord sp; double s; if (!pParams) return(_s_set(&sp,-2)); // pParams initialized if (!pParams->Init) return(_s_set(&sp,-1)); s = sqrt(2*(1.0-Beam.cosTwoTheta))*pParams->k; sp.s_1 = s*Beam.cosAlpha; sp.s_2 = s*Beam.sinAlpha; return( _s_set( &sp, 0 ) ); } // waxs_kdir2sp /*+++------------------------------------------------------------------------ NAME waxs_kdir2s --- calculates the saxs-coordinates SYNOPSIS WaxsCoord waxs_kdir2s ( WaxsDir Beam ) DESCRIPTION Calculates the saxs-coordinates (s_1, s_2) from the unit vector Beam of the scattered beam in lab coordinates RETURN VALUE .status==0 : s_1, s_2 .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_kdir2s ( WParams * pParams, WaxsDir Beam ) { WaxsCoord sout; double kvec[3]; double kvecout[3]; if (!pParams) return(_s_set( &sout,-2)); // pParams initialized if (!pParams->Init) return(_s_set( &sout,-1)); kvec[0] = Beam.sinTwoTheta*Beam.cosAlpha; kvec[1] = Beam.sinTwoTheta*Beam.sinAlpha; kvec[2] = -Beam.cosTwoTheta; vec_mul ( kvecout, pParams->InvRot, kvec ); // no solution for positive kvecout[2] if (kvecout[2]>-eps) return(_s_set( &sout,-3)); sout.s_1 = -(kvecout[0]/kvecout[2])*pParams->k; sout.s_2 = -(kvecout[1]/kvecout[2])*pParams->k; return(_s_set( &sout,0)); } // waxs_kdir2s /*+++------------------------------------------------------------------------ NAME waxs_ssym2kdir --- calculates the angles of kout SYNOPSIS WaxsDir waxs_ssym2kdir ( WaxsCoord ssym ) DESCRIPTION Calculates the unit vector of the scattered beam in lab coordinates from the saxs-coordinates (ssym_1, ssym_2) of the cylindrical symmetric Ewald-sphere projection. RETURN VALUE .status==0 : sinTwoTheta, cosTwoTheta, sinAlpha, cosAlpha angles in rad (external angles) .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsDir waxs_ssym2kdir ( WParams * pParams, WaxsCoord ssym ) { WaxsDir Beam; double kin[3], k0[3], s[3], s0[3], kout[3]; double sp2, ss2, s2; double A, B; double k022pk032, arg, tmp; if (!pParams) return(_beam_set(&Beam,-2)); // pParams initialized if (!pParams->Init) return(_beam_set(&Beam,-1)); if ( pParams->SymType == 2 ) { // axis 2 is symmetry axis (rotate -90_deg) tmp = ssym.s_1; ssym.s_1 = ssym.s_2; ssym.s_2 = -tmp; } kin[0] = 0.0; kin[1] = 0.0; kin[2] = -pParams->k; vec_mul ( k0, pParams->InvSymRot, kin ); sp2 = ssym.s_1*ssym.s_1; // s-parallel to sym ss2 = ssym.s_2*ssym.s_2; // s-perpendicular to sym s2 = ss2 + sp2; A = - (s2*0.5+k0[0]*ssym.s_1); B = ss2; k022pk032 = k0[1]*k0[1]+k0[2]*k0[2]; if (fabs(k022pk032) < eps) return( _beam_set( &Beam, -4 ) ); arg = k022pk032*B-A*A; if (arg<0.0) return( _beam_set( &Beam, -5 ) ); arg = sqrt(arg); s0[0] = ssym.s_1; if (ssym.s_2<0) { s0[1] = (A*k0[1] + k0[2]*arg)/k022pk032; s0[2] = (A*k0[2] - k0[1]*arg)/k022pk032; } else { s0[1] = (A*k0[1] - k0[2]*arg)/k022pk032; s0[2] = (A*k0[2] + k0[1]*arg)/k022pk032; } vec_mul ( s, pParams->SymRot, s0 ); // kout^ = (s~ + kin~)/k kout[0] = s[0]/pParams->k; kout[1] = s[1]/pParams->k; kout[2] = s[2]/pParams->k - 1.0; if ( pParams->SymType == 2 ) { // axis 2 is symmetry axis (rotate +90_deg) tmp = kout[0]; kout[0] = -kout[1]; kout[1] = tmp; } Beam.cosTwoTheta = -kout[2]; Beam.sinTwoTheta = sqrt(kout[0]*kout[0]+kout[1]*kout[1]); if (fabs(Beam.sinTwoTheta)>eps) { Beam.cosAlpha = kout[0]/Beam.sinTwoTheta; Beam.sinAlpha = kout[1]/Beam.sinTwoTheta; } else { Beam.cosAlpha = 0.0; Beam.sinAlpha = 0.0; } return( _beam_set( &Beam, 0 ) ); } // waxs_ssym2kdir /*+++------------------------------------------------------------------------ NAME waxs_kdir2ssym --- calc's the saxs-coordinates of the cylindrical projection SYNOPSIS WaxsCoord waxs_kdir2sym ( WaxsDir kdir ) DESCRIPTION Calculates the saxs-coordinates (ssym_1, ssym_2) of the cylindrical Ewald-sphere projection from the unit vector Beam of the scattered beam in lab coordinates RETURN VALUE .status==0 : ssym_1, ssym_2 .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_kdir2ssym ( WParams * pParams, WaxsDir Beam ) { WaxsCoord ssym; double sym[3], e1[3]; double kvec[3]; double svec[3]; double s1, ssym2, tmp; if (!pParams) return(_s_set(&ssym,-2)); // pParams initialized if (!pParams->Init) return(_s_set(&ssym,-1)); // s~ = k * kout^ + k * e3^ kvec[0] = Beam.sinTwoTheta*Beam.cosAlpha; kvec[1] = Beam.sinTwoTheta*Beam.sinAlpha; kvec[2] = -Beam.cosTwoTheta; if ( pParams->SymType == 2 ) { // axis 2 is symmetry axis (rotate -90_deg) tmp = kvec[0]; kvec[0] = kvec[1]; kvec[1] = -tmp; } svec[0] = kvec[0] * pParams->k; svec[1] = kvec[1] * pParams->k; svec[2] = (kvec[2]+1.0) * pParams->k; e1[0]=1.0; e1[1]=0.0; e1[2]=0.0; vec_mul(sym, pParams->SymRot, e1); s1 = scalar_product( svec, sym ); ssym2 = scalar_product( svec, svec ); ssym.s_1 = s1; if (svec[1]*sym[0]-svec[0]*sym[1]>0) ssym.s_2 = sqrt(ssym2-s1*s1); else ssym.s_2 = -sqrt(ssym2-s1*s1); if ( pParams->SymType == 2 ) { // axis 2 is symmetry axis (rotate +90_deg) tmp = ssym.s_1; ssym.s_1 = -ssym.s_2; ssym.s_2 = tmp; } return( _s_set( &ssym, 0 ) ); } // waxs_kdir2ssym /*+++------------------------------------------------------------------------ NAME waxs_kdir2svec --- calc's the s-vector of the scattered beam kdir SYNOPSIS WaxsVector waxs_kdir2svec ( WaxsDir Beam ) DESCRIPTION Calculates the s-vector svec = (svec_1, svec_2, svec_3) from the unit vector Beam of the scattered beam in lab coordinates RETURN VALUE .status==0 : svec_1, svec_2, svec_3 .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsVector waxs_kdir2svec ( WParams * pParams, WaxsDir Beam ) { WaxsVector svec; if (!pParams) return(_svec_set(&svec,-2)); // pParams initialized if (!pParams->Init) return(_svec_set(&svec,-1)); svec.s_1 = pParams->k*Beam.sinTwoTheta*Beam.cosAlpha; svec.s_2 = pParams->k*Beam.sinTwoTheta*Beam.sinAlpha; svec.s_3 = pParams->k*(1.0-Beam.cosTwoTheta); return( _svec_set ( &svec, 0 ) ); } // waxs_kdir2svec /*+++------------------------------------------------------------------------ NAME waxs_SymInit --- Initialisation of parameters for cylindrical symmetry SYNOPSIS int waxs_SymInit ( int symtype, double symrot_1, double symrot_2, double symrot_3 ) DESCRIPTION It initializes the static parameters for cylindrical symmetry. Must be called after waxs_Init ARGUMENTS k : wavenumber symrot_1 : ccw rotation around axis 1 symrot_2 : ccw rotation around axis 2 symrot_3 : ccw rotation around axis 3 RETURN VALUE returns 0 if OK ----------------------------------------------------------------------------*/ int waxs_SymInit ( WParams * pParams, int symtype, double symrot_1, double symrot_2, double symrot_3 ) { double Rot_1[3][3], Rot_2[3][3], Rot_3[3][3]; double tmp[3][3]; if (!pParams) return(-2); // pParams initialized if (!pParams->Init) return( -1 ); // symmetry type pParams->SymType = symtype; // symmetry rotation matrix if (symtype != 2) { rotation_matrix_3 ( Rot_1, 1, symrot_1 ); rotation_matrix_3 ( Rot_2, 2, symrot_2 ); } else { rotation_matrix_3 ( Rot_1, 1, symrot_2 ); rotation_matrix_3 ( Rot_2, 2, -symrot_1 ); } rotation_matrix_3 ( Rot_3, 3, symrot_3 ); mat_mul_3 ( tmp, Rot_2, Rot_1 ); mat_mul_3 ( pParams->SymRot, Rot_3, tmp ); // inverse symmetry rotation matrix if (symtype != 2) { rotation_matrix_3 ( Rot_1, 1, -symrot_1 ); rotation_matrix_3 ( Rot_2, 2, -symrot_2 ); } else { rotation_matrix_3 ( Rot_1, 1, -symrot_2 ); rotation_matrix_3 ( Rot_2, 2, symrot_1 ); } rotation_matrix_3 ( Rot_3, 3, -symrot_3 ); mat_mul_3 ( tmp, Rot_2, Rot_3 ); mat_mul_3 ( pParams->InvSymRot, Rot_1, tmp ); return( 0 ); } // waxs_SymInit /*+++------------------------------------------------------------------------ NAME waxs_Init --- Initialisation of parameters SYNOPSIS int waxs_Init ( double k, double rot_1, double rot_2, double rot_3 ) DESCRIPTION It initializes all static parameters. ARGUMENTS k : wavenumber rot_1 : ccw rotation around axis 1 rot_2 : ccw rotation around axis 2 rot_3 : ccw rotation around axis 3 RETURN VALUE returns 0 if OK ----------------------------------------------------------------------------*/ int waxs_Init ( WParams * pParams, double k, double rot_1, double rot_2, double rot_3 ) { double Rot_1[3][3], Rot_2[3][3], Rot_3[3][3]; double tmp[3][3]; if (!pParams) return(-2); pParams->Init = 0; // rotation matrix rotation_matrix_3 ( Rot_1, 1, rot_1 ); rotation_matrix_3 ( Rot_2, 2, rot_2 ); rotation_matrix_3 ( Rot_3, 3, rot_3 ); mat_mul_3 ( tmp, Rot_2, Rot_1 ); mat_mul_3 ( pParams->Rot, Rot_3, tmp ); // inverse rotation matrix rotation_matrix_3 ( Rot_1, 1, -rot_1 ); rotation_matrix_3 ( Rot_2, 2, -rot_2 ); rotation_matrix_3 ( Rot_3, 3, -rot_3 ); mat_mul_3 ( tmp, Rot_2, Rot_3 ); mat_mul_3 ( pParams->InvRot, Rot_1, tmp ); // wavevector k pParams->k = k; pParams->halfdk2 = 0.5/(k*k); // symmetry type default // isotropic scattering pParams->SymType = 0; // symmetry rotation matrix default (no rotation) rotation_matrix_3 ( pParams->SymRot, 1, 0.0 ); rotation_matrix_3 ( pParams->InvSymRot, 1, 0.0 ); pParams->Init = 1; return( 0 ); } // waxs_Init /*+++------------------------------------------------------------------------ NAME waxs_not_init --- check initialization SYNOPSIS int waxs_not_init ( void ); DESCRIPTION Checks whether the parameters have been initialized. ARGUMENTS void RETURN VALUE returns 0 if initialized, otherwise 1 ----------------------------------------------------------------------------*/ int waxs_not_init ( WParams *pParams ) { if (!pParams) return(0); else return( pParams->Init?0:1 ); } // waxs_not_init /*+++------------------------------------------------------------------------ NAME waxs_get_transform --- return transformation mode SYNOPSIS int waxs_get_transform( int proin, int proout ); DESCRIPTION Determines the transformation mode from the input and output projection types ARGUMENTS input projection type proin (IO_ProSaxs, IO_ProWaxs) output projection type proout (IO_ProSaxs, IO_ProWaxs) RETURN VALUE -1: inverse transformation (WAXS->SAXS_pParams) 0: no transformation 1: normal transformation (SAXS_pParams->WAXS) 2: transformation between different rotations (SAXS_pParams->SAXS_pParamsOut) ----------------------------------------------------------------------------*/ int waxs_get_transform( int proin, int proout ) { int transform=0; if ( proin!=proout ) { /* There can be more projections defined as saxs and waxs */ if ((proin==IO_ProSaxs)&&(proout==IO_ProWaxs)) transform=1; // normal transformation else if ((proin==IO_ProWaxs)&&(proout==IO_ProSaxs)) transform=-1; // inverse transformation } else { if ((proin==IO_ProSaxs)&&(proout==IO_ProSaxs)) transform=2; // different rotations } return( transform ); } // waxs_to_transform() /*+++------------------------------------------------------------------------ NAME waxs_Sp2S --- calculation of saxs coordinate from s-projection SYNOPSIS WaxsCoord waxs_Sp2S ( WParams * pParamsIn, WParams * pParamsOut, WaxsCoord sp ); DESCRIPTION Calculates the saxs-coordinate s of the inclined detector image from the saxs-coordinate sp of the Ewald sphere-projection. The parameter SymType is used. ARGUMENT WParams * pParams : parameters of input image (Ewald sphere projection) WParams * pParamsOut : parameters of output image (if NULL, uses pParams) WaxsCoord sp : saxs-coordinate of the Ewald sphere projection RETURN VALUE WaxsCoord s : saxs-coordinate of the inclined detector image s.status==0 in case of success .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_Sp2S ( WParams * pParams, WParams * pParamsOut, WaxsCoord sp ) { WaxsDir kdir; WaxsCoord sout; if (!pParams) return(_s_set( &sout,-2)); // pParams initialized if (!pParams->Init) return(_s_set( &sout,-1)); if (!pParamsOut) pParamsOut = pParams; // pParamsOut initialized if (!pParamsOut->Init) return(_s_set( &sout,-1)); if (pParams->SymType) kdir = waxs_ssym2kdir ( pParams, sp ); else kdir = waxs_sp2kdir ( pParams, sp ); if (kdir.status) return( _s_set( &sout,kdir.status*10-2) ); sout = waxs_kdir2s ( pParamsOut, kdir ); if (sout.status) return( _s_set( &sout,sout.status*10-2) ); return( _s_set( &sout, 0 ) ); } // waxs_Sp2S /*+++------------------------------------------------------------------------ NAME waxs_S2Sp --- calculation of s-projection from saxs coordinate s SYNOPSIS WaxsCoord waxs_S2Sp ( WParams * pParams, WParams * pParamsOut, WaxsCoord s ); DESCRIPTION Calculates the saxs-coordinate sp of the Ewald sphere-projection from the saxs-coordinate s of the inclined detector image. The parameter SymType is used. ARGUMENT WParams * pParams : parameters of the input coordinate (inclined detector) WParams * pParamsOut : parameters of the output coordinate (Ewald sphere projection) (if NULL, pParams is used) WaxsCoord s : saxs-coordinate s of the inclined detector image RETURN VALUE WaxsCoord sp : saxs-coordinate sp of the Ewald sphere-projection s.status==0 in case of success .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_S2Sp ( WParams * pParams, WParams * pParamsOut, WaxsCoord s ) { WaxsDir kdir; WaxsCoord spout; if (!pParams) return(_s_set( &spout,-2)); // pParams initialized if (!pParams->Init) return(_s_set( &spout,-1)); if (!pParamsOut) pParamsOut = pParams; // pParamsOut initialized if (!pParamsOut->Init) return(_s_set( &spout,-1)); kdir = waxs_s2kdir ( pParams, s ); if (kdir.status) return( _s_set( &spout,kdir.status*10-2) ); if (pParams->SymType) spout = waxs_kdir2ssym ( pParamsOut, kdir ); else spout = waxs_kdir2sp ( pParamsOut, kdir ); if (spout.status) return( _s_set( &spout,spout.status*10-2) ); return( _s_set( &spout, 0 ) ); } // waxs_S2Sp /*+++------------------------------------------------------------------------ NAME waxs_S2S --- saxs coordinate transformation between rotated detectors SYNOPSIS WaxsCoord waxs_S2S ( WParams * pParams, WParams * pParamsOut, WaxsCoord s ) DESCRIPTION Returns the saxs-coordinate of an inclined detector (*pParamsOut) which is calculated from the saxs-coordinate s of another inclined detector (pParams). The parameter SymType has no effect and is not used. If one of pParams or pParamsOut is NULL, the parameters for an unrotated detector are used. At least one parameter set needs to be initialized. ARGUMENTS WParams * pParams : Waxs Parameters of the input coordinate (inclined detector) if NULL: calculate for perpendicular detector WParams * pParamsOut : Waxs Parameters of the output coordinate (inclined detector) if NULL: calculate for perpendicular detector WaxsCoord s : saxs-coordinate corresponding to *pParams RETURN VALUE WaxsCoord s : saxs-coordinate corresponding to *pParamsOut s.status==0 in case of success .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_S2S ( WParams * pParams, WParams * pParamsOut, WaxsCoord s ) { WaxsDir kdir; WaxsCoord sout; WParams DefaultParams; // only 1 parameter set can be NULL if ((!pParams)&&(!pParamsOut)) return(_s_set( &sout,-2)); // pParams initialized if (!pParams) { if (!pParamsOut) return(_s_set( &sout,-2)); if (!pParamsOut->Init) return(_s_set( &sout,-1)); pParams = &DefaultParams; if ( waxs_Init ( pParams, pParamsOut->k, 0.0, 0.0, 0.0 ) ) return(_s_set( &sout,-2)); } if (!pParams->Init) return(_s_set( &sout,-1)); // pParamsOut initialized if (!pParamsOut) { pParamsOut = &DefaultParams; if ( waxs_Init ( pParamsOut, pParams->k, 0.0, 0.0, 0.0 ) ) return(_s_set( &sout,-2)); } if (!pParamsOut->Init) return(_s_set( &sout,-1)); kdir = waxs_s2kdir ( pParams, s ); if (kdir.status) return( _s_set( &sout,kdir.status*10-2) ); sout = waxs_kdir2s ( pParamsOut, kdir ); if (sout.status) return( _s_set( &sout,sout.status*10-2) ); return( _s_set( &sout, 0 ) ); } // waxs_S2S /*+++------------------------------------------------------------------------ NAME waxs_Saxs2Vector --- calculation of s-projection from saxs coordinate s SYNOPSIS WaxsVector waxs_Saxs2Vector ( WaxsCoord s ) DESCRIPTION Calculates the s-vector svec from the saxs-coordinate s of the inclined detector image. ARGUMENT WaxsCoord s : saxs-coordinate s of the inclined detector image RETURN VALUE .status==0 : svec_1, svec_2, svec_3 .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsVector waxs_Saxs2Vector ( WParams * pParams, WaxsCoord s ) { WaxsDir kdir; WaxsVector svec; if (!pParams) return( _svec_set ( &svec, -2 ) ); // pParams initialized if (!pParams->Init) return(_svec_set( &svec,-1)); kdir = waxs_s2kdir ( pParams, s ); if (kdir.status) return( _svec_set( &svec,kdir.status*10-2) ); svec = waxs_kdir2svec ( pParams, kdir ); if (svec.status) return( _svec_set( &svec,svec.status*10-2) ); return( _svec_set ( &svec, 0 ) ); } // waxs_Saxs2Vector /*+++------------------------------------------------------------------------ NAME waxs_Uni2Iso --- uniaxial WAXS projection to isotropic WAXS projection SYNOPSIS WaxsCoord waxs_Uni2Iso ( WParams * pParams, WParams * pParamsOut, WaxsCoord ssym ); DESCRIPTION Calculates the saxs-coordinate sp of an isotropic WAXS projection from the saxs-coordinate ssym of an uniaxial symmetric WAXS projection. ARGUMENT WParams * pParams : parameters of the uniaxial symmetric Ewald sphere projection WParams * pParamsOut : parameters of the isotropic Ewald sphere projection (if NULL, uses pParams) WaxsCoord ssym : saxs-coordinate of the uniaxial symmetric Ewald sphere projection RETURN VALUE WaxsCoord sp : saxs-coordinate of the isotropic Ewald sphere projection s.status==0 in case of success .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_Uni2Iso ( WParams * pParams, WParams * pParamsOut, WaxsCoord ssym ) { WaxsDir kdir; WaxsCoord spout; if (!pParams) return(_s_set( &spout,-1)); // pParams initialized if (!pParams->Init) return(_s_set( &spout,-1)); if (!pParamsOut) pParamsOut = pParams; // pParams initialized if (!pParamsOut->Init) return(_s_set( &spout,-1)); if (pParams->SymType) { kdir = waxs_ssym2kdir ( pParams, ssym ); if (kdir.status) return( _s_set( &spout,kdir.status*10-2) ); spout = waxs_kdir2sp ( pParamsOut, kdir ); if (spout.status) return( _s_set( &spout,spout.status*10-2) ); } else spout = ssym; return( _s_set( &spout, 0 ) ); } // waxs_Uni2Iso /*+++------------------------------------------------------------------------ NAME waxs_Iso2Uni --- isotropic WAXS projection to uniaxial WAXS projection SYNOPSIS WaxsCoord waxs_Iso2Uni ( WParams * pParams, WParams * pParamsOut, WaxsCoord sp ); DESCRIPTION Calculates the saxs-coordinate ssym of an uniaxial symmetric WAXS projection from the saxs-coordinate sp of an isotropic WAXS projection. ARGUMENT WParams * pParams : parameters of the isotropic Ewald sphere projection WParams * pParamsOut : parameters of the uniaxial symmetric Ewald sphere projection (if NULL, uses pParams) WaxsCoord sp : saxs-coordinate of the isotropic Ewald sphere projection RETURN VALUE WaxsCoord ssym : saxs-coordinate of the uniaxial symmetric Ewald sphere projection s.status==0 in case of success .status<0 : error .status<-1 : no solution ----------------------------------------------------------------------------*/ WaxsCoord waxs_Iso2Uni ( WParams * pParams, WParams * pParamsOut, WaxsCoord sp ) { WaxsDir kdir; WaxsCoord ssymout; if (!pParams) return(_s_set( &ssymout,-2)); // pParams initialized if (!pParams->Init) return(_s_set( &ssymout,-1)); if (!pParamsOut) pParamsOut = pParams; // pParamsOut initialized if (!pParamsOut->Init) return(_s_set( &ssymout,-1)); if (pParams->SymType) { kdir = waxs_sp2kdir ( pParams, sp ); if (kdir.status) return( _s_set( &ssymout,kdir.status*10-2) ); ssymout = waxs_kdir2ssym ( pParams, kdir ); if (ssymout.status) return( _s_set( &ssymout,ssymout.status*10-2) ); } else ssymout = sp; return( _s_set( &ssymout, 0 ) ); } // waxs_Iso2Uni /*--------------------------------------------------------------------------- NAME waxs_Transform --- return transformed coordinate SYNOPSIS WaxsCoord waxs_Transform( WParams * pParams, WParams *pParamsOut, int transform, WaxsCoord W) DESCRIPTION The routine calculates the transformed coordinate of W. If transform is 0 the coordinate W is returned, if transform is -1 the Waxs coordinate of W is returned, if transform is 1 the SAXS coordinate of W is returned If transform is 2 the Saxs coordinate W for a perpendicular detector is returned, The arguent transform can be multiplied by -1 to invert the calculation. ARGUMENTS WParams * pParams : Waxs Parameters of the input coordinate WParams * pParamsOut : Waxs Parameters of the output coordinate, WaxsCoord s : saxs-coordinate of the inclined input detector (*pParams) RETURN VALUE transformed coordinate ---------------------------------------------------------------------------*/ WaxsCoord waxs_Transform( WParams *pParams, WParams * pParamsOut, int transform, WaxsCoord W) { WaxsCoord WT; if (transform) { switch (transform) { case -1: WT = waxs_S2Sp ( pParams, pParamsOut, W ); // inverse break; case 1: WT = waxs_Sp2S ( pParams, pParamsOut, W ); // direct break; case -2: WT = waxs_S2S ( pParams, pParamsOut, W ); break; case 2: WT = waxs_S2S ( pParams, pParamsOut, W ); break; default: W.status=1; WT = W; // error } } else { W.status=0; WT = W; } // no projection transformation return(WT); } // waxs_Transform /*--------------------------------------------------------------------------- NAME waxs_Range --- calculates waxs range from saxs image parameters SYNOPSIS int waxs_Range( WParams * pParams, WParams * pParamsOut, int proin, int proout, long dim_1, long dim_2, float off_1, float pix_1, float cen_1, float off_2, float pix_2, float cen_2, float dis, float wvl, WaxsCoord *Wmin, WaxsCoord *Wmax, int * pstatus); DESCRIPTION off_1 to wvl are the parameters of the untransformed image (projection type Saxs). The range in saxs coordinates of the transformed image (projection type Waxs) are calculated and returned in Wmin and Wmax. Because the output area is not necessarily rectangular, parts of the output can be outside the range described by Wmin and Wmax. RETURN VALUE (returns value determined with waxs_get_transform) -1: inverse transformation (WAXS->SAXS_pParams) 0: no transformation 1: normal transformation (SAXS_pParams->WAXS) 2: transformation between different rotations (SAXS_pParams->SAXS_pParamsOut) status returned in *pstatus : 0: success, otherwise failed ---------------------------------------------------------------------------*/ int waxs_Range( WParams * pParams, WParams * pParamsOut, int proin, int proout, long dim_1, long dim_2, float off_1, float pix_1, float cen_1, float off_2, float pix_2, float cen_2, float dis, float wvl, WaxsCoord *Wmin, WaxsCoord *Wmax, int * pstatus) { const float eps=1e-32; WaxsCoord W, WOut; float s_11, s_12, s_21, s_22, smin_1, smax_1, smin_2, smax_2; int transform; if (!pParams) return(-2); *pstatus = -1; transform = waxs_get_transform(proin,proout); if (fabs(pix_1)<=eps) goto waxs_Range_error; if (fabs(pix_2)<=eps) goto waxs_Range_error; if (fabs(wvl)<=eps) goto waxs_Range_error; if (fabs(dis)<=eps) goto waxs_Range_error; /* WSaxs = INDEX2S(IIndex,Offset,Psize,Center,SampleDistance,WaveLength); */ s_11 = INDEX2S(INDEXSTART+LOWERBORDER,off_1,pix_1,cen_1,dis,wvl); s_12 = INDEX2S(INDEXSTART+LOWERBORDER+dim_1,off_1,pix_1,cen_1,dis,wvl); s_21 = INDEX2S(INDEXSTART+LOWERBORDER,off_2,pix_2,cen_2,dis,wvl); s_22 = INDEX2S(INDEXSTART+LOWERBORDER+dim_2,off_2,pix_2,cen_2,dis,wvl); W.s_1 = s_11; W.s_2 = s_21; WOut = waxs_Transform(pParams, pParamsOut, -transform, W); if (WOut.status) goto waxs_Range_error; smin_1 = WOut.s_1; smax_1 = WOut.s_1; smin_2 = WOut.s_2; smax_2 = WOut.s_2; W.s_1 = s_12; W.s_2 = s_21; WOut = waxs_Transform(pParams, pParamsOut, -transform, W); if (WOut.status) goto waxs_Range_error; smin_1 = MIN2(smin_1,WOut.s_1); smax_1 = MAX2(smax_1,WOut.s_1); smin_2 = MIN2(smin_2,WOut.s_2); smax_2 = MAX2(smax_2,WOut.s_2); W.s_1 = s_12; W.s_2 = s_22; WOut = waxs_Transform(pParams, pParamsOut, -transform, W); if (WOut.status) goto waxs_Range_error; smin_1 = MIN2(smin_1,WOut.s_1); smax_1 = MAX2(smax_1,WOut.s_1); smin_2 = MIN2(smin_2,WOut.s_2); smax_2 = MAX2(smax_2,WOut.s_2); W.s_1 = s_11; W.s_2 = s_22; WOut = waxs_Transform(pParams, pParamsOut, -transform, W); if (WOut.status) goto waxs_Range_error; smin_1 = MIN2(smin_1,WOut.s_1); smax_1 = MAX2(smax_1,WOut.s_1); smin_2 = MIN2(smin_2,WOut.s_2); smax_2 = MAX2(smax_2,WOut.s_2); /* backward or forward projection */ if (transform==1) { // direct transformation SAXS->WAXS /* In case that the input image coordinates are transformed from Saxs to Waxs (Inverse is FALSE) it must be checked whether the original pattern contains the backscattering vector (180 degree scattering) This is the case if the origin (0,0) cannot be projected on the detector plane (transform(transform, FALSE, W) fails) and if the the origin (0,0) lies inside the found edges (smin and smax). In this case the modulus of the maximum scattering vector is (2*WAVENUMBER(WaveLength). */ W.s_1 = 0.0; W.s_2 = 0.0; WOut = waxs_Transform(pParams, pParamsOut, transform, W); if (WOut.status) { /* backward projection */ if ( (smin_1*smax_1<0)&&(smin_2*smax_2<0) ) { smax_1 = 2.0*WAVENUMBER(wvl); smin_1 = -smax_1; smax_2 = 2.0*WAVENUMBER(wvl); smin_2 = -smax_2; } } } Wmin->s_1 = smin_1; Wmin->s_2 = smin_2; Wmax->s_1 = smax_1; Wmax->s_2 = smax_2; *pstatus = 0; return( transform ); waxs_Range_error: return( transform ); } // waxs_Range spd-1.3.0/edfpack/readascii.h0000644000175000017500000001037211633462461012725 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME readascii.h SYNOPSIS #include "readascii.h" DESCRIPTION Header of the module "readascii.c" PURPOSE Conversion of ascii tables to float See PUBLIC functions for detail. AUTHOR 2007 Peter Boesecke (PB) HISTORY 2007-09-07 V1.0 PB ***************************************************************************/ #ifndef _READASCII_ # define _READASCII_ /*************************************************************************** * General Definitions * ***************************************************************************/ # ifndef PRIVATE # define PRIVATE static # define PUBLIC # endif /*************************************************************************** * Include Files * ***************************************************************************/ # include # include # include # include # include # include # include # include # include # include # include "edfio.h" # include "numio.h" # include "filename.h" /*************************************************************************** * Structure Definitions * ***************************************************************************/ PUBLIC typedef struct RA_Descriptions { char * Key; // pointer to the key string struct RA_Descriptions *Previous,*Next; // the previous and next elements FILE * in; int verbose; char * filename; long bskp; long lskp; long cskp; long skipcol; long skiprow; long dim1; long dim2; long cnt; long ori; float dummy; char * delimiterset; char * commentset; float *buffer; // pointer to allocated buffer size_t bufsiz; // size of allocated buffer } RADescr; /*************************************************************************** * PUBLIC Functions * ***************************************************************************/ PUBLIC RADescr *RA_openfile(const char *filename, int verbose, int *pstatus); PUBLIC long RA_readfile( RADescr * descr, float ** pdata, int * pstatus ); PUBLIC void RA_closefile( RADescr * descr, int * pstatus ); PUBLIC int RA_setbskp( RADescr * descr, long bskp ); PUBLIC int RA_setlskp( RADescr * descr, long lskp ); PUBLIC int RA_setcskp( RADescr * descr, long cskp ); PUBLIC int RA_setskipcol( RADescr * descr, long skipcol ); PUBLIC int RA_setskiprow( RADescr * descr, long skiprow ); PUBLIC int RA_setdim1( RADescr * descr, long dim1 ); PUBLIC int RA_setdim2( RADescr * descr, long dim2 ); PUBLIC int RA_setori( RADescr * descr, long ori ); PUBLIC int RA_setdummy( RADescr * descr, float dummy ); PUBLIC int RA_setdelimiterset( RADescr * descr, const char *delimiterset ); PUBLIC int RA_setcommentset( RADescr * descr, const char *commentset ); PUBLIC const char * RA_version ( void ); # endif /************************************************************************---*/ spd-1.3.0/edfpack/gauss.c0000644000175000017500000001210711633462462012115 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define GAUSS_VERSION "gauss : V1.2 Peter Boesecke 2007-04-23" /*+++------------------------------------------------------------------------ NAME gauss --- routines for gaussian distributions SYNOPSIS # include gauss.h HISTORY 2000-11-17 V1.0 Peter Boesecke creation 2007-02-21 V1.1 PB SaxsDefinition.h is not needed any more 2007-03-23 V1.2 PB GaussInit() -> GaussInit( void ) ----------------------------------------------------------------------------*/ # define GAUSS_LEN 201 /* number of interpolation points */ # define GAUSS_RANGE 8 /* range of LUT in multiples of sigma */ # include "gauss.h" static int GaussDebugMode = 0; static double GaussLut_X[GAUSS_LEN]; static double GaussLut_Y[GAUSS_LEN]; static int GaussLutInit = 0; static double GaussS2Pi = 2.506628274631; // sqrt(2.0*SAXS_PI); void GaussDebug( int mode ) { GaussDebugMode = mode; } double GaussPhi( double X ) { return( exp ( - X*X*0.5 ) ); } /* GausPhi */ /* initializes GaussLut with the integrated values Y of a Gaussian GaussPhi( X ) = exp(-Y^2/2), Y = Integral(0,X,GaussPhi(X) */ void GaussInit( void ) { const int N = GAUSS_LEN-1; int i; double X1, X2; double Y1, Y2; double range = GAUSS_RANGE; double step; double value; step = range/N; X2 = 0.0; Y2 = GaussPhi( X2 ); value = 0.0; GaussLut_X[0] = X2; GaussLut_Y[0] = value; for (i=1;i<=N;i++) { X1 = X2; Y1 = Y2; X2 = X2 + step; Y2 = GaussPhi( X2 ); value += (Y1+Y2)*0.5*step; GaussLut_X[i] = X2; GaussLut_Y[i] = value; } GaussLutInit = 1; } /* GaussInit */ void GaussPrintLut( FILE * out, double X[], double Y[] ) { const int N=GAUSS_LEN-1; int i; fprintf( out, "\n%s\n\n", GAUSS_VERSION ); for (i=0;i<=N;i++) { fprintf(out,"X[%u] = %10.5g, Y[%u] = %10.5g\n", i, GaussLut_X[i],i,GaussLut_Y[i]); } } /* GaussPrintLut */ /* returns the interpolated values of the LUT Xn = XX[n]; Yn = YY[n]; Monoton increasing values are required: X1 Y1 Y = Y0 Xn <= X < Xn+1 -> Y = Yn + (Yn+1-Yn)/(Xn+1-Xn) * (X-Xn) XN <= X -> Y = YN */ double Ipol_LUT2( double XX[], double YY[], double X ) { double Y; int i, N = GAUSS_LEN-1; if ( X < XX[0] ) Y = YY[0]; else if ( XX[N] <= X ) Y = YY[N]; else { for (i=1; i<=N; i++) { if (X < XX[i]) break; } Y = YY[i-1] + (YY[i]-YY[i-1])/(XX[i]-XX[i-1]) * (X-XX[i-1]); } return( Y ); } /* Ipol_LUT2 */ /* Gauss(x) = 1.0/(sqrt(2*pi)*sigma) * exp(- x^2/(2*sigma^2) */ double Gauss( double x, double sigma ) { return( (GaussS2Pi/sigma) * GaussPhi( x/sigma ) ); } /* Gauss */ /* IntGauss(x,sigma)=1.0/(sqrt(2*pi)*sigma)*Integral(-Inf,x,Gauss(x,sigma)) */ double IntGauss ( double x, double sigma ) { double value; if (!GaussLutInit) { GaussInit(); if (GaussDebugMode) GaussPrintLut( stdout , GaussLut_X , GaussLut_Y ); } if (x<0) value = 0.5-(Ipol_LUT2(GaussLut_X, GaussLut_Y, -x/sigma))/GaussS2Pi; else value = 0.5+(Ipol_LUT2(GaussLut_X, GaussLut_Y, x/sigma))/GaussS2Pi; return( value ); } /* IntGauss */ /* InvIntGauss(y,sigma) = Inverted IntGauss */ double InvIntGauss ( double y, double sigma ) { double value; if (!GaussLutInit) { GaussInit(); if (GaussDebugMode) GaussPrintLut( stdout , GaussLut_X , GaussLut_Y ); } if (y<0.5) value=(-Ipol_LUT2(GaussLut_Y,GaussLut_X,(0.5-y)*GaussS2Pi))*sigma; else value=(Ipol_LUT2(GaussLut_Y,GaussLut_X,(y-0.5)*GaussS2Pi))*sigma; return( value ); } /* InvIntGauss */ /* set random number seed */ void GaussNoiseSeed( unsigned int seed ) { srand( seed ); } /* GaussNoiseSeed */ /* create gaussian distributed noise */ double GaussNoise( double sigma ) { int rannum = rand(); double p; double value; /* create random numbers between 0 and 1 */ p = rannum/(RAND_MAX+1.0); /* project the range 0 to 1 to the x-range of the gauss distribution */ value = InvIntGauss ( p, sigma ); return ( value ); } /* GaussNoise */ spd-1.3.0/edfpack/numio.c0000644000175000017500000055734011633462462012137 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define NUMIO_VERSION "numio : V1.34 Peter Boesecke 2011-06-16" /*+++------------------------------------------------------------------------ NAME numio.c --- number expressions SYNOPSIS # include numio.h INCLUDE FILES numio.h gamma.h TO LINK WITH gamma.c PURPOSE Reading of double and long integer expressions from strings. See PUBLIC functions for detail. CALL long num_str2long(const char *str, const char **tail, int *perrval); double num_str2double(const char *str, const char **tail, int *perrval); AUTHOR 1995 Peter Boesecke (PB) HISTORY 11-Oct-1996 PB extracted from input.c 13-Oct-1996 PB dpconstant : physical constants and units, units are preceeded by an underscore '_' 02-Aug-2000 PB dpterm : case '%' added function doubleexpr added 28-Nov-2000 PB dpfunction : GAMMA_ added dpconstant : km3, ..., m3 added 04-Dec-2000 PB ->numio.c, .h 04-Feb-2003 PB Inf 03-Aug-2003 PB longexpr, floatexpr, doubleexpr: char * -> const char * 19-Feb-2004 PB dpfunction : min, max 02-Mar-2004 PB If a factor is followed by the underscore operator '_' it is immediately multiplied with the factor following the underscore. Parentheses around both factors are not necessary in this case. This simplifies the use of units, e.g. "1/1_nm" is identical to "1/(1*nm)". It was necessar to change the following functions: dpconstant: unit identifier '_' removed, no distinction between units and names any more names and units ordered by length dpfactor: new multiplicator '_' Because a unit does not start any more with an underscore all macros using units must be adapted. 16-Mar-2004 PB SaxsExpression -> numio V1.00 24-Mar-2004 PB STRNCASECMP -> num_strncasecmp 30-Mar-2004 PB error corrected: dpexpression and lvexpression stop at white space or comma 02-Apr-2004 PB parameter tail added to argument list of num_str2... num_str2... stops at a white space, a comma or a semicolon. If the evaluated expression is not complete or faulty, an error is returned. 03-Apr-2004 PB new units kg, J, W, pixel, photon 13-Jun-2004 PB double constant list (pixel and photon no longer defined) 19-Jun-2004 PB list rearranged, numio_debug created, name of electron charge changed from e to ec new units and constants: erg, dyn, cal, Pa, bar, N, V, A, C, lb, in, ft, lbf, psi, gN, ga 20-Jun-2004 PB debug mode 0|1|2, consistency check of units 07-Jul-2004 PB show quantity in debug mode, barn symbol is b instead of barn, new units Ar (a), poundal (pdl) 08-Jul-2004 PB new units Neugrad (gon), knots (kn), Kelvin (K) 05-Feb-2005 PB physical constants from CODATA 2002, SI prefixes extended: Peta - Yotta, zepto - yocto previous definition of Exa corrected to Peta Units from PTB 2004 mi -> mile after PTB 2004, unit Hz, constant mn inconsistent definition of amu in 2002 and 2004, using 2002, unit pond without prefixes, because mp hides proton rest mass mp 16-May-2005 PB Loop in dpfactor removed and dpfactor splitted into dpfactor1 and dpfactor2 21-May-2005 PB isvariable added 28-Jun-2005 PB test version NumProgramError, NumNoVariable, NumVar, dpprogram_run num_str2long calculates dp values with temporary program. next step: remove return value from all dp routines 29-Jun-2005 PB The file numprog.h has been included into numio.h. The file numprog.c is included into the code of numio.c. num_str2double creates a temporary program that is executed to calculate the value, new functions num_str2prog4, num_runprog4, num_rmprog. 30-Jun-2005 PB num_str2prog4 and num_runprog4 replaced by num_str2prog and num_runprog using a variable argument list (stdarg.h), numprog.c and numprog.h copied into numio.c and numio.h 06-Aug-2005 PB num_chkvar added 15-Sep-2005 PB dpvariable: Used is incremented and not Value num_chkvar corrected 11-Dec-2005 PB print routines declared in numio.h length routines: num_prog_variables, num_prog_accumulators, num_prog_instructions, num_prog_variable_size, num_prog_accumulator_size, num_prog_instruction_size num_prog_size, num_prog_size_all numprog_up_accumulator: If CurrentAccumulator is NULL, next is initialized with next = program->AccumulatorList and not with NULL, to force the reuse of already allocated accumulators. Otherwise each call to dpprogram_run would allocate an accumulator with number 1. 15-Mar-2006 PB dpconstant_print: printf argument mismatch corrected 13-Jun-2006 PB units added: liter, minute, hour, day, POW calculation corrected 19-Apr-2007 PB code corrected to avoid compiler warnings with -Wall 18-Jun-2007 V1.21 PB num_str2double, num_str2num: If str is the null pointer it is handled like an empty string. 19-Jul-2007 V1.22 PB units degK, degC, degF added, functions degC2K, degF2K, degK2K, K2degC, K2degF, K2degK added, isfunction: extended to capital characters 'A'-'Z' 08-Feb-2008 V1.23 PB CEIL: cosh corrected to ceil 21-May-2008 V1.24 PB binary constants added 22-May-2008 V1.25 PB num_double2hex added 23-May-2008 V1.26 PB num_double2hex 20-Mar-2009 V1.27 PB char **tail -> const char **tail 21-Mar-2009 V1.28 PB logical operators added: NOT, EQU, NEQ, LE, LT, GE, GT, AND, OR, IF 06-Oct-2009 V1.29 PB pi constant NUM_PI defined in numio.h (not used internally) 30-Jan-2011 V1.30 PB %g -> %lg double2s shortened 31-Jan-2011 V1.31 PB lcc does not like %ld and %lg on the same line, splitted to make compiler happy 09-Mar-2011 V1.32 PB double2s: format corrected to avoid leading spaces, in all public functions: perrval can be NULL 01-Jun-2011 V1.33 PB dpprogram_step: unique error exit 16-Jun-2011 V1.34 PB double constants marked, e.g. 1->1.0 --------------------------------------------------------------------------*/ /**************************************************************************** * Include * ****************************************************************************/ # include "numio.h" /**************************************************************************** * Static Variables * ****************************************************************************/ static int NUMIO_debug = 0; /**************************************************************************** * Enum (Basic Instructions) * * New functions must be added to these tables. Each function needs an * * entry in dpprogram_step. * * ATTENTION: InValidNumCommand must have the value 0 * * Do not change PUSHVAL, PUSHADDR * ****************************************************************************/ enum NumCommand { InValidNumCommand, PUSHVAL, PUSHADDR, NEG, MUL, NOT, EQU, NEQ, LE, LT, GE, GT, AND, OR, IF, DIV, REST, ADD, SUB, RAD, DEG, PI, SIN, COS, TAN, ASIN, ACOS, ATAN, ATAN2, SINH, COSH, TANH, FLOOR, CEIL, FABS, EXP, LOG, LOG10, POW, SQRT, ROUND, GAMMA, FMIN, FMAX, DEGC2K, K2DEGC, DEGF2K, K2DEGF, DEGK2K, K2DEGK, DEGF2DEGC, DEGC2DEGF, EndNumCommand }; static const char * NumCommandStrings[] = { "Invalid", "PUSHVAL", "PUSHADDR", "NEG", "MUL", "NOT", "EQU", "NEQ", "LE", "LT", "GE", "GT", "AND", "OR", "IF", "DIV", "REST", "ADD", "SUB", "RAD", "DEG", "PI", "SIN", "COS", "TAN", "ASIN", "ACOS", "ATAN", "ATAN2", "SINH", "COSH", "TANH", "FLOOR", "CEIL", "FABS", "EXP", "LOG", "LOG10", "POW", "SQRT", "ROUND", "GAMMA", "FMIN", "FMAX", "DEGC2K", "K2DEGC", "DEGF2K", "K2DEGF", "DEGK2K", "K2DEGK", "DEGF2DEGC", "DEGC2DEGF", (const char *) NULL }; /**************************************************************************** * Number Program Routines * ****************************************************************************/ /**************************************************************************** * Defines * ****************************************************************************/ # define NumBUFLEN 128 /*************************************************************************** * Number Program Static Variables * ***************************************************************************/ static int NUMPROG_init = 0; /* init flag */ static NumProg * NumProgRoot = (NumProg *) NULL; /* program root */ /*************************************************************************** * Number Program Functions * ***************************************************************************/ int numprog_init ( void ); NumProg * numprog_new ( const char * Name ); int numprog_insert ( const char * Name, NumProg **pprogram ); int numprog_remove ( const char * Name ); int numprog_search ( const char * Name, NumProg **pprogram ); int numprog_free ( NumProg *program ); int numprog_append_variable ( NumProg *program, const char * Key, double InitValue, NumVar **pvariable ); int numprog_search_variable ( NumProg *program, const char *Key, NumVar **pvariable, int mode ); int numprog_free_variable_list ( NumProg *program ); long num_prog_variables ( NumProg *program ); size_t num_prog_variable_size ( NumProg *program ); int num_prog_print_variable_list ( FILE * out, NumProg *program, int level, int verbose ); NumAccu *numprog_up_accumulator ( NumProg *program, double Value ); NumAccu *numprog_down_accumulator ( NumProg *program ); int numprog_free_accumulator_list ( NumProg *program ); long num_prog_accumulators ( NumProg *program ); size_t num_prog_accumulator_size ( NumProg *program ); int num_prog_print_accumulator_list( FILE * out, NumProg *program, int level, int verbose ); int numprog_append_instruction ( NumProg *program, int mode, int Command, int Nargs, double Value, double *Address, NumInstr **pinstruction ); int numprog_free_instruction_list ( NumProg *program, int mode ); long num_prog_instructions ( NumProg *program, int mode ); size_t num_prog_instruction_size ( NumProg *program, int mode ); int num_prog_print_instruction_list( FILE * out, NumProg *program, int mode, int level, int verbose ); int num_prog_print_list ( FILE * out, NumProg * program, int level, int verbose ); /*--------------------------------------------------------------------------- NAME numprog_newstr --- allocate memory and copy a character string into it SYNOPSIS char * numprog_newstr( const char * string ); DESCRIPTION Allocates strlen(´string´)+1 bytes of memory and copies ´string´ into it. In case of success the pointer to the allocated memory is returned. The null pointer is returned in case of an error. If ´string´ is the NULL pointer the NULL pointer is returned. RETURN VALUE Returns the pointer to the allocated string or (char *) NULL in case of an error. ---------------------------------------------------------------------------*/ char * numprog_newstr( const char * string ) { char * newstring; if (!string) return( (char *) NULL ); if (!(newstring = (char *) malloc(strlen(string)+1))) return((char *) NULL); (void) strcpy(newstring,string); return( newstring ); } /* numprog_newstr */ /*--------------------------------------------------------------------------- NAME numprog_checkvar --- check whether variable name contains invalid chars SYNOPSIS int numprog_checkvar( const char * string ); DESCRIPTION Checks, whether the input string contains only allowed characters. first character: ['a'..'z'], ['A'..'Z'] (isalpha) all other characters: ['0'..'9'], ['a'..'z'], ['A'..'Z'] (isalnum) RETURN VALUE 0: success, -1: error ---------------------------------------------------------------------------*/ int numprog_checkvar( const char * string ) { const char * ps; ps=string; if (!ps) return(-1); if (*ps) { if (isalpha((int) *ps)==0) return(-1); ps++; } while (*ps) { if (isalnum((int) *ps)==0) return(-1); ps++; } return( 0 ); } /* numprog_checkvar */ /*--------------------------------------------------------------------------- NAME numprog_cmd2str --- converts NumCommand to a string SYNOPSIS NumCommand numprog_cmd; const char * numprog_cmd2str( int numprog_cmd ) RETURN VALUE Pointer to a constant result string. -------------------------------------------------------------------------*/ const char * numprog_cmd2str( int numprog_cmd ) { if ((numprog_cmd<0)||(numprog_cmd>=EndNumCommand)) numprog_cmd = InValidNumCommand; return( NumCommandStrings[numprog_cmd] ); } /* numprog_cmd2str */ /*--------------------------------------------------------------------------- NAME numprog_ins2str --- converts NumInstr to a string SYNOPSIS NumCommand numprog_cmd; const char * numprog_ins2str( char buffer[], size_t buflen, NumInstr * ins ) RETURN VALUE success: Pointer to a constant result string. -------------------------------------------------------------------------*/ const char * numprog_ins2str ( char buffer[], size_t buflen, NumInstr * ins ) { char * pb; buffer[0] = (char) 0; pb = buffer; if (buflen<50) return(pb); switch (ins->Command) { case PUSHVAL: /* value parameter */ sprintf(pb,"%10s %10g", numprog_cmd2str(ins->Command), ins->Value); break; case PUSHADDR: /* address parameter */ sprintf(pb,"%10s *%10p", numprog_cmd2str(ins->Command), ins->Address); break; default: /* no parameter */ sprintf(pb,"%10s %10s (%d args)", numprog_cmd2str(ins->Command), "", ins->Nargs); break; } return( pb ); } /* numprog_ins2str */ /*--------------------------------------------------------------------------- NAME numprog_init --- Initializes the module SYNOPSIS int numprog_init ( void ); DESCRPTION Initializes the program lists. It should be called by routines that access directly NumProgRoot, if NUMPROG_init is not set. Currently, only the initialization flag is set to 1. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int numprog_init ( void ) { NUMPROG_init = 1; return(0); } /* numprog_init */ /*--------------------------------------------------------------------------- NAME numprog_new --- Create a program SYNOPSIS NumProg * numprog_new ( const char * Name ); DESCRPTION Creates new program with Name and returns a pointer to it. An existing program is removed and reallocated with a different pointer. RETURN VALUE success: POINTER, error: NULL ---------------------------------------------------------------------------*/ PUBLIC NumProg * numprog_new ( const char * Name ) { NumProg * program; if (numprog_search ( Name, &program )) return ( (NumProg *) NULL ); if (numprog_free( program )) return ( (NumProg *) NULL ); if (numprog_insert ( Name, &program )) return ( (NumProg *) NULL ); return( program ); } /* numprog_new */ /*--------------------------------------------------------------------------- NAME numprog_insert --- Insert a program SYNOPSIS int numprog_insert ( const char * Name, NumProg **pprogram ); DESCRPTION Insert a program with Name and update *pprogram with the pointer to program. If 'Name' already exists only *pprogram is updated. In case of success the pointer to program is returned in *pprogram, otherwise NULL. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int numprog_insert ( const char * Name, NumProg **pprogram ) { NumProg * newprogram, * next, * previous; int notfound = 1; if (!NUMPROG_init) numprog_init(); if (pprogram) *pprogram = (NumProg *) NULL; if (!Name) return(-1); previous = (NumProg *) NULL; next = NumProgRoot; /* search insertion point (insertion before next) */ while ( ( next!=(NumProg *) NULL ) && (notfound>0) ) { notfound = strcmp(next->Name,Name); if (notfound>0) {previous = next; next = next->Next;} } /* create new program Name, if notfound */ if ( notfound ) { /* create new program Name */ if (!(newprogram = (NumProg*) malloc(sizeof(NumProg)))) return(-1); newprogram->Name = numprog_newstr( Name ); if (!newprogram->Name) return(-1); newprogram->VariableList = (NumVar *) NULL; newprogram->AccumulatorList = (NumAccu *) NULL; newprogram->CurrentAccumulator = (NumAccu *) NULL; newprogram->InstructionList = (NumInstr *) NULL; newprogram->CompiledList = (NumInstr *) NULL; /* insert newprogram before next */ if (next) next->Previous = newprogram; newprogram->Next=next; newprogram->Previous=previous; if (previous) previous->Next=newprogram; else NumProgRoot = newprogram; next = newprogram; } if (pprogram) *pprogram = next; return(0); } /* numprog_insert */ /*--------------------------------------------------------------------------- NAME numprog_search --- search program SYNOPSIS int numprog_search ( const char * Name, NumProg **pprogram ) DESCRPTION Search program Name in the program list. If found, the pointer to program is returned, otherwise NULL. All characters of Name are compared. Name is searched from the beginning of the list which is inversely lexicographically ordered. RETURN VALUE Attention: The return value indicates errors only. It does not indicate whether the program was found. success:0, error:-1 ---------------------------------------------------------------------------*/ int numprog_search ( const char * Name, NumProg **pprogram ) { NumProg * current; if (!NUMPROG_init) numprog_init(); if (pprogram) *pprogram = (NumProg *) NULL; if (!Name) return(-1); /* search Name */ current = NumProgRoot; if ( current!=(NumProg *) NULL ) while( ( current!=(NumProg *) NULL ) && ( strcmp(current->Name,Name)!=0) ) { current = current->Next; } if (pprogram) *pprogram = current; return(0); } /* numprog_search */ /*--------------------------------------------------------------------------- NAME numprog_free SYNOPSIS int numprog_free( NumProg * program ); DESCRIPTION Removes program from NumProgRoot and releases its contents RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ PUBLIC int numprog_free( NumProg * program ) { NumProg * previous, *next; if (!NUMPROG_init) numprog_init(); /* nothing to do, if NULL pointer is given */ if (program==(NumProg *) NULL) return(0); /* check, whether program is in NumProgRoot list */ next=NumProgRoot; while ((next)&&(program!=next)) next=next->Next; if (next==(NumProg *) NULL) return(-1); /* change links */ previous = program->Previous; next = program->Next; if ( next != (NumProg *) NULL ) next->Previous = previous; if ( previous != (NumProg *) NULL ) previous->Next = next; else NumProgRoot = next; /* free program and its elements */ if (numprog_free_variable_list ( program )) return(-1); if (numprog_free_accumulator_list ( program )) return(-1); if (numprog_free_instruction_list ( program, 0 )) return(-1); if (numprog_free_instruction_list ( program, 1 )) return(-1); if (program->Name) free(program->Name); free(program); return(0); } /* numprog_free */ /*--------------------------------------------------------------------------- NAME numprog_remove --- remove program(s) SYNOPSIS int numprog_remove ( const char * Name ); DESCRIPTION Removes program Name and its contents. If called with Name == (char *) NULL, all programs are removed RETURN VALUE success:0, error:-1 --------------------------------------------------------------------------+*/ int numprog_remove ( const char * Name ) { NumProg * next, * current; if (!NUMPROG_init) numprog_init(); if ( Name != (char *) NULL ) { /* search program ´Name´ */ if (numprog_search( Name, ¤t )) return(-1); /* remove current program */ if (numprog_free( current )) return(-1); } else { next = NumProgRoot; while ( next != (NumProg *) NULL ) { current = next; next = current->Next; /* remove current program */ if (numprog_free( current )) return(-1); } } return( 0 ); } /* numprog_remove */ /*--------------------------------------------------------------------------- NAME num_prog_size --- return program size SYNOPSIS size_t num_prog_size( NumProg * program ); DESCRIPTION Returns size of program or 0 if program is NULL. RETURN VALUE program size in bytes ---------------------------------------------------------------------------*/ PUBLIC size_t num_prog_size( NumProg * program ) { size_t prog_size=0; if (!NUMPROG_init) numprog_init(); if (program!=(NumProg *) NULL) { prog_size += sizeof( NumProg ); prog_size += strlen( program->Name )+1; prog_size += num_prog_variable_size(program); prog_size += num_prog_accumulator_size(program); prog_size += num_prog_instruction_size(program,0); prog_size += num_prog_instruction_size(program,1); } return(prog_size); } /* num_prog_size */ /*--------------------------------------------------------------------------- NAME num_prog_size_all --- return size of all programs SYNOPSIS size_t num_prog_size_all( void ); DESCRIPTION Returns size of all programs. RETURN VALUE program size in bytes ---------------------------------------------------------------------------*/ PUBLIC extern size_t num_prog_size_all ( void ) { NumProg * program; size_t prog_size=0; if (!NUMPROG_init) numprog_init(); program = NumProgRoot; while(program!=(NumProg *) NULL) prog_size += num_prog_size ( program ); return(prog_size); } /* num_prog_size_all */ /*--------------------------------------------------------------------------- NAME num_prog_print_list --- print program(s) SYNOPSIS int num_prog_print_list( FILE * out, NumProg * program, int level, int verbose ); DESCRIPTION Prints program list to out. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ PUBLIC int num_prog_print_list( FILE * out, NumProg * program, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - - - - - - - - - - - - - - - -"; NumProg * currentprogram; if (!NUMPROG_init) numprog_init(); if (level<1) return(0); if (program) currentprogram = program; else currentprogram = NumProgRoot; while(currentprogram!=(NumProg *) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Name = %s\n",currentprogram->Name); num_prog_print_variable_list(out,currentprogram,level-1,verbose); num_prog_print_accumulator_list(out,currentprogram,level-1,verbose); num_prog_print_instruction_list(out,currentprogram,0,level-1,verbose); // num_prog_print_instruction_list(out,currentprogram,1,level-1,verbose); fprintf(out," Previous program = "); if ((currentprogram->Previous)!=(NumProg *) NULL) fprintf(out,"%s\n", currentprogram->Previous->Name); else fprintf(out,"(no previous program)\n"); fprintf(out," Next program = "); if ((currentprogram->Next)!=(NumProg *) NULL) fprintf(out,"%s\n", currentprogram->Next->Name); else fprintf(out,"(no next program)\n"); if (currentprogram->CurrentAccumulator) { // fprintf splitted to make lcc happy fprintf(out," CurrentAccumulator = #%ld", currentprogram->CurrentAccumulator->Number); fprintf(out," (Value = %lg)\n", currentprogram->CurrentAccumulator->Value); } else fprintf(out," CurrentAccumulator = (no current accumulator)\n"); } else { fprintf(out," Program = '%s'\n",currentprogram->Name); num_prog_print_variable_list(out,currentprogram,level-1,verbose ); num_prog_print_instruction_list(out,currentprogram,0,level-1,verbose ); // num_prog_print_instruction_list(out,currentprogram,1,level-1,verbose ); num_prog_print_accumulator_list(out,currentprogram,level-1,verbose ); } if (program) currentprogram = (NumProg *) NULL; else currentprogram=currentprogram->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* num_prog_print_list */ /*--------------------------------------------------------------------------- NAME numprog_append_variable --- Appends a variable to the end of the list SYNOPSIS int numprog_append_variable ( NumProg *program, const char * Key, double InitValue, NumVar **pvariable ); DESCRPTION Appends a variable with name Key to the variable list of program and updates *pvariable with the pointer to the variable. If 'Key' already exists only *pvariable is updated and an error is returned. If 'Key' does not exist the new variable is appended to the end of the list. The pointer to the variable is returned in *pvariable. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ PUBLIC int numprog_append_variable ( NumProg *program, const char * Key, double InitValue, NumVar **pvariable ) { NumVar * newvariable, * next, * previous; int notfound = 1; if (pvariable) *pvariable = (NumVar *) NULL; if (!Key) return(-1); /* Check, whether Key contains only allowed characters */ if ( numprog_checkvar( Key ) ) return(-1); /* Nothing to do if program pointer is NULL */ if ( !program ) return(0); previous = (NumVar *) NULL; next = program->VariableList; /* search insertion point (insertion before next) */ while ( ( next!=(NumVar *) NULL ) && (notfound!=0) ) { notfound = strcmp(next->Key,Key); if (notfound!=0) {previous = next; next = next->Next;} } /* create new variable Key, if notfound */ if ( notfound ) { /* create new variable Key */ if (!(newvariable = (NumVar*) malloc(sizeof(NumVar)))) return(-1); newvariable->Key = numprog_newstr( Key ); if (!newvariable->Key) return(-1); newvariable->Value = InitValue; newvariable->Used = 0; /* insert newvariable before next */ if (next) next->Previous = newvariable; newvariable->Next=next; newvariable->Previous=previous; if (previous) previous->Next=newvariable; else program->VariableList = newvariable; next = newvariable; } if (pvariable) *pvariable = next; if (!notfound) return(-1); return(0); } /* numprog_append_variable */ /*--------------------------------------------------------------------------- NAME numprog_search_variable --- search variable SYNOPSIS int numprog_search_variable ( NumProg *program, const char *Key, NumVar **pvariable, int mode ); DESCRPTION Searches variable in the variable list of program. In case of success the pointer to variable is returned in *pvariable, otherwise NULL. If mode==0, all characters of Key are compared, if mode==1, the comparison stops if a variable is found where all characters match the first characters of Key. Key is searched from the beginning of the list which is inversely lexicographically ordered. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int numprog_search_variable ( NumProg *program, const char *Key, NumVar **pvariable, int mode ) { NumVar * current; if (pvariable) *pvariable = (NumVar *) NULL; if (!Key) return(-1); /* Nothing to search if program pointer is NULL */ if ( !(NumProg * ) program ) return(-1); /* search Key */ current = program->VariableList; if ( current!=(NumVar *) NULL ) { if (mode==0) { while( ( current!=(NumVar *) NULL ) && ( strcmp(current->Key,Key)!=0) ) { current = current->Next; } } else { while( ( current!=(NumVar *) NULL ) && ( strncmp(current->Key,Key,strlen(current->Key))!=0) ) { current = current->Next; } } } if (pvariable) *pvariable = current; if (current==(NumVar *) NULL) return(-1); return(0); } /* numprog_search_variable */ /*--------------------------------------------------------------------------- NAME numprog_free_variable_list --- remove variable list SYNOPSIS int numprog_free_variable_list ( NumProg * program ); DESCRIPTION Removes variable list from program RETURN VALUE success:0, error:-1 --------------------------------------------------------------------------+*/ int numprog_free_variable_list ( NumProg * program ) { NumVar * variable, * next; /* Nothing to do if no program pointer is given */ if (!program) return(0); next = program->VariableList; program->VariableList = (NumVar *) NULL; while(next!=(NumVar*) NULL) { variable = next; next=next->Next; free(variable->Key); free(variable); } return(0); } /* numprog_free_variable_list */ /*--------------------------------------------------------------------------- NAME num_prog_variables --- return number of variables SYNOPSIS long num_prog_variables ( NumProg *program ); DESCRIPTION Return number of variables. RETURN VALUE number of variables ---------------------------------------------------------------------------*/ PUBLIC long num_prog_variables ( NumProg *program ) { NumVar * variable, * next; long variable_length=0l; /* Nothing to do if no program pointer is given */ if (!program) return(variable_length); next = program->VariableList; while(next!=(NumVar*) NULL) { variable = next; next=next->Next; variable_length++; } return(variable_length); } /* num_prog_variables */ /*--------------------------------------------------------------------------- NAME num_prog_variable_size --- return allocated memory size of variable list SYNOPSIS size_t num_prog_variable_size ( NumProg *program ); DESCRIPTION Return allocated memory size of variable list. RETURN VALUE allocated memory size ---------------------------------------------------------------------------*/ PUBLIC size_t num_prog_variable_size ( NumProg *program ) { NumVar * variable, * next; size_t variable_size=0; /* Nothing to do if no program pointer is given */ if (!program) return(variable_size); next = program->VariableList; while(next!=(NumVar*) NULL) { variable = next; next=next->Next; variable_size += sizeof(NumVar); } return(variable_size); } /* num_prog_variable_size */ /*--------------------------------------------------------------------------- NAME num_prog_print_variable_list --- print variable list of program SYNOPSIS int num_prog_print_variable_list ( FILE * out, NumProg *program, int level, int verbose ); DESCRIPTION Prints program variable list to out. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ PUBLIC int num_prog_print_variable_list ( FILE * out, NumProg *program, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - -"; NumVar * variable; if (level<1) return(0); /* Nothing to print if program pointer is NULL */ if ( !(NumProg * ) program ) return(0); variable = program->VariableList; while(variable!=(NumVar *) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Variable = %s\n",variable->Key); fprintf(out," Value = %lg\n",variable->Value); fprintf(out," Used = %d\n",variable->Used); fprintf(out," Previous variable = "); if ((variable->Previous)!=(NumVar *) NULL) fprintf(out,"%s\n", variable->Previous->Key); else fprintf(out,"(no previous variable)\n"); fprintf(out," Next variable = "); if ((variable->Next)!=(NumVar *) NULL) fprintf(out,"%s\n", variable->Next->Key); else fprintf(out,"(no next variable)\n"); } else { fprintf(out," '%s' = %lg = *%p\n", variable->Key,variable->Value,&(variable->Value)); } variable=variable->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* num_prog_print_variable_list */ /*--------------------------------------------------------------------------- NAME numprog_up_accumulator --- increments program->CurrentAccumulator SYNOPSIS NumAccu *numprog_up_accumulator( NumProg *program, double Value ); DESCRPTION Increments program->CurrentAccumulator to next Accumulator. If it does not exist it is appended to the accumulator list of program. The Accumulator is initialized with Value. The pointer to the Accumulator is returned. RETURN VALUE success: POINTER , error: NULL ---------------------------------------------------------------------------*/ NumAccu *numprog_up_accumulator( NumProg *program, double Value ) { NumAccu * newaccumulator, * next, * current; long current_number; /* Nothing to do if program pointer is NULL */ if ( !program ) return( (NumAccu *) NULL ); current = program->CurrentAccumulator; if (current) next = current->Next; else next = program->AccumulatorList; // use existing accumulator if (current) current_number=current->Number; else current_number=0; if (!next) { /* append new accumulator */ if (!(newaccumulator = (NumAccu*) malloc(sizeof(NumAccu)))) return( (NumAccu *) NULL ); newaccumulator->Number = current_number+1; /* insert newaccumulator before next */ if (next) next->Previous = newaccumulator; newaccumulator->Next=next; newaccumulator->Previous=current; if (current) current->Next=newaccumulator; else program->AccumulatorList = newaccumulator; next = newaccumulator; } next->Value = Value; program->CurrentAccumulator = next; return( next ); } /* numprog_up_accumulator */ /*--------------------------------------------------------------------------- NAME numprog_down_accumulator --- decrements program->CurrentAccumulator SYNOPSIS NumAccu *numprog_down_accumulator( NumProg *program, double Value ); DESCRPTION Decrements program->CurrentAccumulator to previous Accumulator. The pointer to the Accumulator is returned. RETURN VALUE success: POINTER , error: NULL ---------------------------------------------------------------------------*/ NumAccu *numprog_down_accumulator ( NumProg *program ) { NumAccu * current, * previous; /* Nothing to do if program pointer is NULL */ if ( !program ) return( (NumAccu *) NULL ); current = program->CurrentAccumulator; if (current) previous = current->Previous; else previous = (NumAccu *) NULL; program->CurrentAccumulator = previous; return( previous ); } /* numprog_down_accumulator */ /*--------------------------------------------------------------------------- NAME numprog_free_accumulator_list --- remove accumulator list SYNOPSIS int numprog_free_accumulator_list ( NumProg * program ); DESCRIPTION Removes accumulator list from program RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int numprog_free_accumulator_list ( NumProg *program ) { NumAccu * accumulator, * next; /* Nothing to do if no program pointer is given */ if (!program) return(0); next = program->AccumulatorList; program->AccumulatorList = (NumAccu *) NULL; while(next!=(NumAccu*) NULL) { accumulator = next; next=next->Next; free(accumulator); } return(0); } /* numprog_free_accumulator_list */ /*--------------------------------------------------------------------------- NAME num_prog_accumulators --- return number of available accumulators SYNOPSIS long num_prog_accumulators ( NumProg *program ): DESCRIPTION Return number of available accumulators. RETURN VALUE number of accumulators ---------------------------------------------------------------------------*/ PUBLIC long num_prog_accumulators ( NumProg *program ) { NumAccu * accumulator, * next; long accu_length=0l; /* Nothing to do if no program pointer is given */ if (!program) return(accu_length); next = program->AccumulatorList; while(next!=(NumAccu*) NULL) { accumulator = next; next=next->Next; accu_length++; } return(accu_length); } /* num_prog_accumulators */ /*--------------------------------------------------------------------------- NAME num_prog_accumulator_size --- return alloc. memory size of accumulator table SYNOPSIS size_t num_prog_accumulator_size ( NumProg *program ); DESCRIPTION Return allocated memory size of accumulator table RETURN VALUE allocated memory size ---------------------------------------------------------------------------*/ PUBLIC size_t num_prog_accumulator_size ( NumProg *program ) { NumAccu * accumulator, * next; size_t accu_size=0; /* Nothing to do if no program pointer is given */ if (!program) return(accu_size); next = program->AccumulatorList; while(next!=(NumAccu*) NULL) { accumulator = next; next=next->Next; accu_size += sizeof(NumAccu); } return(accu_size); } /* num_prog_accumulator_size */ /*--------------------------------------------------------------------------- NAME num_prog_print_accumulator_list --- print accumulator list of program SYNOPSIS int num_prog_print_accumulator_list ( FILE * out, NumProg *program, int level, int verbose ); DESCRIPTION Prints program accumulator list to out. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ PUBLIC int num_prog_print_accumulator_list ( FILE * out, NumProg *program, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - -"; NumAccu * accumulator; if (level<1) return(0); /* Nothing to print if program pointer is NULL */ if ( !(NumProg * ) program ) return(0); accumulator = program->AccumulatorList; while(accumulator!=(NumAccu *) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Accumulator = #%ld\n",accumulator->Number); fprintf(out," Value = %lg\n",accumulator->Value); fprintf(out," Previous accumulator = "); if ((accumulator->Previous)!=(NumAccu *) NULL) fprintf(out,"#%ld\n", accumulator->Previous->Number); else fprintf(out,"(no previous accumulator)\n"); fprintf(out," Next accumulator = "); if ((accumulator->Next)!=(NumAccu *) NULL) fprintf(out,"#%ld\n", accumulator->Next->Number); else fprintf(out,"(no next accumulator)\n"); } else { // fprintf splitted to make lcc happy fprintf(out," Accumulator #%ld =", accumulator->Number); fprintf(out," %lg\n", accumulator->Value); } accumulator=accumulator->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* num_prog_print_accumulator_list */ /*--------------------------------------------------------------------------- NAME numprog_append_instruction --- Appends a program instruction SYNOPSIS int numprog_append_instruction ( NumProg *program, int mode, int Command, int Nargs, double Value, double *Address, NumInstr **pinstruction ); DESCRIPTION mode 0: Appends a new instruction to the end of the instruction list that starts at program->InstructionList. mode 1: Appends a new instruction to the end of the instruction list that starts at program->CompiledList. Nargs is the number of arguments required by the command, e.g. Nargs = 0 : no argument, accumulator number is increased by 1 Nargs = 1 : 1 argument, accumulator number is not changed Nargs = N : N arguments, accumulator number is decreased by N-1 This information is only used by numprog_optimize It updates *pinstruction with the pointer to the new instruction. In case of success the pointer to the instruction is returned in *pinstruction, otherwise NULL. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ PUBLIC int numprog_append_instruction ( NumProg *program, int mode, int Command, int Nargs, double Value, double *Address, NumInstr **pinstruction ) { NumInstr * newinstruction, * next, * previous, **proot; if (pinstruction) *pinstruction = (NumInstr *) NULL; /* Nothing to append if program pointer is NULL */ if ( !program ) return(0); previous = (NumInstr *) NULL; switch (mode) { case 0: proot = &(program->InstructionList); break; case 1: proot = &(program->CompiledList); break; default: /* Error */ return(-1); } next = *proot; /* search insertion point (insertion before next) */ while ( ( next!=(NumInstr *) NULL ) ) { previous = next; next = next->Next; } /* create new instruction */ if (!next) { /* create new instruction */ if (!(newinstruction = (NumInstr*) malloc(sizeof(NumInstr)))) return(-1); newinstruction->Command = Command; newinstruction->Nargs = Nargs; newinstruction->Value = Value; newinstruction->Address = Address; /* insert newinstruction before next */ if (next) next->Previous = newinstruction; newinstruction->Next=next; newinstruction->Previous=previous; if (previous) previous->Next=newinstruction; else *proot = newinstruction; next = newinstruction; } if (pinstruction) *pinstruction = next; return(0); } /* numprog_append_instruction */ /*--------------------------------------------------------------------------- NAME numprog_free_instruction_list --- remove instruction list SYNOPSIS int numprog_free_instruction_list ( NumProg * program, int mode ); DESCRIPTION mode 0: Removes the list starting at program->InstructionList. mode 1: Removes the list starting at program->CompiledList. RETURN VALUE success:0, error:-1 --------------------------------------------------------------------------+*/ int numprog_free_instruction_list ( NumProg *program, int mode ) { NumInstr * instruction, * next, **proot; /* Nothing to do if program pointer is NULL */ if (!program) return(0); switch (mode) { case 0: proot = &(program->InstructionList); break; case 1: proot = &(program->CompiledList); break; default: /* Error */ return(-1); } next = *proot; *proot = (NumInstr *) NULL; while(next!=(NumInstr*) NULL) { instruction = next; next=next->Next; free(instruction); } return(0); } /* numprog_free_instruction_list */ /*--------------------------------------------------------------------------- NAME num_prog_instructions --- return number of instructions SYNOPSIS long num_prog_instructions ( NumProg *program, int mode ); DESCRIPTION Return number of instructions. mode 0: InstructionList. mode 1: CompiledList. mode 2: If CompiledList exist returns its length, otherwise return the length of InstructionList RETURN VALUE number of instructions ---------------------------------------------------------------------------*/ PUBLIC long num_prog_instructions ( NumProg *program, int mode ) { NumInstr * current; long instruction_length=0l; /* Nothing to do if program pointer is NULL */ if (!program) return(instruction_length); switch (mode) { case 0: current = program->InstructionList; break; case 1: current = program->CompiledList; break; case 2: if (program->CompiledList) current = program->CompiledList; else current = program->InstructionList; break; default: /* Error */ return(instruction_length); } while(current!=(NumInstr*) NULL) { instruction_length++; current=current->Next; } return(instruction_length); } /* num_prog_instructions */ /*--------------------------------------------------------------------------- NAME num_prog_instruction_size --- return alloc. memory size of instruction list SYNOPSIS size_t num_prog_instruction_size ( NumProg *program, int mode ); DESCRIPTION Return allocated memory size of instruction list mode 0: InstructionList. mode 1: CompiledList. RETURN VALUE allocated memory size ---------------------------------------------------------------------------*/ PUBLIC size_t num_prog_instruction_size ( NumProg *program, int mode ) { NumInstr * instruction, * next, **proot; size_t instruction_size=0; /* Nothing to do if program pointer is NULL */ if (!program) return(instruction_size); switch (mode) { case 0: proot = &(program->InstructionList); break; case 1: proot = &(program->CompiledList); break; default: /* Error */ return(0); } next = *proot; while(next!=(NumInstr*) NULL) { instruction = next; next=next->Next; instruction_size += sizeof(NumInstr); } return(instruction_size); } /* num_prog_instruction_size */ /*--------------------------------------------------------------------------- NAME num_prog_print_instruction_list --- print instruction list of program SYNOPSIS int num_prog_print_instruction_list ( FILE * out, NumProg *program, int mode, int level, int verbose ); DESCRIPTION mode 0: Prints the list starting at program->InstructionList to out. mode 1: Prints the list starting at program->CompiledList to out. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ PUBLIC int num_prog_print_instruction_list ( FILE * out, NumProg *program, int mode, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - -"; char buffer[NumBUFLEN]; size_t buflen=NumBUFLEN; NumInstr * instruction, **proot; if (level<1) return(0); /* Nothing to print if program pointer is NULL */ if ( !program ) return(0); switch (mode) { case 0: fprintf(out," %s\n","InstructionList"); proot = &(program->InstructionList); break; case 1: fprintf(out," %s\n","CompiledList"); proot = &(program->CompiledList); break; default: /* Error */ return(-1); } instruction = *proot; while(instruction!=(NumInstr *) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Command = %s\n", numprog_ins2str ( buffer, buflen, instruction ) ); fprintf(out," Previous instruction = "); if ((instruction->Previous)!=(NumInstr *) NULL) fprintf(out,"%s\n", numprog_ins2str ( buffer,buflen,instruction->Previous )); else fprintf(out,"(no previous instruction)\n"); fprintf(out," Next instruction = "); if ((instruction->Next)!=(NumInstr *) NULL) fprintf(out,"%d\n", instruction->Next->Command); else fprintf(out,"(no next instruction)\n"); } else { fprintf(out," %s\n", numprog_ins2str ( buffer, buflen, instruction ) ); } instruction=instruction->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* num_prog_print_instruction_list */ /*************************************************************************** * Double Constant List Structure Definition * ***************************************************************************/ typedef struct Double_Constant { char * Key; /* pointer to key string */ double Value; /* Value of the constant */ char * Quantity; /* pointer to description string */ char * Unit; /* pointer to unit string */ struct Double_Constant *Previous,*Next; /* previous and next constants */ } DPConstant; /**************************************************************************** * Double Constant Static Variables * ****************************************************************************/ static int DPConstantInit = 0; /* init flag */ static DPConstant * DPConstantRoot = (DPConstant *) NULL; /* list root */ static const double Yotta = 1e+24, Yotta2 = 1e+48, Yotta3 = 1e+72; static const double Zetta = 1e+21, Zetta2 = 1e+42, Zetta3 = 1e+63; static const double Exa = 1e+18, Exa2 = 1e+36, Exa3 = 1e+54; static const double Peta = 1e+15, Peta2 = 1e+30, Peta3 = 1e+45; static const double Tera = 1e+12, Tera2 = 1e+24, Tera3 = 1e+36; static const double Giga = 1e+09, Giga2 = 1e+18, Giga3 = 1e+27; static const double Mega = 1e+06, Mega2 = 1e+12, Mega3 = 1e+18; static const double Kilo = 1e+03, Kilo2 = 1e+06, Kilo3 = 1e+09; static const double Hekto = 1e+02, Hekto2 = 1e+04, Hekto3 = 1e+06; // static const double Deka = 1e+01, Deka2 = 1e+02, Deka3 = 1e+03; //unused static const double deci = 1e-01, deci2 = 1e-02, deci3 = 1e-03; static const double centi = 1e-02, centi2 = 1e-04, centi3 = 1e-06; static const double milli = 1e-03, milli2 = 1e-06, milli3 = 1e-09; static const double micro = 1e-06, micro2 = 1e-12, micro3 = 1e-18; static const double nano = 1e-09, nano2 = 1e-18, nano3 = 1e-27; static const double pico = 1e-12, pico2 = 1e-24, pico3 = 1e-36; static const double femto = 1e-15, femto2 = 1e-30, femto3 = 1e-45; static const double atto = 1e-18, atto2 = 1e-36, atto3 = 1e-54; // static const double zepto = 1e-21, zepto2 = 1e-42, zepto3 = 1e-63; // unused static const double zepto = 1e-21, zepto3 = 1e-63; static const double yocto = 1e-24, yocto2 = 1e-48, yocto3 = 1e-72; /**************************************************************************** * Internal Functions * ****************************************************************************/ /*--------------------------------------------------------------------------- NAME num_newstr --- allocate memory and copy a character string into it SYNOPSIS char * num_newstr( const char * string ); DESCRIPTION Allocates strlen(´string´)+1 bytes of memory and copies ´string´ into it. In case of success the pointer to the allocated memory is returned. The null pointer is returned in case of an error. If ´string´ is the NULL pointer the NULL pointer is returned. RETURN VALUE Returns the pointer to the allocated string or (char *) NULL in case of an error. ---------------------------------------------------------------------------*/ char * num_newstr( const char * string ) { char * newstring; if (!string) return( (char *) NULL ); if (!(newstring = (char *) malloc(strlen(string)+1))) return((char *) NULL); (void) strcpy(newstring,string); return( newstring ); } /* num_newstr */ /**************************************************************************** * Program Functions * ****************************************************************************/ /*--------------------------------------------------------------------------- NAME dpprogram_step --- Step through a single instruction SYNOPSIS int dpprogram_step ( NumProg * program, NumInstr * instruction, int * perrval ); DESCRPTION Executes a single instruction. It uses program->CurrentAccumulator as current accumulator. In case of success this pointer is updated. At entry accumulator->Value must contain argumentN, accumulator->Previous->Value must contain argumentN-1 and so on until argument1. The instruction is executed with these input arguments and the result is written to the accumulator that contained originally argument1. Instructions without input arguments (PUSHVAL, PUSHADDR, PI) write the output value to accumulator->Next->Value. If necessary, memory for this accumulator is allocated. The values of the variables that are defined in program->VariableList are used for calculation. ERROR VALUES *perrval NumSuccess : success program errors: (in this case the returned address is NULL) NumNoAccumulator : not enough accumulator cells available NumNoInstruction : unknown instruction calculation errors: NumDivByZero : division by zero NumDomainError : some of the input arguments are outside RETURN VALUE success: 0 in case of success or a calculation error (DivByZero, DomainError) error :-1 in case of a program error (NumNoAccumulator, NumNoInstruction) In case of return value 0 the calculations can be repeated with changed variable values, in case of return value -1 the program is corrupted and cannot be used. ---------------------------------------------------------------------------*/ int dpprogram_step ( NumProg * program, NumInstr * instruction, int * perrval ) { int errval; const double pi = 3.1415926535897932384626; const double degtorad = pi/180.0; const double radtodeg = 180.0/pi; double argument1, argument2, argument3; NumAccu * accumulator; errval = NumSuccess; if (!program) { errval = NumProgramError; goto dpprogram_step_error; } if (!instruction) { errval = NumNoInstruction; goto dpprogram_step_error; } accumulator = program->CurrentAccumulator; switch (instruction->Command) { case PUSHVAL: accumulator = numprog_up_accumulator( program, instruction->Value ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } break; case PUSHADDR: accumulator = numprog_up_accumulator( program,*(instruction->Address) ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } break; case NEG: argument1 = accumulator->Value; accumulator->Value = -argument1; break; case MUL: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = argument1 * argument2; break; case NOT: argument1 = accumulator->Value; accumulator->Value = argument1?0.0:1.0; break; case EQU: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 == argument2)?1.0:0.0; break; case NEQ: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 != argument2)?1.0:0.0; break; case LE: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 <= argument2)?1.0:0.0; break; case LT: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 < argument2)?1.0:0.0; break; case GE: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 >= argument2)?1.0:0.0; break; case GT: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 > argument2)?1.0:0.0; break; case AND: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 && argument2)?1.0:0.0; break; case OR: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1 || argument2)?1.0:0.0; break; case IF: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; argument3 = accumulator->Next->Next->Value; accumulator->Value = argument1 ? argument2 : argument3; break; case DIV: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; if ( argument2 != 0.0 ) { accumulator->Value = argument1 / argument2; } else errval = NumDivByZero; break; case REST: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; if ( argument2 != 0.0 ) { accumulator->Value = (double) ((long)floor(argument1+0.5)%(long)floor(argument2+0.5)); } else errval = NumDivByZero; break; case ADD: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = argument1 + argument2; break; case SUB: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = argument1 - argument2; break; case RAD: argument1 = accumulator->Value; accumulator->Value = degtorad * argument1; break; case DEG: argument1 = accumulator->Value; accumulator->Value = radtodeg * argument1; break; case PI: accumulator = numprog_up_accumulator( program, pi ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } break; case SIN: argument1 = accumulator->Value; accumulator->Value = sin( argument1 ); break; case COS: argument1 = accumulator->Value; accumulator->Value = cos( argument1 ); break; case TAN: argument1 = accumulator->Value; accumulator->Value = tan( argument1 ); break; case ASIN: argument1 = accumulator->Value; if (fabs(argument1)<=1.0) { accumulator->Value = asin( argument1 ); } else errval=NumDomainError; break; case ACOS: argument1 = accumulator->Value; if (fabs(argument1)<=1.0) { accumulator->Value = acos( argument1 ); } else errval=NumDomainError; break; case ATAN: argument1 = accumulator->Value; accumulator->Value = atan( argument1 ); break; case ATAN2: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = atan2( argument1 , argument2 ); break; case SINH: argument1 = accumulator->Value; accumulator->Value = sinh( argument1 ); break; case COSH: argument1 = accumulator->Value; accumulator->Value = cosh( argument1 ); break; case TANH: argument1 = accumulator->Value; accumulator->Value = tanh( argument1 ); break; case FLOOR: argument1 = accumulator->Value; accumulator->Value = floor( argument1 ); break; case CEIL: argument1 = accumulator->Value; accumulator->Value = ceil( argument1 ); break; case FABS: argument1 = accumulator->Value; accumulator->Value = fabs( argument1 ); break; case EXP: argument1 = accumulator->Value; accumulator->Value = exp( argument1 ); break; case LOG: argument1 = accumulator->Value; if (argument1>0.0) { accumulator->Value = log( argument1 ); } else errval=NumDomainError; break; case LOG10: argument1 = accumulator->Value; if (argument1>0.0) { accumulator->Value = log10( argument1 ); } else errval=NumDomainError; break; case POW: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; if ( argument2 == 0.0 ) { // argument1 is 0 -> result is defined as 1.0 accumulator->Value = 1.0; } else { if ( argument1 > 0.0 ) { // positive argument1 -> solutions for all argument2 if ( argument2 > 0.0 ) { accumulator->Value = pow( argument1 , argument2 ); } else { accumulator->Value = 1.0/pow( argument1 , -argument2 ); } } else { // argument1 is negative or zero if ( argument1 == 0.0 ) { // argument1 is zero if ( argument2 > 0.0 ) { accumulator->Value = 0.0; } else errval=NumDomainError; } else { // argument1 is negative if ( (floor(argument2+0.5)-argument2)==0.0 ) { // only solutions for integer values of argument2 if ( argument2 > 0.0 ) { accumulator->Value = pow( argument1 , argument2 ); } else { accumulator->Value = 1.0/pow( argument1 , -argument2 ); } } else errval=NumDomainError; } } } break; case SQRT: argument1 = accumulator->Value; if (argument1>=0.0) { accumulator->Value = sqrt( argument1 ); } else errval=NumDomainError; break; case ROUND: argument1 = accumulator->Value; accumulator->Value = floor( argument1 + 0.5 ); break; case GAMMA: argument1 = accumulator->Value; accumulator->Value = gamma( argument1 ); break; case FMIN: accumulator = numprog_down_accumulator( program ); if (!accumulator) { errval = NumNoAccumulator; goto dpprogram_step_error; } argument1 = accumulator->Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1Value; argument2 = accumulator->Next->Value; accumulator->Value = (argument1>argument2)?argument1:argument2; break; case DEGC2K: argument1 = accumulator->Value; accumulator->Value = argument1 + 273.15; break; case K2DEGC: argument1 = accumulator->Value; accumulator->Value = argument1 - 273.15; break; case DEGF2K: argument1 = accumulator->Value; accumulator->Value = (5.0/9.0) * (argument1 - 32.0) + 273.15; break; case K2DEGF: argument1 = accumulator->Value; accumulator->Value = ((argument1 - 273.15) * (9.0/5.0)) + 32.0; break; case DEGK2K: argument1 = accumulator->Value; accumulator->Value = argument1; break; case K2DEGK: argument1 = accumulator->Value; accumulator->Value = argument1; break; case DEGF2DEGC: argument1 = accumulator->Value; accumulator->Value = (5.0/9.0) * (argument1 - 32.0); break; case DEGC2DEGF: argument1 = accumulator->Value; accumulator->Value = (argument1 * (9.0/5.0)) + 32.0; break; default: errval = NumNoInstruction; goto dpprogram_step_error; } /* cmd */ if (perrval) *perrval=errval; return( 0 ); dpprogram_step_error: if (perrval) *perrval=errval; return( -1 ); } /* dpprogram_step */ /*--------------------------------------------------------------------------- NAME dpprogram_run --- Executes all instructions of the program SYNOPSIS int dpprogram_run ( NumProg * program, int * perrval ); DESCRPTION Executes all instructions starting with the first instruction of InstructionList and with the first accumulator of AccumulatorList. At entry, the pointer program->CurrentAccumulator is reset to NULL. The program is executed by subsequent calls to dpprogram_step. In case of success, program->CurrentAccumulator->Value points to the result. ERROR VALUES *perrval NumSuccess : success program errors : (in this case the returned value is -1) NumNoAccumulator : not enough accumulator cells available NumNoInstruction : unknown instruction calculation errors: NumDivByZero : division by zero NumDomainError : some of the input arguments are outside RETURN VALUE success: 0 in case of success or a calculation error (DivByZero, DomainError) error :-1 in case of a program error (NumNoAccumulator, NumNoInstruction) In case of return value 0 the calculations can be repeated with changed variable values, in case of return value -1 the program is corrupted and cannot be used. ---------------------------------------------------------------------------*/ PUBLIC int dpprogram_run ( NumProg * program, int * perrval ) { int status=-1; NumInstr * instruction; if (!program) { *perrval = NumProgramError; return( status ); } instruction = program->InstructionList; if (!instruction) { *perrval = NumNoInstruction; return( status ); } program->CurrentAccumulator = ( NumAccu * ) NULL; while ( instruction ) { status = dpprogram_step( program, instruction, perrval ); if ( *perrval ) return( status ); instruction = instruction->Next; } return( status ); } /* dpprogram_run */ /*--------------------------------------------------------------------------- NAME dpprogram_optimize --- contract instructions where possible SYNOPSIS NumInstr * dpprogram_optimize ( NumProg * program, NumInstr * firstinstruction, int * perrval ); DESCRIPTION The routine executes the input instruction list and uses program->CurrentAccumulator as first accumulator. The instruction list is executed either until the command PUSHADDR is given or until program->CurrentAccumulator->Number reaches the same number that it had at entry. If PUSHADDR is found, the values of all accumulators between first accumulator->Next and program->CurrentAccumulator are copied with PUSHVAL to program->CompiledList. In the second case, the values of all accumulators between first accumulator->Next and program->CurrentAccumulator are copied with PUSHVAL to program->CompiledList. If existing, the last instruction that would use or modify the value of the first accumulator is appended to program->CompiledList, because it cannot be executed immediately. The last copied instruction is returned. ERROR VALUES *perrval NumSuccess : success program errors : (in this case the returned value is NULL) NumNoAccumulator : not enough accumulator cells available NumNoInstruction : unknown instruction calculation errors (only, if no variables are involved): NumDivByZero : division by zero NumDomainError : some of the input arguments are outside RETURN VALUE pointer to the last used instruction or NULL if end of list is reached NULL, together with an error value, is also returned in case of a program error. ---------------------------------------------------------------------------*/ NumInstr * dpprogram_optimize ( NumProg * program, NumInstr * firstinstruction, int * perrval ) { NumInstr *instruction, *lastinstruction; NumAccu *accumulator, *firstaccumulator, *lastaccumulator; int accunum, firstaccunum, lastaccunum; if (!program) { *perrval = NumProgramError; return( (NumInstr *) NULL ); } if (!firstinstruction) { *perrval = NumNoInstruction; return( (NumInstr *) NULL ); } firstaccumulator = program->CurrentAccumulator; if ( firstaccumulator ) firstaccunum = firstaccumulator->Number; else firstaccunum = 0; instruction = firstinstruction; accumulator = firstaccumulator; accunum = firstaccunum; while ( ( instruction ) && ( instruction->Command != PUSHADDR ) && ( accunum+1-instruction->Nargs > firstaccunum ) ) { dpprogram_step( program, instruction, perrval ); if ( *perrval ) return( instruction ); accumulator = program->CurrentAccumulator; accunum = accumulator->Number; instruction = instruction->Next; } lastinstruction = instruction; lastaccumulator = accumulator; lastaccunum = accunum; /* copy (lastaccunum-firstaccunum) accumulator values starting at firstaccumulator->Next to lastaccumulator (inclusive) */ if ( firstaccumulator ) accumulator=firstaccumulator->Next; else accumulator = program->AccumulatorList; for (accunum=firstaccunum+1;accunum<=lastaccunum;accunum++) { /* write accumulator values with PUSHVAL into CompiledList */ if (numprog_append_instruction ( program, 1, PUSHVAL, 0, accumulator->Value, NULL, NULL ) ) return( (NumInstr *) NULL ); accumulator=accumulator->Next; } if ( lastinstruction ) { /* copy last instruction */ instruction=lastinstruction; if (numprog_append_instruction ( program, 1, instruction->Command, instruction->Nargs, instruction->Value, instruction->Address, NULL ) ) return( (NumInstr *) NULL ); } if ( lastinstruction ) { /* the last instruction was not executed */ if (lastinstruction->Nargs==0) { numprog_up_accumulator ( program, *(lastinstruction->Address) ); } else { for (accunum=lastaccunum;accunum>lastaccunum+1-lastinstruction->Nargs; accunum--) numprog_down_accumulator ( program ); } } return( lastinstruction ); } /* dpprogram_optimize */ /*--------------------------------------------------------------------------- NAME dpprogram_compile --- Optimizes the program SYNOPSIS int dpprogram_compile ( NumProg * program, int * perrval ); DESCRIPTION The program is optimized by calculating parts of the program that do not contain variables. ERROR VALUES *perrval NumSuccess : success program errors : (in this case the returned value is -1) NumNoAccumulator : not enough accumulator cells available NumNoInstruction : unknown instruction calculation errors: NumDivByZero : division by zero NumDomainError : some of the input arguments are outside RETURN VALUE success: 0 in case of success or a calculation error (DivByZero, DomainError) error :-1 in case of a program error (NumNoAccumulator, NumNoInstruction) In case of return value 0 the calculation has caused an error, e.g. DivByZero, DomainError. If the program is run it will also return a calculation error. In case of return value -1 the program is corrupted and cannot be used. ---------------------------------------------------------------------------*/ PUBLIC int dpprogram_compile ( NumProg * program, int * perrval ) { NumInstr * instruction; if (!program) { *perrval = NumProgramError; return( -1 ); } instruction = program->InstructionList; if (!instruction) { *perrval = NumNoInstruction; return( -1 ); } program->CurrentAccumulator = ( NumAccu * ) NULL; while ( instruction ) { instruction = dpprogram_optimize( program, instruction, perrval ); if ( *perrval ) return( instruction?0:-1 ); if (instruction ) instruction = instruction->Next; } /* Replace InstructionList by CompiledList */ if ( numprog_free_instruction_list ( program, 0 ) ) { *perrval = NumProgramError; return( -1 ); } program->InstructionList = program->CompiledList; program->CompiledList = ( NumInstr * ) NULL; return( 0 ); } /* dpprogram_compile */ /**************************************************************************** * Number Functions * ****************************************************************************/ # define EXPRESSION dpcondition void dpcondition( NumProg * program, const char **ps, int level, int * perrval); void dplogicsum( NumProg * program, const char **ps, int level, int * perrval); void dplogicproduct( NumProg * program, const char **ps, int level, int * perrval); void dpequality( NumProg * program, const char **ps, int level, int * perrval); void dpcomparison( NumProg * program, const char **ps, int level, int * perrval); void dpexpression( NumProg * program, const char **ps, int level, int *perrval); void dpterm( NumProg * program, const char **ps, int level, int *perrval); void dpfactor0( NumProg * program, const char **ps, int level, int *perrval); void dpfactor1( NumProg * program, const char **ps, int level, int *perrval); void dpfactor2( NumProg * program, const char **ps, int level, int *perrval); void dpconstant( NumProg * program, const char **ps, int *perrval); void dpvariable( NumProg * program, const char **ps, int *perrval); void dpfunction( NumProg * program, const char **ps, int level, int *perrval); long int lvexpression( const char **ps, int level, int *perrval); long int lvfactor( const char **ps, int level, int *perrval); long int lvterm( const char **ps, int level, int *perrval); int isfunction( const char * s ) /* A function name starts with a character and contains characters and numbers. It ends with a parenthesis '('. This function returns 1 if the string s starts with a function name */ { if (('0'<=*s) && (*s<'9')) return ( 0 ); /* no function */ while ( (('0'<=*s) && (*s<'9')) || (('a'<=*s) && (*s<'z')) || (('A'<=*s) && (*s<'Z')) ) s++; if (*s=='(') return ( 1 ); else return ( 0 ); } /* isfunction */ int isvariable( const char * s ) /* In an expression, a variable name is preceded by an underscore. This function returns 1 if the string s starts with a variable name */ { if ('_'!=*s) return ( 0 ); /* no variable */ return ( 1 ); } /* isvariable */ void print_spaces( FILE * out, int n ) { for (n=n;n>0;n--) fprintf(out," "); } /* print_spaces */ /*************************************************************************** * Double Constant Functions * ***************************************************************************/ int dpconstant_insert ( const char * Quantity, const char * Unit, const char * Key, double value, DPConstant ** pdpconstant ); int dpconstant_search ( const char * Key, DPConstant ** pdpconstant, int mode ); int dpconstant_free ( void ); int dpconstant_print ( FILE * out, int level, int verbose ); int dpconstant_init ( void ); /*--------------------------------------------------------------------------- NAME dpconstant_insert --- Define Value of Key SYNOPSIS int dpconstant_insert ( const char * Quantity, const char * Unit, const char * Key, double Value , DPConstant ** pdpconstant ) DESCRPTION Insert or update the constant Key with Value, return pointer to dpconstant. If 'Key' already exists, its 'Value', 'Quantity' and 'Unit' are updated, otherwise 'Key' is created. In case of success the pointer to the new dpconstant is returned, otherwise NULL. 'Quantity' and 'Unit' are optional strings. They are only used if NUMIO_debug is > 0. If 'Quantity' or 'Unit' is NULL the corresponding value is ignored. The key list is inversely lexicographically ordered, i.e. longer keys are preceeding shorter keys (nnn->nn->n->mmm->mm>m). RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_insert ( const char * Quantity, const char * Unit, const char * Key, double Value , DPConstant ** pdpconstant ) { DPConstant * newdpconstant, * next, * previous; int notfound = 1; if (pdpconstant) *pdpconstant = (DPConstant *) NULL; previous = (DPConstant *) NULL; next = DPConstantRoot; /* search insertion point (insertion before next) */ while ( ( next!=(DPConstant *) NULL ) && (notfound>0) ) { notfound = strcmp(next->Key,Key); if (notfound>0) {previous = next; next = next->Next;} } /* create new constant Key, if notfound */ if ( notfound ) { /* create new constant Key */ if (!(newdpconstant = (DPConstant*) malloc(sizeof(DPConstant)))) return(-1); newdpconstant->Key = num_newstr( Key ); if (!newdpconstant->Key) return(-1); newdpconstant->Quantity = (char *) NULL; newdpconstant->Unit = (char *) NULL; /* insert newdpconstant before next */ if (next) next->Previous = newdpconstant; newdpconstant->Next=next; newdpconstant->Previous=previous; if (previous) previous->Next=newdpconstant; else DPConstantRoot = newdpconstant; next = newdpconstant; } /* update Value */ next->Value = Value; /* update Quantity and Unit for debugging */ if (NUMIO_debug > 0) { if (next->Quantity) free( next->Quantity ); next->Quantity = num_newstr( Quantity ); /* Ignore error if newstr returns NULL, because Quantity can be NULL */ if (next->Unit) free( next->Unit ); next->Unit = num_newstr( Unit ); /* Ignore error if newstr returns NULL, because Unit can be NULL */ } if (pdpconstant) *pdpconstant = next; return(0); } /* dpconstant_insert */ /*--------------------------------------------------------------------------- NAME dpconstant_search --- search Key SYNOPSIS int dpconstant_search ( const char * Key, DPConstant ** pdpconstant ) DESCRPTION Search the Key. In case of success the pointer to dpconstant is returned, otherwise NULL. If mode==0, all characters of Key are compared, if mode==1, the comparison stops if a dpconstant is found where all characters match the first characters of Key. Key is searched from the beginning of the list which is inversely lexicographically ordered. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_search ( const char * Key, DPConstant ** pdpconstant, int mode ) { DPConstant * current; /* return NULL in case that Key was not found */ if (pdpconstant) *pdpconstant = (DPConstant *) NULL; /* search Key */ current = DPConstantRoot; if ( current!=(DPConstant *) NULL ) { if (mode==0) { while( ( current!=(DPConstant *) NULL ) && ( strcmp(current->Key,Key)!=0) ) { current = current->Next; } } else { while( ( current!=(DPConstant *) NULL ) && ( strncmp(current->Key,Key,strlen(current->Key))!=0) ) { current = current->Next; } } } if (pdpconstant) *pdpconstant = current; if (current==(DPConstant *) NULL) return(-1); if (NUMIO_debug > 0) { if (current->Unit) { if (current->Quantity) { printf(" %s = %.15g %s (%s)\n", current->Key,current->Value,current->Unit,current->Quantity); } else { printf(" %s = %.15g %s\n",current->Key,current->Value,current->Unit); } } else { if (current->Quantity) { printf(" %s = %.15g (%s)\n", current->Key,current->Value,current->Quantity); } else { printf(" %s = %.15g\n",current->Key,current->Value); } } } return(0); } /* dpconstant_search */ /*+++------------------------------------------------------------------------ NAME dpconstant_free --- free list of constants SYNOPSIS int dpconstant_free( void ) DESCRIPTION Releases all Keys RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_free( void ) { DPConstant * current, * next; next = DPConstantRoot; while(next!=(DPConstant*) NULL) { current = next; next=next->Next; if (current->Quantity) free(current->Quantity); if (current->Unit) free(current->Unit); free(current->Key); free(current); } DPConstantRoot = (DPConstant *) NULL; return(0); } /* dpconstant_free */ /*+++------------------------------------------------------------------------ NAME dpconstant_print --- print all constants SYNOPSIS int dpconstant_print( FILE * out, int level, int verbose ) DESCRIPTION Prints all constants to the file ´out´ RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_print( FILE * out, int level, int verbose ) { const char * SeparationLine = "- - - - - - - -"; DPConstant * current; if (level<1) return(0); current = DPConstantRoot; while (current!=(DPConstant*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Key = %s\n",current->Key); fprintf(out," Value = %lg\n",current->Value); if (current->Quantity) fprintf(out," Quantity = %s\n",current->Quantity); if (current->Unit) fprintf(out," Unit = %s\n",current->Unit); fprintf(out," Previous Key = "); if ((current->Previous)!=(DPConstant*) NULL) fprintf(out,"%s\n", current->Previous->Key); else fprintf(out,"(no previous dpconstant)\n"); fprintf(out," Next Key = "); if ((current->Next)!=(DPConstant*) NULL) fprintf(out,"%s\n", current->Next->Key); else fprintf(out,"(no next dpconstant)\n"); } else { if (current->Quantity) if (current->Unit) fprintf(out," '%s' = %lg %s (%s)\n", current->Key,current->Value,current->Unit, current->Quantity); else fprintf(out," '%s' = %lg (%s)\n", current->Key,current->Value,current->Quantity); else if (current->Unit) fprintf(out," '%s' = %lg %s\n", current->Key,current->Value,current->Unit); else fprintf(out," '%s' = %lg\n",current->Key,current->Value); } current=current->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* dpconstant_print */ /*--------------------------------------------------------------------------- NAME dpconstant_insert_unit --- Insert full range of unit from atto to Exa SYNOPSIS int dpconstant_insert_unit ( const char * Quantity, const char * Unit, const char * Baseunit, double Basevalue ); DESCRPTION Baseunit preceeded by prefixes from atto to Exa is inserted into the list. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_insert_unit ( const char * Quantity, const char * Unit, const char * Baseunit, double Basevalue ) { char unit[128]; DPConstant * element; if (strlen(Baseunit)>64) return(-1); /* Yotta */ if ( sprintf( unit, "Y%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Yotta*Basevalue, &element )) return(-1); /* Zetta */ if ( sprintf( unit, "Z%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Zetta*Basevalue, &element )) return(-1); /* Exa */ if ( sprintf( unit, "E%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Exa*Basevalue, &element )) return(-1); /* Peta */ if ( sprintf( unit, "P%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Peta*Basevalue, &element )) return(-1); /* Tera */ if ( sprintf( unit, "T%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Tera*Basevalue, &element )) return(-1); /* Giga */ if ( sprintf( unit, "G%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Giga*Basevalue, &element )) return(-1); /* Mega */ if ( sprintf( unit, "M%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Mega*Basevalue, &element )) return(-1); /* Kilo */ if ( sprintf( unit, "k%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Kilo*Basevalue, &element )) return(-1); /* Hekto */ if ( sprintf( unit, "h%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Hekto*Basevalue, &element )) return(-1); /* Base unit */ if (dpconstant_insert ( Quantity, Unit, Baseunit, Basevalue, &element )) return(-1); /* deci */ if ( sprintf( unit, "d%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, deci*Basevalue, &element )) return(-1); /* centi */ if ( sprintf( unit, "c%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, centi*Basevalue, &element )) return(-1); /* milli */ if ( sprintf( unit, "m%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, milli*Basevalue, &element )) return(-1); /* micro */ if ( sprintf( unit, "u%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, micro*Basevalue, &element )) return(-1); /* nano */ if ( sprintf( unit, "n%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, nano*Basevalue, &element )) return(-1); /* pico */ if ( sprintf( unit, "p%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, pico*Basevalue, &element )) return(-1); /* femto */ if ( sprintf( unit, "f%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, femto*Basevalue, &element )) return(-1); /* atto */ if ( sprintf( unit, "a%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, atto*Basevalue, &element )) return(-1); /* zepto */ if ( sprintf( unit, "z%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, zepto*Basevalue, &element )) return(-1); /* yocto */ if ( sprintf( unit, "y%s", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, yocto*Basevalue, &element )) return(-1); return(0); } /* dpconstant_insert_unit */ /*--------------------------------------------------------------------------- NAME dpconstant_insert_unit2 --- Insert full range of unit for square SYNOPSIS int dpconstant_insert_unit2 ( const char * Quantity, const char * Unit, const char * Baseunit, double Basevalue ); DESCRPTION The square of the Baseunit preceeded by prefixes from atto to Exa and followed by 2 is inserted into the list, e.g. km2 = Kilo*Kilo*m*m Baseunit and Basevalue are not squared! Unit is the unit symbol of Quantity, e.g. Unit="m^2", Quantity="area" RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_insert_unit2 ( const char * Quantity, const char * Unit, const char * Baseunit, double Basevalue ) { double Basevalue2; char unit[128]; DPConstant * element; if (strlen(Baseunit)>63) return(-1); Basevalue2 = Basevalue*Basevalue; /* Yotta2 */ if ( sprintf( unit, "Y%s2",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Yotta2*Basevalue2, &element )) return(-1); /* Zetta2 */ if ( sprintf( unit, "Z%s2",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Zetta2*Basevalue2, &element )) return(-1); /* Exa2 */ if ( sprintf( unit, "E%s2",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Exa2*Basevalue2, &element )) return(-1); /* Peta2 */ if ( sprintf( unit, "P%s2",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Peta2*Basevalue2, &element )) return(-1); /* Tera2 */ if ( sprintf( unit, "T%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Tera2*Basevalue2, &element )) return(-1); /* Giga2 */ if ( sprintf( unit, "G%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Giga2*Basevalue2, &element )) return(-1); /* Mega2 */ if ( sprintf( unit, "M%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Mega2*Basevalue2, &element )) return(-1); /* Kilo2 */ if ( sprintf( unit, "k%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Kilo2*Basevalue2, &element )) return(-1); /* Hekto2 */ if ( sprintf( unit, "h%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Hekto2*Basevalue2, &element )) return(-1); /* Base unit ^2 */ if ( sprintf( unit, "%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Basevalue2, &element )) return(-1); /* deci2 */ if ( sprintf( unit, "d%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, deci2*Basevalue2, &element )) return(-1); /* centi2 */ if ( sprintf( unit, "c%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, centi2*Basevalue2, &element )) return(-1); /* milli2 */ if ( sprintf( unit, "m%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, milli2*Basevalue2, &element )) return(-1); /* micro2 */ if ( sprintf( unit, "u%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, micro2*Basevalue2, &element )) return(-1); /* nano2 */ if ( sprintf( unit, "n%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, nano2*Basevalue2, &element )) return(-1); /* pico2 */ if ( sprintf( unit, "p%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, pico2*Basevalue2, &element )) return(-1); /* femto2 */ if ( sprintf( unit, "f%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, femto2*Basevalue2, &element )) return(-1); /* atto2 */ if ( sprintf( unit, "a%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, atto2*Basevalue2, &element )) return(-1); /* yocto2 */ if ( sprintf( unit, "y%s2", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, yocto2*Basevalue2, &element )) return(-1); return(0); } /* dpconstant_insert_unit2 */ /*--------------------------------------------------------------------------- NAME dpconstant_insert_unit3 --- Insert full range of unit for unit^3 SYNOPSIS int dpconstant_insert_unit3 ( const char * Quantity, const char * Unit, const char * Baseunit, double Basevalue ); DESCRPTION The cube of the Baseunit preceeded by prefixes from atto to Exa and followed by 3 is inserted into the list, e.g. km2 = Kilo*Kilo*m*m Baseunit and Basevalue are the linear values, they are not cubed! Unit is the unit symbol of Quantity, e.g. Unit="m^3", Quantity="volume" RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_insert_unit3 ( const char * Quantity, const char * Unit, const char * Baseunit, double Basevalue ) { double Basevalue3; char unit[128]; DPConstant * element; if (strlen(Baseunit)>63) return(-1); Basevalue3 = Basevalue*Basevalue; /* Yotta3 */ if ( sprintf( unit, "Y%s3",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Yotta3*Basevalue3, &element )) return(-1); /* Zetta3 */ if ( sprintf( unit, "Z%s3",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Zetta3*Basevalue3, &element )) return(-1); /* Exa3 */ if ( sprintf( unit, "E%s3",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Exa3*Basevalue3, &element )) return(-1); /* Peta3 */ if ( sprintf( unit, "P%s3",Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Peta3*Basevalue3, &element )) return(-1); /* Tera3 */ if ( sprintf( unit, "T%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Tera3*Basevalue3, &element )) return(-1); /* Giga3 */ if ( sprintf( unit, "G%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Giga3*Basevalue3, &element )) return(-1); /* Mega3 */ if ( sprintf( unit, "M%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Mega3*Basevalue3, &element )) return(-1); /* Kilo3 */ if ( sprintf( unit, "k%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Kilo3*Basevalue3, &element )) return(-1); /* Hekto3 */ if ( sprintf( unit, "h%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Hekto3*Basevalue3, &element )) return(-1); /* Base unit ^3 */ if ( sprintf( unit, "%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, Basevalue3, &element )) return(-1); /* deci3 */ if ( sprintf( unit, "d%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, deci3*Basevalue3, &element )) return(-1); /* centi3 */ if ( sprintf( unit, "c%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, centi3*Basevalue3, &element )) return(-1); /* milli3 */ if ( sprintf( unit, "m%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, milli3*Basevalue3, &element )) return(-1); /* micro3 */ if ( sprintf( unit, "u%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, micro3*Basevalue3, &element )) return(-1); /* nano3 */ if ( sprintf( unit, "n%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, nano3*Basevalue3, &element )) return(-1); /* pico3 */ if ( sprintf( unit, "p%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, pico3*Basevalue3, &element )) return(-1); /* femto3 */ if ( sprintf( unit, "f%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, femto3*Basevalue3, &element )) return(-1); /* atto3 */ if ( sprintf( unit, "a%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, atto3*Basevalue3, &element )) return(-1); /* zepto3 */ if ( sprintf( unit, "z%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, zepto3*Basevalue3, &element )) return(-1); /* yocto3 */ if ( sprintf( unit, "y%s3", Baseunit) < 1 ) return(-1); if (dpconstant_insert ( Quantity, Unit, unit, yocto3*Basevalue3, &element )) return(-1); return(0); } /* dpconstant_insert_unit3 */ /*+++------------------------------------------------------------------------ NAME dpconstant_init --- Inits constants SYNOPSIS int dpconstant_init( void ) DESCRIPTION Inits the constants list RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int dpconstant_init ( void ) /* Physical and mathematical constants are taken from: [86] Lawrence Berkeley Laboratory University of California Berkeley, California 94720 X-Ray data booklet, second printing, with corrections, April 1986 Constants that are not contained in this edition are taken from [91] Kuchling, Taschenbuch der Physik, Verlag Harri Deutsch 1991 There are inconsistencies between in some definitions, e.g. amu, ga and p. 86+ and 91+ means that the values were calculated from values in [86] or [91]. If possible, all physical constants replaced by values from [2002] Peter J. Mohr and Barry N. Taylor, CODATA Recommended Values of the Fundamental Physical Constants: 2002 taken from http://physics.nist.gov/constants All units are preferably taken from [2004] PTB Die gesetzlichen Einheiten in Deutschland (download from http://www.ptb.de/ 20/0104) Inconsistency for amu_ in 2002 and 2004 */ { const double pi = 3.1415926535897932384626; /* pi number 86 */ const double gamma = 0.577215664901532861; /* gamma number 86 */ const double e = 2.718281828459045235; /* Euler number 86 */ const double rad_ = 1.0; /* angle (rad) */ const double deg_ = pi/180.0; /* angle (rad) */ const double gon_ = pi/200.0; /* angle (rad) */ const double arcmin_ = pi/180.0/60.0; /* angle (rad) */ const double arcsec_ = pi/180.0/3600.0; /* angle (rad) */ const double inf = DBL_MAX; /* "infinity" (workaround) */ // const double k = 1.380662e-23; /* Boltzmann constant (J/K) 86 */ const double k = 1.3806505e-23; /* Boltzmann constant (J/K) 2002 */ // const double me = 9.109534e-31; /* electron rest mass (kg) 86 */ const double me = 9.1093826e-31; /* electron rest mass (kg) 2002 */ // const double mp = 1.6726485e-27; /* proton rest mass (kg) 86 */ const double mp = 1.67262171e-27; /* proton rest mass (kg) 2002 */ // const double md = 3.3436369e-27; /* deuteron rest mass (kg) 86+ */ const double md = 3.34358335e-27; /* deuteron rest mass (kg) 2002 */ const double mn = 1.67492728e-27; /* neutron rest mass (kg) 2002 */ //const double NA = 6.022045e23; /* Avogadro number (1/mol) 86 */ // const double NA = 6.0221367e23; /* Avogadro number (1/mol) 91 */ const double NA = 6.0221415e23; /* Avogadro number (1/mol) 2002 */ // const double re = 2.8179380e-15; /* classical electron radius (m) 86 */ const double re = 2.817940325e-15; /* classical electron radius (m) 2002 */ const double c = 2.99792458e8; /* velocity of light (m/s) 2002 */ // const double ec = 1.6021892e-19; /* electron charge magnitude (C) 86 */ const double ec = 1.60217653e-19; /* elementary charge (C) 2002 */ // const double h = 6.626176e-34; /* Planck's number (J*s) 86 */ const double h = 6.6260693e-34; /* Planck constant (J*s) 2002 */ // const double gN = 6.6720e-11; /* gravitational constant (m3/kg/s2) 86 */ const double gN = 6.6742e-11; /* Newtonian constant of gravitation (m3/kg/s2) 2002 */ //const double ga = 9.8062; /* gravitational acceleration at sea // level at 45 deg latitude (m/s2) 86 */ const double ga = 9.80665; /* gravitational acceleration (m/s2) 2004 */ const double u0 = 4e-7*pi; /* permeability of vacuum (H/m) 86 */ const double e0 = 1.0/(u0*c*c); /* permittivity of vacuum (F/m) 86 */ const double m_ = 1.0; /* length (m) meter */ const double in_ = 2.54e-2; /* length (m) inch 86 2004 */ const double ft_ = 0.3048; /* length (m) foot 91 2004 */ const double yd_ = 0.9144; /* length (m) yard 91 2004 */ const double mile_ = 1609.344; /* length (m) mile 91 2004 */ const double sm_ = 1852; /* length (m) nautical mile 91 2004 */ const double barn_ = 1e-28; /* area (m2) barn 86 2004 */ const double a_ = 1e2; /* area (m2) Ar 91 2004 */ const double sec_ = 1.0; /* time (s) second */ const double min_ = 60.0*sec_; /* time (s) minute */ const double hr_ = 60.0*min_; /* time (s) hour */ const double d_ = 24.0*hr_; /* time (s) day */ const double Hz_ = 1.0; /* frequency (1/s) Herz */ const double kn_ = sm_/3600.0/sec_; /* speed (m/s) knots 91 2004 */ const double l_ = 1e-3; /* volume (m3) liter */ const double g_ = 1e-3; /* mass (kg) gram */ // const double amu_ = 1.6605402e-27; /* mass (kg) atomic mass unit 91 */ // const double amu_ = 1.6605655e-27; /* mass (kg) atomic mass unit 86 2004 */ const double amu_ = 1.66053886e-27; /* 0.00000028e-27 mass (kg) atomic mass constant 2002*/ const double lb_ = 0.45359237; /* mass (kg) pound 91 2004 */ // const double oz_ = 0.02834952; /* mass (kg) ounze 91 */ const double oz_ = 0.0283495; /* mass (kg) ounze (avoirdupois) 2004 */ const double J_ = 1.0; /* energy (J) Joule */ // const double cal_ = 4.184; /* energy (J) calorie 86 */ const double cal_ = 4.1868; /* energy (J) calorie 2004 */ const double erg_ = 1e-7; /* energy (J) erg 91 2004 */ const double W_ = 1.0; /* power (W) Watt */ const double K_ = 1.0; /* temperature (K) Kelvin */ const double degK_ = K_; const double degC_ = K_; const double degF_ = (5.0/9.0)*K_; const double N_ = 1.0; /* force (N) Newton */ const double p_ = 9.80665e-3; /* force (N) pond 91 2004 */ const double dyn_ = 1e-5; /* force (N) dyn 91 2004 */ //const double lbf_ = 4.44822; /* force (N) pound force 91 */ const double lbf_ = lb_*ga; /* force (N) pound force */ const double pdl_ = 0.138255; /* force (N) poundal 91 */ const double Pa_ = 1.0; /* pressure (Pa) Pascal */ const double bar_ = 1e5; /* pressure (Pa) bar 91 2004 */ const double Torr_ = 133.3224; /* pressure (Pa) Torr 91 2004 */ const double atm_ = 1.01325e5; /* pressure (Pa) physical atmosphere 2004 */ const double at_ = 0.980665e5; /* pressure (Pa) technical atmosphere 2004 */ // const double psi_ = 6894.76; /* pressure (Pa) lbf per square in 91 */ const double psi_ = lbf_/in_/in_; /* pressure (Pa) lbf per square in */ const double V_ = 1.0; /* voltage (V) Volt */ const double A_ = 1.0; /* electric current (A) Ampere */ const double C_ = 1.0; /* electric charge (C) Coulomb */ const double F_ = 1.0; /* electric capacity (F=A*s/V) Farad */ const double Ohm_ = 1.0; /* electric resistance (Ohm=V/A) */ const double S_ = 1.0; /* electric conductivity (S=A/V) Siemens */ const double T_ = 1.0; /* magnetic induction (T=V*s/m2) Tesla */ const double Wb_ = 1.0; /* magnetic flux (Wb=V*s) Weber */ const double H_ = 1.0; /* magnetic inductivity (H=V*s/A) Henry */ const double mol_ = 1.0; /* molecular amount */ const double Byte_ = 1.0; /* binary, B means Bel and cannot be used here */ DPConstant * element; /* --- mathematical constants and units */ /* Infinity */ if (dpconstant_insert ( "infinity", NULL, "inf", inf, &element )) return(-1); /* Gamma */ if (dpconstant_insert ( "gamma number", NULL, "gamma", gamma, &element )) return(-1); /* pi */ if (dpconstant_insert ( "pi number", NULL, "pi", pi, &element )) return(-1); /* e */ if (dpconstant_insert ( "Euler number", NULL, "e", e, &element )) return(-1); /* --- angle */ /* rad (rad)*/ if (dpconstant_insert ( "angle", "rad", "rad", rad_, &element )) return(-1); /* mrad (rad) */ if (dpconstant_insert ( "angle", "rad", "mrad", milli*rad_, &element )) return(-1); /* urad (rad) */ if (dpconstant_insert ( "angle", "rad", "urad", micro*rad_, &element )) return(-1); /* deg (rad)*/ if (dpconstant_insert ( "angle", "rad", "deg", deg_, &element )) return(-1); /* mdeg (rad) */ if (dpconstant_insert ( "angle", "rad", "mdeg", milli*deg_, &element )) return(-1); /* udeg (rad) */ if (dpconstant_insert ( "angle", "rad", "udeg", micro*deg_, &element )) return(-1); /* gon (rad)*/ if (dpconstant_insert ( "angle", "rad", "gon", gon_, &element )) return(-1); /* mgon (rad) */ if (dpconstant_insert ( "angle", "rad", "mgon", milli*gon_, &element )) return(-1); /* ugon (rad) */ if (dpconstant_insert ( "angle", "rad", "ugon", micro*gon_, &element )) return(-1); /* arcmin (rad)*/ if (dpconstant_insert ( "angle", "rad", "arcmin", arcmin_, &element )) return(-1); /* arcsec (rad)*/ if (dpconstant_insert ( "angle", "rad", "arcsec", arcsec_, &element )) return(-1); /* --- spherical angle (sr) */ if (dpconstant_insert ( "spherical angle", "sr", "sr", rad_*rad_, &element )) return(-1); /* --- physical constants and units */ /* k Boltzmann constant (J/K) */ if (dpconstant_insert ( "Boltzmann constant", "J/K", "k", k, &element )) return(-1); /* me electron rest mass (kg) */ if (dpconstant_insert ( "electron rest mass", "kg", "me", me, &element )) return(-1); /* mp proton rest mass (kg) */ if (dpconstant_insert ( "proton rest mass", "kg", "mp", mp, &element )) return(-1); /* mp deuteron rest mass (kg) */ if (dpconstant_insert ( "deuteron rest mass", "kg", "md", md, &element )) return(-1); /* mn neutron rest mass (kg) */ if (dpconstant_insert ( "neutron rest mass", "kg", "mn", mn, &element )) return(-1); /* NA Avogadro number (1/mol) */ if (dpconstant_insert ( "Avogadro number", "1/mol", "NA", NA, &element )) return(-1); /* re classical electron radius (m) */ if (dpconstant_insert ( "classical electron radius", "m", "re", re, &element )) return(-1); /* c velocity of light */ if (dpconstant_insert ( "velocity of light", "m/s", "c", c, &element )) return(-1); /* ec electron charge */ if (dpconstant_insert ( "electron charge", "C", "ec", ec, &element )) return(-1); /* h Planck's number (J*s) */ if (dpconstant_insert ( "Planck constant", "J*s", "h", h, &element )) return(-1); /* gN gravitational constant (m3/kg/s2) */ if (dpconstant_insert ( "gravitational constant", "m3/kg/s2", "gN", gN, &element )) return(-1); /* ga gravitational acceleration (m/s2) */ if (dpconstant_insert ( "gravitational acceleration", "m/s2", "ga", ga, &element )) return(-1); /* u0 permeability of vacuum = 4e-7*pi H/m */ if ( dpconstant_insert ( "permeability of vacuum", "H/m", "u0", u0, &element ) ) return(-1); /* e0 permittivity of vacuum = 1/u0/c2 (F/m) */ if ( dpconstant_insert ( "permittivity of vacuum", "F/m", "e0", e0, &element ) ) return(-1); /* Charge Coulomb (C) */ if ( dpconstant_insert_unit ( "electric charge", "C", "C", C_ ) ) return(-1); /* Voltage Volt (V) */ if ( dpconstant_insert_unit ( "voltage", "V", "V", V_ ) ) return(-1); /* Electric capacity Farad (F=As/V) */ if ( dpconstant_insert_unit ( "electric capacity", "F", "F", F_ ) ) return(-1); /* Resistance (Ohm=V/A) */ if ( dpconstant_insert_unit ( "electric resistance", "Ohm", "Ohm", Ohm_ ) ) return(-1); /* Conductivity Siemens (S=A/V) */ if ( dpconstant_insert_unit ( "electric conductivity", "S", "S", S_ ) ) return(-1); /* Magnetic induction Tesla (T) */ if ( dpconstant_insert_unit ( "magnetic induction", "T", "T", T_ ) ) return(-1); if ( dpconstant_insert_unit ( "magnetic induction", "T", "G", 1e-4*T_ ) ) return(-1); /* Magnetic flux Weber (Wb=Vs) */ if ( dpconstant_insert_unit ( "magnetic flux", "Wb", "Wb", Wb_ ) ) return(-1); /* Magnetic inductivity Henry (H=Vs/A) */ if ( dpconstant_insert_unit ( "magnetic inductivity", "H", "H", H_ ) ) return(-1); /* Electric current Ampere (A) */ if ( dpconstant_insert_unit ( "electric current", "A", "A", A_ ) ) return(-1); /* Time (s) */ if ( dpconstant_insert_unit ( "time", "s", "s", sec_ ) ) return(-1); if ( dpconstant_insert ( "time", "s", "min", min_, &element ) ) return(-1); if ( dpconstant_insert ( "time", "s", "hr", hr_, &element ) ) return(-1); if ( dpconstant_insert ( "time", "s", "d", d_, &element ) ) return(-1); /* Time^2 (s^2) */ if ( dpconstant_insert_unit2 ( "time^2", "s2", "s", sec_ ) ) return(-1); /* Frequency (1/s) */ if ( dpconstant_insert_unit ( "frequency", "1/s", "Hz", Hz_ ) ) return(-1); /* Length (m) */ if ( dpconstant_insert_unit ( "length", "m", "m", m_ ) ) return(-1); if ( dpconstant_insert ( "length", "m", "in", in_, &element )) return(-1); if ( dpconstant_insert ( "length", "m", "ft", ft_, &element )) return(-1); if ( dpconstant_insert ( "length", "m", "yd", yd_, &element )) return(-1); if ( dpconstant_insert ( "length", "m", "mile", mile_, &element )) return(-1); if ( dpconstant_insert ( "length", "m", "sm", sm_, &element )) return(-1); /* Speed (m/s) */ if ( dpconstant_insert ( "speed", "m/s", "kn", kn_, &element )) return(-1); /* Area (m^2) */ if ( dpconstant_insert_unit2 ( "area", "m2", "m", m_ ) ) return(-1); if ( dpconstant_insert ( "area", "m2", "b", barn_, &element )) return(-1); if ( dpconstant_insert ( "area", "m2", "a", a_, &element )) return(-1); if ( dpconstant_insert ( "area", "m2", "ha", Hekto*a_, &element )) return(-1); /* Volume (m^3) */ if ( dpconstant_insert_unit3 ( "volume", "m3", "m", m_ ) ) return(-1); if ( dpconstant_insert_unit ( "volume", "m3", "l", l_ ) ) return(-1); /* Mass (kg) */ if ( dpconstant_insert_unit ( "mass", "kg", "g", g_ ) ) return(-1); if ( dpconstant_insert ( "mass", "kg", "lb", lb_, &element ) ) return(-1); if ( dpconstant_insert ( "mass", "kg", "oz", oz_, &element ) ) return(-1); /* amu atomic mass unit (kg) */ if (dpconstant_insert ( "mass", "kg", "amu", amu_, &element )) return(-1); /* Molecular amount (mol) */ if ( dpconstant_insert_unit ( "molecular amount", "mol", "mol", mol_ ) ) return(-1); /* Energy Joule (J) */ if ( dpconstant_insert_unit ( "energy", "J", "J", J_ ) ) return(-1); if ( dpconstant_insert_unit ( "energy", "J", "eV", ec*V_ ) ) return(-1); if ( dpconstant_insert_unit ( "energy", "J", "cal", cal_ ) ) return(-1); if ( dpconstant_insert ( "energy", "J", "erg", erg_, &element ) ) return(-1); /* Temperature Kelvin (K) */ if ( dpconstant_insert ( "temperature", "K", "K", K_, &element ) ) return(-1); if ( dpconstant_insert ( "temperature", "K", "mK", milli*K_, &element ) ) return(-1); if ( dpconstant_insert ( "temperature", "K", "uK", micro*K_, &element ) ) return(-1); /* Temperature degrees Kelvin, Celsius, Fahrenheit (K) */ if ( dpconstant_insert ( "temperature", "K", "degK", degK_, &element ) ) return(-1); if ( dpconstant_insert ( "temperature", "K", "degC", degC_, &element ) ) return(-1); if ( dpconstant_insert ( "temperature", "K", "degF", degF_, &element ) ) return(-1); /* Power Watt (W) */ if ( dpconstant_insert_unit ( "power", "W", "W", W_ ) ) return(-1); /* Force Newton (N) */ if ( dpconstant_insert_unit ( "force", "N", "N", N_ ) ) return(-1); /* if ( dpconstant_insert_unit ( "force", "N", "p", p_ ) ) return(-1); */ if ( dpconstant_insert ( "force", "N", "p", p_, &element ) ) return(-1); if ( dpconstant_insert ( "force", "N", "lbf", lbf_, &element ) ) return(-1); if ( dpconstant_insert ( "force", "N", "pdl", pdl_, &element ) ) return(-1); if ( dpconstant_insert ( "force", "N", "dyn", dyn_, &element ) ) return(-1); /* Pressure Pascal (Pa) */ if ( dpconstant_insert_unit ( "pressure", "Pa", "Pa", Pa_ ) ) return(-1); if ( dpconstant_insert_unit ( "pressure", "Pa", "bar", bar_ ) ) return(-1); if ( dpconstant_insert ( "physical atmospheric pressure", "Pa", "atm", atm_, &element ) ) return(-1); if ( dpconstant_insert ( "technical atmospheric pressure", "Pa", "at", at_, &element ) ) return(-1); if ( dpconstant_insert ( "pressure", "Pa", "psi", psi_, &element ) ) return(-1); if ( dpconstant_insert ( "pressure", "Pa", "Torr", Torr_, &element ) ) return(-1); /* Binary constants (Byte) */ if ( dpconstant_insert ( "Byte", "Byte", "Byte", Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "KiloByte", "Byte", "kByte", Kilo*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "MegaByte", "Byte", "MByte", Mega*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "GigaByte", "Byte", "GByte", Giga*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "TeraByte", "Byte", "TByte", Tera*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "PetaByte", "Byte", "PByte", Peta*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "ExaByte", "Byte", "EByte", Exa*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "ZettaByte", "Byte", "ZByte", Zetta*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "YottaByte", "Byte", "YByte", Yotta*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "KibiByte", "Byte", "KiByte", pow(1024,1)*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "MebiByte", "Byte", "MiByte", pow(1024,2)*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "GibiByte", "Byte", "GiByte", pow(1024,3)*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "TebiByte", "Byte", "TiByte", pow(1024,4)*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "PebiByte", "Byte", "PiByte", pow(1024,5)*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "ExbiByte", "Byte", "EiByte", pow(1024,6)*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "ZebiByte", "Byte", "ZiByte", pow(1024,7)*Byte_, &element ) ) return(-1); if ( dpconstant_insert ( "YobiByte", "Byte", "YiByte", pow(1024,8)*Byte_, &element ) ) return(-1); DPConstantInit = 1; if ( NUMIO_debug > 1 ) dpconstant_print ( stdout, 1, 0 ); return( 0 ); } /* dpconstant_init */ /*************************************************************************** * Number Functions * ***************************************************************************/ void dpconstant( NumProg * program, const char **ps, int *perrval) { double value; DPConstant * constant; *perrval = NumSuccess; value = 1.0; if (!DPConstantInit) dpconstant_init(); if ( !dpconstant_search( *ps, &constant, 1 ) ) { value=constant->Value; *ps=*ps+strlen(constant->Key); if (numprog_append_instruction ( program, 0, PUSHVAL, 0, value, NULL, NULL)) { *perrval = NumProgramError; return; } } else { /* --- no float constant */ *perrval = NumNoFloatNumber; } return; } /* dpconstant */ void dpvariable( NumProg * program, const char **ps, int *perrval) { double *addr; NumVar *variable; *perrval = NumSuccess; if ( !numprog_search_variable ( program, *ps, &variable, 1 ) ) { addr=&(variable->Value); *ps=*ps+strlen(variable->Key); variable->Used++; if (numprog_append_instruction ( program, 0, PUSHADDR, 0, *addr, addr, NULL )) { *perrval = NumProgramError; return; } } else { /* --- undefined variable */ *perrval = NumNoVariable; } return; } /* dpvariable */ /*--------------------------------------------------------------------------- NAME dpfunction --- Append a function call to program. SYNOPSI void dpfunction( NumProg * program, const char **ps, int level, int *perrval); DESCRIPTION Append a function call to program. To add a new function FX the following steps needs to be done file numprog.h: Add FX to NumCommand and NumCommandStrings dpprogram_step: Add an entry of FX to dpprogram_step. All functions needs to be defined there. dpfunction: Add the string FX_ to dpfunction. It must be terminated with '(', e.g. const char *FX_="fx(". Append the instruction with numprog_append_instruction, as it is done for the other functions. NArgs must be exactly the number of arguments that are needed to calculate the function value. ----------------------------------------------------------------------------*/ void dpfunction( NumProg * program, const char **ps, int level, int *perrval) { const double pi = 3.1415926535897932384626; // const double degtorad = pi/180.0; // unused // const double radtodeg = 180.0/pi; // unused char * RAD_="rad("; char * DEG_="deg("; char * PI_ ="pi("; char * SIN_="sin("; char * COS_="cos("; char * TAN_="tan("; char * ASIN_="asin("; char * ACOS_="acos("; char * ATAN_="atan("; char * ATAN2_="atan2("; char * SINH_="sinh("; char * COSH_="cosh("; char * TANH_="tanh("; char * FLOOR_="floor("; char * CEIL_="ceil("; char * FABS_="abs("; char * EXP_="exp("; char * LOG_="log("; char * LOG10_="log10("; char * POW_="pow("; char * SQRT_="sqrt("; char * ROUND_="round("; char * GAMMA_="gamma("; char * FMIN_="min("; char * FMAX_="max("; char * DEGC2K_="degC2K("; char * K2DEGC_="K2degC("; char * DEGF2K_="degF2K("; char * K2DEGF_="K2degF("; char * DEGK2K_="degK2K("; char * K2DEGK_="K2degK("; char * DEGF2DEGC_="degF2degC("; char * DEGC2DEGF_="degC2degF("; *perrval = NumSuccess; /* rad-function */ if (!strncmp(*ps,RAD_,strlen(RAD_))) { *ps+=strlen(RAD_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, RAD, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* rad_ */ /* deg-function */ else if (!strncmp(*ps,DEG_,strlen(DEG_))) { *ps+=strlen(DEG_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, DEG, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* DEG_ */ /* pi-function */ else if (!strncmp(*ps,PI_,strlen(PI_))) { *ps+=strlen(PI_); if (numprog_append_instruction ( program, 0, PUSHVAL, 0, pi, NULL, NULL )) { *perrval = NumProgramError; return; } } /* PI_ */ /* sin-function */ else if (!strncmp(*ps,SIN_,strlen(SIN_))) { *ps+=strlen(SIN_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, SIN, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* SIN_ */ /* cos-function */ else if (!strncmp(*ps,COS_,strlen(COS_))) { *ps+=strlen(COS_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, COS, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* COS_ */ /* tan-function */ else if (!strncmp(*ps,TAN_,strlen(TAN_))) { *ps+=strlen(TAN_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, TAN, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* TAN_ */ /* asin-function */ else if (!strncmp(*ps,ASIN_,strlen(ASIN_))) { *ps+=strlen(ASIN_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, ASIN, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* ASIN_ */ /* acos-function */ else if (!strncmp(*ps,ACOS_,strlen(ACOS_))) { *ps+=strlen(ACOS_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, ACOS, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* ACOS_ */ /* atan-function */ else if (!strncmp(*ps,ATAN_,strlen(ATAN_))) { *ps+=strlen(ATAN_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, ATAN, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* ATAN_ */ /* atan2-function */ else if (!strncmp(*ps,ATAN2_,strlen(ATAN2_))) { *ps+=strlen(ATAN2_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if ((**ps)!=',') *perrval = NumCommaExpected; else (*ps)++; if (*perrval != NumSuccess) return; EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, ATAN2, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* ATAN2_ */ /* sinh-function */ else if (!strncmp(*ps,SINH_,strlen(SINH_))) { *ps+=strlen(SINH_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, SINH, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* SINH_ */ /* cosh-function */ else if (!strncmp(*ps,COSH_,strlen(COSH_))) { *ps+=strlen(COSH_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, COSH, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* COSH_ */ /* tanh-function */ else if (!strncmp(*ps,TANH_,strlen(TANH_))) { *ps+=strlen(TANH_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, TANH, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* TANH_ */ /* floor-function */ else if (!strncmp(*ps,FLOOR_,strlen(FLOOR_))) { *ps+=strlen(FLOOR_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, FLOOR, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* FLOOR_ */ /* ceil-function */ else if (!strncmp(*ps,CEIL_,strlen(CEIL_))) { *ps+=strlen(CEIL_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, CEIL, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* FLOOR_ */ /* fabs-function */ else if (!strncmp(*ps,FABS_,strlen(FABS_))) { *ps+=strlen(FABS_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, FABS, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* FABS_ */ /* exp-function */ else if (!strncmp(*ps,EXP_,strlen(EXP_))) { *ps+=strlen(EXP_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, EXP, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* EXP_ */ /* log-function */ else if (!strncmp(*ps,LOG_,strlen(LOG_))) { *ps+=strlen(LOG_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, LOG, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* LOG_ */ /* log10-function */ else if (!strncmp(*ps,LOG10_,strlen(LOG10_))) { *ps+=strlen(LOG10_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, LOG10, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* LOG10_ */ /* pow-function */ else if (!strncmp(*ps,POW_,strlen(POW_))) { *ps+=strlen(POW_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if ((**ps)!=',') *perrval = NumCommaExpected; else (*ps)++; if (*perrval != NumSuccess) return; EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, POW, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* POW_ */ /* sqrt-function */ else if (!strncmp(*ps,SQRT_,strlen(SQRT_))) { *ps+=strlen(SQRT_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, SQRT, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* SQRT_ */ /* round-function */ else if (!strncmp(*ps,ROUND_,strlen(ROUND_))) { *ps+=strlen(ROUND_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, ROUND, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* ROUND_ */ /* gamma-function */ else if (!strncmp(*ps,GAMMA_,strlen(GAMMA_))) { *ps+=strlen(GAMMA_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, GAMMA, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* GAMMA_ */ /* min-function */ else if (!strncmp(*ps,FMIN_,strlen(FMIN_))) { *ps+=strlen(FMIN_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if ((**ps)!=',') *perrval = NumCommaExpected; else (*ps)++; if (*perrval != NumSuccess) return; EXPRESSION(program,ps,level+1,perrval); if (numprog_append_instruction ( program, 0, FMIN, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* FMIN_ */ /* max-function */ else if (!strncmp(*ps,FMAX_,strlen(FMAX_))) { *ps+=strlen(FMAX_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if ((**ps)!=',') *perrval = NumCommaExpected; else (*ps)++; if (*perrval != NumSuccess) return; EXPRESSION(program,ps,level+1,perrval); if (numprog_append_instruction ( program, 0, FMAX, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* FMAX_ */ /* degC2K-function */ else if (!strncmp(*ps,DEGC2K_,strlen(DEGC2K_))) { *ps+=strlen(DEGC2K_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, DEGC2K, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* DEGC2K_ */ /* K2degC-function */ else if (!strncmp(*ps,K2DEGC_,strlen(K2DEGC_))) { *ps+=strlen(K2DEGC_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, K2DEGC, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* K2DEGC_ */ /* degF2K-function */ else if (!strncmp(*ps,DEGF2K_,strlen(DEGF2K_))) { *ps+=strlen(DEGF2K_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, DEGF2K, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* DEGF2K_ */ /* K2degF-function */ else if (!strncmp(*ps,K2DEGF_,strlen(K2DEGF_))) { *ps+=strlen(K2DEGF_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, K2DEGF, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* K2DEGF_ */ /* degK2K-function */ else if (!strncmp(*ps,DEGK2K_,strlen(DEGK2K_))) { *ps+=strlen(DEGK2K_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, DEGK2K, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* DEGK2K_ */ /* K2degK-function */ else if (!strncmp(*ps,K2DEGK_,strlen(K2DEGK_))) { *ps+=strlen(K2DEGK_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, K2DEGK, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* K2DEGK_ */ /* degF2degC-function */ else if (!strncmp(*ps,DEGF2DEGC_,strlen(DEGF2DEGC_))) { *ps+=strlen(DEGF2DEGC_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, DEGF2DEGC, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* DEGF2DEGC_ */ /* degC2degF-function */ else if (!strncmp(*ps,DEGC2DEGF_,strlen(DEGC2DEGF_))) { *ps+=strlen(DEGC2DEGF_); EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) return; if (numprog_append_instruction ( program, 0, DEGC2DEGF, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } /* DEGC2DEGF_ */ else { /* unknown function */ *perrval = NumNoFloatFunction; return; } if ((**ps)!=')') *perrval = NumBadParenthesis; else (*ps)++; return; } /* dpfunction */ void dpterm( NumProg * program, const char **ps, int level, int * perrval) { *perrval = NumSuccess; dpfactor0(program,ps,level,perrval); if (*perrval!=NumSuccess) return; while (**ps) { switch (**ps) { case '*' : (*ps)++; dpfactor0(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, MUL, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; case '/' : (*ps)++; dpfactor0(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, DIV, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; case '%' : (*ps)++; dpfactor0(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, REST, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default : return; } /* switch */ if (*perrval!=NumSuccess) return; } /* while */ return; } /* dpterm */ // Unary operator void dpfactor0( NumProg * program, const char **ps, int level, int * perrval) { *perrval = NumSuccess; switch (**ps) { case '!' : (*ps)++; dpfactor1(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, NOT, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default : dpfactor1(program,ps,level,perrval); } /* switch */ if (*perrval!=NumSuccess) return; return; } /* dpfactor0 */ // Unit multiplicator void dpfactor1( NumProg * program, const char **ps, int level, int * perrval) { *perrval = NumSuccess; dpfactor2(program,ps,level,perrval); if (*perrval!=NumSuccess) return; while (**ps) { switch (**ps) { case '_' : (*ps)++; dpfactor2(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, MUL, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default : return; } /* switch */ if (*perrval!=NumSuccess) return; } /* while */ return; } /* dpfactor1 */ // Values void dpfactor2( NumProg * program, const char **ps, int level, int * perrval) { char * DOUBLE_ = "(double)"; double value; char *pe; *perrval = NumSuccess; switch (**ps) { case '(' : /* --- (double) */ if (!strncmp(*ps,DOUBLE_,strlen(DOUBLE_))) { *ps=*ps+strlen(DOUBLE_); value = (double) lvfactor(ps,level,perrval); if (*perrval != NumSuccess) break; if (numprog_append_instruction ( program, 0, PUSHVAL, 0, value, NULL, NULL )) { *perrval = NumProgramError; return; } break;} /* --- expression */ (*ps)++; EXPRESSION(program,ps,level+1,perrval); if (*perrval != NumSuccess) break; if ((**ps)!=')') *perrval = NumBadParenthesis; else (*ps)++; break; default : /* --- number */ if ( (('0'<=**ps)&&(**ps<='9'))||('.'==**ps) ) { value = strtod(*ps,&pe); *ps = (const char *) pe; if (numprog_append_instruction ( program, 0, PUSHVAL, 0, value, NULL, NULL )) { *perrval = NumProgramError; return; } } /* number */ /* --- function */ else if (isfunction(*ps)) { dpfunction(program,ps,level,perrval); if (*perrval != NumSuccess) break; } /* function */ /* --- variable */ else if (isvariable(*ps)) { (*ps)++; /* skip underscore */ dpvariable(program,ps,perrval); if (*perrval != NumSuccess) break; } /* variable */ /* --- constant */ else { dpconstant(program,ps,perrval); if (*perrval != NumSuccess) break; } /* constant */ break; } /* switch */ if (*perrval!=NumSuccess) return; return; } /* dpfactor2 */ void dpexpression( NumProg * program, const char **ps, int level, int * perrval) { *perrval = NumSuccess; switch (**ps) { case '+': (*ps)++; dpterm(program,ps,level,perrval); break; case '-': (*ps)++; dpterm(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, NEG, 1, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default : dpterm(program,ps,level,perrval); break; } /* switch */ if (*perrval!=NumSuccess) return; while (**ps) { switch (**ps) { case '+': (*ps)++; dpterm(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, ADD, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; case '-': (*ps)++; dpterm(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, SUB, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; case ')': if (level<=0) *perrval = NumBadParenthesis; return; // case ';': // case ',': // return; default : return; // Return without error // if (isspace(**ps)) { //++++++++++++++++++ // return; // } // *perrval = NumScanError; break; } /* switch */ if (*perrval!=NumSuccess) return; } /* while */ return; } /* dpexpression */ // condition = logicsum ["?" logicsum ":" logicsum ] void dpcondition( NumProg * program, const char **ps, int level, int * perrval) { *perrval = NumSuccess; dplogicsum(program,ps,level,perrval); if (*perrval != NumSuccess) return; switch (**ps) { case '?': (*ps)++; dplogicsum(program,ps,level,perrval); if (*perrval != NumSuccess) return; switch (**ps) { case ':': (*ps)++; dplogicsum(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, IF, 3, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default: *perrval = NumScanError; } // switch default: ; // continue } // switch if (*perrval != NumSuccess) return; return; } // dpcondition // logicsum = logicproduct { || logicproduct } void dplogicsum( NumProg * program, const char **ps, int level, int * perrval) { const char *pps; *perrval = NumSuccess; dplogicproduct(program,ps,level,perrval); if (*perrval != NumSuccess) return; while (**ps) { pps = *ps; switch (*pps) { case '|': (pps)++; switch (*pps) { case '|': (pps)++; // "||" OR *ps = pps; dplogicproduct(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, OR, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default: return; } break; default: return; } // switch if (*perrval != NumSuccess) return; } // while return; } // dplogicsum // logicproduct = equality { && equality } void dplogicproduct( NumProg * program, const char **ps, int level, int * perrval) { const char *pps; *perrval = NumSuccess; dpequality(program,ps,level,perrval); if (*perrval != NumSuccess) return; while (**ps) { pps = *ps; switch (*pps) { case '&': (pps)++; switch (*pps) { case '&': (pps)++; // "&&" AND *ps = pps; dpequality(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, AND, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default: return; } break; default: return; } // switch if (*perrval != NumSuccess) return; } // while return; } // dplogicproduct // equality = comparison { "==" | "!=" comparison } void dpequality( NumProg * program, const char **ps, int level, int * perrval) { const char *pps; *perrval = NumSuccess; dpcomparison(program,ps,level,perrval); if (*perrval != NumSuccess) return; pps = *ps; switch (*pps) { case '=': (pps)++; switch (*pps) { case '=': (pps)++; // "==" EQ *ps = pps; dpcomparison(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, EQU, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default: ; // continue } break; case '!': (pps)++; switch (*pps) { case '=': (pps)++; // "==" NE *ps = pps; dpcomparison(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, NEQ, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default: ; // continue } default: ; // continue } // switch return; } // dpequality // comparison = expression { "<" | "<=" | ">" | ">=" expression } void dpcomparison( NumProg * program, const char **ps, int level, int * perrval) { const char *pps; *perrval = NumSuccess; dpexpression(program,ps,level,perrval); if (*perrval != NumSuccess) return; pps = *ps; switch (*pps) { case '<': (pps)++; switch (*pps) { case '=': (pps)++; // "<=" LE *ps = pps; dpexpression(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, LE, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default: // "<" LT *ps = pps; dpexpression(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, LT, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; } // switch break; case '>': (pps)++; switch (*pps) { case '=': (pps)++; // ">=" GE *ps = pps; dpexpression(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, GE, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; default: // ">" LT *ps = pps; dpexpression(program,ps,level,perrval); if (*perrval==NumSuccess) { if (numprog_append_instruction ( program, 0, GT, 2, 0, NULL, NULL )) { *perrval = NumProgramError; return; } } break; } // switch break; } // switch return; } // dpcomparison /*-------------------------------------------------------------------------- num_str2double : reads an expression of the type EXPRESSION = condition condition = logicsum ["?" logicsum ":" logicsum ] logicsum = logicproduct { "||" logicproduct } logicproduct = equality { "&&" equality } equality = comparison ["=="|"!=" comparison] comparison = expression ["<"|"<="|">"|">=" expression] expression = ["+"|"-"] term {"+"|"-" term} term = factor1 {"*"|"/"|"%" factor1} factor0 = ["!"] factor1 factor1 = factor2 {"_" factor2} factor2 = number | function | constant | "(" EXPRESSION ")" | "(double)" lvfactor | variable number = double precision type floating point number function = name "(" expression {"," expression} ")" name = "a"|..|"z" {"a"|..|"z"|"0"|..|"9"} constant = unit | name unit = name variable = "_" name The conversion stops at at the end of the string, a white space, a comma or a semicolon. If tail is not NULL the pointer to the remaining string, including the terminating character, is returned in *tail. If the evaluated expression is not complete or faulty, an error value is returned. A temporary program with the name 'str2double' is created. It is exectuted after successful creation. The resulting value is returned. The program is deleted after the run. return float value (o) : value of expression const char *str (i) : input string char **tail (o) : pointer to rest string if tail!=NULL int * perrval (o) : output status NumSuccess : successful conversion NumBadParenthesis : wrong number of parentheses NumNoFloatNumber : mysterious character found NumDomainError : etc. --------------------------------------------------------------------------*/ PUBLIC double num_str2double(const char *str, const char **tail, int *perrval) { int errval; double value=0.0; const char * ps=""; NumProg * program; if (str) ps = str; errval = NumSuccess; while (isspace(*ps)) ps++; // skip leading white space if ( !(program = numprog_new( "str2double" )) ) errval = NumProgramError; if (!errval) EXPRESSION( program, &ps, 0 , &errval); if (tail) *tail = ps; if (!errval) dpprogram_run ( program, &errval ); if (!errval) value = program->CurrentAccumulator->Value; if (errval>=NumProgramError) num_prog_print_list ( stderr, program, 2, 0 ); else if (NUMIO_debug>2) num_prog_print_list ( stdout, program, 2, 0 ); if (numprog_free( program )) errval = NumProgramError; if (perrval) *perrval=errval; return( value ); } /* num_str2double */ /*-------------------------------------------------------------------------- num_str2prog : Converts an expression with nvar variables to a program that can be exectuted with num_runprog. The syntax is like it is described for num_str2double. Constant expressions are evaluated. Exactly nvar variable names must be given. If not, random errors will occur. return NumProg * (o) : pointer to the program const char *name (i) : program name const char *str (i) : input string char **tail (o) : pointer to rest string if tail!=NULL int * perrval (o) : output status int nvar (i) : number of variables const char *nam1, ... (i) : names of the variables --------------------------------------------------------------------------*/ PUBLIC NumProg * num_str2prog( const char *name, const char *str, const char **tail, int *perrval, int nvar, ... ) { int errval; va_list ap; const char * vname; int n; const char * ps=""; NumProg * program; if (str) ps = str; errval = NumSuccess; while (isspace(*ps)) ps++; // skip leading white space if ( !(program = numprog_new( name )) ) errval = NumProgramError; if (!errval) { va_start(ap, nvar); for (n=0;n=NumProgramError) num_prog_print_list ( stderr, program, 2, 0 ); else if (NUMIO_debug>2) num_prog_print_list ( stdout, program, 2, 0 ); if (errval) { if (numprog_free( program )) errval = NumProgramError; program = (NumProg *) NULL; } if (perrval) *perrval = errval; return( program ); } /* num_str2prog */ /*-------------------------------------------------------------------------- num_chkvar : Returns, how often the n-th variable is used in program. It returns the Used-flag of the n-th variable. return int (o) : 0: does not depend on variable n 1: depends on variable n NumProg * (i) : program pointer created with num_str2prog4 int n (i) : variable number (according to num_str2prog) int * perrval (o) : output status --------------------------------------------------------------------------*/ PUBLIC int num_chkvar ( NumProg * program, int n, int *perrval ) { int errval; NumVar * variable = (NumVar *) NULL; int used = 0; int i; errval = NumSuccess; if (!program) errval=NumProgramError; if (!errval) { variable=program->VariableList; /* go to n-th variable */ for (i=1;iNext; else break; } if (variable) used = variable->Used; else errval=NumNoVariable; } if (perrval) *perrval=errval; return( used ); } /* num_chkvar */ /*-------------------------------------------------------------------------- num_runprog : Runs a program with nvar variables that was created with num_str2prog and returns the result. return double (o) : evaluated value NumProg * (i) : program pointer created with num_str2prog4 int * perrval (o) : output status double var1, ... (i) : variable values. They must be given in the same order as they have been defined with num_str2prog. Exactly the in num_str2prog defined number of variables values must be given. If not, random errors will occur. ATTENTION: The types of var1, ... are not known to the compiler, values are not casted automatically to double. --------------------------------------------------------------------------*/ PUBLIC double num_runprog( NumProg * program, int *perrval, ... ) { int errval; va_list ap; double var; NumVar * variable = (NumVar *) NULL; double value=0.0; errval = NumSuccess; if (!program) errval=NumProgramError; if (!errval) { variable = program->VariableList; va_start(ap, perrval); // perrval is the last argument before ... while (variable) { var = va_arg(ap, double); variable->Value = var; variable=variable->Next; } va_end(ap); } if (!errval) dpprogram_run ( program, &errval ); if (!errval) value = program->CurrentAccumulator->Value; if (errval>=NumProgramError) num_prog_print_list ( stderr, program, 2, 0 ); else if (NUMIO_debug>2) num_prog_print_list ( stdout, program, 2, 0 ); if (perrval) *perrval=errval; return( value ); } /* num_runprog */ /*-------------------------------------------------------------------------- num_searchprog: Returns the pointer of a program return NumProg * (o) : pointer to the program or null-pointer if it was not found const char * name (i) : program name int * perrval (o) : output status Attention: *perrval indicates errors only. It does not indicate whether the program was found. --------------------------------------------------------------------------*/ PUBLIC NumProg *num_searchprog ( const char *name, int *perrval ) { int errval; NumProg *program; errval = NumSuccess; if ( numprog_search ( name, &program ) ) errval=NumProgramError; if (perrval) *perrval=errval; return( program ); } /* num_searchprog */ /*-------------------------------------------------------------------------- num_rmprog : Removes the specified program or all defined programs, if the null-pointer is given return int (o) : 0: Success, -1: error NumProg * (i) : pointer to the program that should be remoed, or null-pointer to remove all programs int * perrval (o) : output status --------------------------------------------------------------------------*/ PUBLIC int num_rmprog( NumProg * program, int *perrval ) { int errval; int status; errval = NumSuccess; if ( (status = numprog_free( program )) ) errval = NumProgramError; if (perrval) *perrval=errval; return( status ); } /* num_rmprog */ long int lvterm( const char **ps, int level, int * perrval) { long int value; long int divisor; *perrval = NumSuccess; value = lvfactor(ps,level,perrval); if (*perrval!=NumSuccess) return ( value ); while (**ps) { switch (**ps) { case '*' : (*ps)++; value *= lvfactor(ps,level,perrval); break; case '/' : (*ps)++; divisor = lvfactor(ps,level,perrval); if ( divisor != 0l) value /= divisor; else *perrval=NumDivByZero; break; case '%' : (*ps)++; divisor = lvfactor(ps,level,perrval); if ( divisor != 0l) value %= divisor; else *perrval=NumDivByZero; break; default : return ( value ); } /* switch */ if (*perrval!=NumSuccess) return ( value ); } /* while */ return ( value ); } /* lvterm */ long int lvfactor( const char **ps, int level, int * perrval) { const double long_max = (double) LONG_MAX; const double long_min = (double) LONG_MIN; NumProg * program; double dpargument; char *pe; long int value; char * TRUE_ = "true"; char * FALSE_ = "false"; char * YES_ = "yes"; char * NO_ = "no"; char * LONG_ = "(long int)"; char * ROUND_ = "(round)"; *perrval = NumSuccess; value = 1l; switch (**ps) { case '(' : /* --- (long int) */ if (!strncmp(*ps,LONG_,strlen(LONG_))) { *ps=*ps+strlen(LONG_); /* Temporary program required to get dpfactor1 result */ if (!( program = numprog_new( "lvfactor" ) ) ) { *perrval = NumProgramError; break; } dpfactor1(program,ps,level,perrval); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpprogram_run ( program, perrval ); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpargument = program->CurrentAccumulator->Value; if (numprog_free( program )) { *perrval = NumProgramError; break; } if ((long_min <= dpargument) && (dpargument <= long_max)) value=(long int) dpargument; else *perrval = NumIntegerOverflow; break; } if (!strncmp(*ps,ROUND_,strlen(ROUND_))) { *ps=*ps+strlen(ROUND_); /* Temporary program required to get dpfactor1 result */ if (!( program = numprog_new( "lvfactor" ) ) ) { *perrval = NumProgramError; break; } dpfactor1(program,ps,level,perrval); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpprogram_run ( program, perrval ); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpargument = program->CurrentAccumulator->Value; if (numprog_free( program )) { *perrval = NumProgramError; break; } dpargument = floor(dpargument+0.5); if ((long_min <= dpargument) && (dpargument <= long_max)) value=(long int) dpargument; else *perrval = NumIntegerOverflow; break; } /* --- expression */ (*ps)++; value *= lvexpression(ps,level+1,perrval); if (*perrval != NumSuccess) break; if ((**ps)!=')') *perrval = NumBadParenthesis; else (*ps)++; break; default : /* --- number */ if (('0'<=**ps) && (**ps<='9')) { value=strtol(*ps,&pe,10); *ps = (const char *) pe; } /* --- function */ else if (isfunction(*ps)) { /* Temporary program required to get dpfunction result */ if (!( program = numprog_new( "lvfactor" ) ) ) { *perrval = NumProgramError; break; } dpfunction(program,ps,level,perrval); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpprogram_run ( program, perrval ); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpargument = program->CurrentAccumulator->Value; if (numprog_free( program )) { *perrval = NumProgramError; break; } dpargument = floor(dpargument+0.5); if ((long_min <= dpargument) && (dpargument <= long_max)) value=(long int) dpargument; else *perrval = NumIntegerOverflow; if (*perrval != NumSuccess) break; } /* function */ /* --- constant */ else if (!num_strncasecmp(*ps,TRUE_,strlen(TRUE_))) { value=1l; *ps=*ps+strlen(TRUE_);} else if (!num_strncasecmp(*ps,FALSE_,strlen(FALSE_))) { value=0l; *ps=*ps+strlen(FALSE_);} else if (!num_strncasecmp(*ps,YES_,strlen(YES_))) { value=1l; *ps=*ps+strlen(YES_);} else if (!num_strncasecmp(*ps,NO_,strlen(NO_))) { value=0l; *ps=*ps+strlen(NO_);} else { /* Temporary program required to get dpconstant result */ if (!( program = numprog_new( "lvfactor" ) ) ) { *perrval = NumProgramError; break; } dpconstant(program,ps,perrval); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpprogram_run ( program, perrval ); if (*perrval!=NumSuccess) { numprog_free( program ); break; } dpargument = program->CurrentAccumulator->Value; if (numprog_free( program )) { *perrval = NumProgramError; break; } dpargument = floor(dpargument+0.5); if ((long_min <= dpargument) && (dpargument <= long_max)) value=(long int) dpargument; else *perrval = NumIntegerOverflow; if (*perrval != NumSuccess) break; } /* --- exit */ break; } /* switch */ if (*perrval!=NumSuccess) return ( value ); return( value ); } /* lvfactor */ long int lvexpression( const char **ps, int level, int * perrval) { long int value; *perrval = NumSuccess; value = 0l; switch (**ps) { case '+': (*ps)++; value += lvterm(ps,level,perrval); break; case '-': (*ps)++; value -= lvterm(ps,level,perrval); break; default : value += lvterm(ps,level,perrval); break; } /* switch */ if (*perrval!=NumSuccess) return ( value ); while (**ps) { switch (**ps) { case '+': (*ps)++; value += lvterm(ps,level,perrval); break; case '-': (*ps)++; value -= lvterm(ps,level,perrval); break; case ')': if (level<=0) *perrval = NumBadParenthesis; return( value ); case ';': case ',': return( value ); default : if (isspace(**ps)) return( value ); *perrval = NumScanError; break; } /* switch */ if (*perrval!=NumSuccess) return ( value ); } /* while */ return(value); } /* lvexpression */ /*-------------------------------------------------------------------------- num_str2long : reads an expression of the type lvexpression = ["+"|"-"] lvterm {"+"|"-" lvterm} lvterm = lvfactor {"*"|"/" lvfactor} lvfactor = lvnumber | lvconstant |"(" lvexpression ")" | dpfunction | "(long int)" dpfactor | "(round)" dpfactor1 | dpconstant lvnumber = long integer type number lvconstant = "true" | "false" | "yes" | "no" dpfunction = see above dpfactor1 = see above The result of dpfunction is rounded to the closest long integer value. The conversion stops at at the end of the string, a white space, a comma or a semicolon. If tail is not NULL the pointer to the remaining string, including the terminating character, is returned in *tail. If the evaluated expression is not complete or faulty, an error value is returned. return long value (o) : value of expression const char *str (i) : input string char **tail (o) : pointer to rest string if tail!=NULL int * perrval (o) : output status NumSuccess : successful conversion NumBadParenthesis : wrong number of parentheses NumNoIntegerNumber : mysterious character found --------------------------------------------------------------------------*/ PUBLIC long num_str2long(const char *str, const char **tail, int *perrval) { int errval; long int value; const char * ps=""; if (str) ps = str; while (isspace(*ps)) ps++; // skip leading white space value = lvexpression( &ps, 0 , &errval); if (tail) *tail = ps; if (perrval) *perrval=errval; return( value ); } /* num_str2long */ /*-------------------------------------------------------------------------- num_long2str : writes a long value to buffer return char * (o) : pointer to buffer, char * NULL in case of an error unsigned long buflen (i) : buffer length (includes terminating NULL) long value (i) : value to write int * perrval (o) : 0 Success, otherwise error --------------------------------------------------------------------------*/ PUBLIC char *num_long2str( char buffer[], unsigned long buflen, long value, int * perrval ) { int errval; char tmp[128]; errval = NumWriteError; if ( sprintf(tmp,"%ld", value ) < 1 ) goto num_long2str_error; strncpy( buffer, tmp, buflen-1 ); buffer[buflen-1] = '\0'; errval = NumSuccess; if (perrval) *perrval=errval; return( buffer ); num_long2str_error: if (perrval) *perrval=errval; return( (char *) NULL ); } /* num_long2str */ /*-------------------------------------------------------------------------- num_long2hex : writes a long value hexadecimal to buffer return char * (o) : pointer to buffer, char * NULL in case of an error unsigned long buflen (i) : buffer length (includes terminating NULL) long value (i) : value to write int * perrval (o) : 0 Success, otherwise error --------------------------------------------------------------------------*/ PUBLIC char *num_long2hex( char buffer[], unsigned long buflen, long value, int * perrval ) { int errval; char tmp[128]; errval = NumWriteError; if ( sprintf(tmp,"0x%lx", value ) < 1 ) goto num_long2hex_error; strncpy( buffer, tmp, buflen-1 ); buffer[buflen-1] = '\0'; errval = NumSuccess; if (perrval) *perrval=errval; return( buffer ); num_long2hex_error: if (perrval) *perrval=errval; return( (char *) NULL ); } /* num_long2hex */ /*--------------------------------------------------------------------------- double2s( buffer, value, ndigits ) Conversion of double to string and output to buffer. The pointer to buffer is returned. In case of an error the null pointer is returned. The length of buffer must be 32 or larger. Only the absolute value of ndigits is used. ---------------------------------------------------------------------------*/ char * double2s( char buffer[], double value, int ndigits ) # define FORMAT_LEN 20 { char format[FORMAT_LEN]; if (ndigits<0) ndigits=-ndigits; if (ndigits>80) ndigits=80; if (ndigits==0) sprintf(format,"%%lg"); else sprintf(format,"%%.%dlg",ndigits); if ( sprintf(buffer,format,value)<1) return((char *) NULL); return(buffer); } /* double2s */ /*-------------------------------------------------------------------------- num_double2str : writes a float value with unit into buffer The input value must have a normalized form, e.g. it must be given in meters, rad, seconds or Joule. The value is expressed relative to uniti, i.e. if value is 1 and unit is "mm" the output string will be "1000_mm" = (1/mm)_mm. return char * (o) : pointer to buffer, char * NULL in case of an error unsigned long buflen (i) : buffer length (includes terminating NULL) double value (i) : value to write const char * unit (i) : unit to use or empty string or NULL int ndigits (i) : number of digits to write int * perrval (o) : 0 Success, otherwise error --------------------------------------------------------------------------*/ PUBLIC char *num_double2str( char buffer[], unsigned long buflen, double value, const char * unit, int ndigits, int * perrval ) { int errval; char tmp[128], *tmp_unit; double val, unit_val, tmp_unit_val; if ((unit) && (strlen(unit)>0)) { // get unit unit_val = num_str2double( unit, NULL, &errval ); if (errval) goto num_double2str_error; errval = NumDivByZero; if ( unit_val == 0.0 ) goto num_double2str_error; val = value/unit_val; // test unit (0 multiplied with unit) errval = NumMemoryAllocationError; tmp_unit = (char *) malloc( sizeof(char)*(strlen(unit)+3) ); if (!tmp_unit) goto num_double2str_error; sprintf(tmp_unit,"0_%s",unit); tmp_unit_val = num_str2double( tmp_unit, NULL, &errval ); free(tmp_unit); if (errval) goto num_double2str_error; // write val to tmp errval = NumWriteError; if ( !double2s( tmp, val, ndigits ) ) goto num_double2str_error; // copy tmp and unit to buffer errval = NumWriteError; if (tmp_unit_val == 0.0 ) { if ( buflen < ( strlen(tmp)+strlen(unit)+2 ) ) goto num_double2str_error; if ( sprintf(buffer,"%s_%s", tmp, unit ) < 2 ) goto num_double2str_error; } else { if ( buflen < ( strlen(tmp)+strlen(unit)+4 ) ) goto num_double2str_error; if ( sprintf(buffer,"%s_(%s)", tmp,unit ) < 2 ) goto num_double2str_error; } } else { // write value to tmp with ndigits errval = NumWriteError; if ( !double2s( tmp, value, ndigits ) ) goto num_double2str_error; // copy tmp to buffer strncpy( buffer, tmp, buflen-1 ); buffer[buflen-1] = '\0'; } errval = NumSuccess; if (perrval) *perrval=errval; return( buffer ); num_double2str_error: if (perrval) *perrval=errval; return( (char *) NULL ); } /* num_double2str */ /*-------------------------------------------------------------------------- num_double2hex : rounds a double value and writes it hexadecimal to buffer (without unit, without decimals) If ndigits is negative it is only used for negative values. return char * (o) : pointer to buffer, char * NULL in case of an error unsigned long buflen (i) : buffer length (includes terminating NULL) double value (i) : value to write int ndigits (i) : number of digits to write int * perrval (o) : 0 Success, otherwise error --------------------------------------------------------------------------*/ PUBLIC char *num_double2hex( char buffer[], unsigned long buflen, double value, int ndigits, int * perrval ) { int errval; char *ps; double nhex, hex, rest, m; double base=16.0; int sign; errval = NumWriteError; if (buflen<4) goto num_double2hex_error; // too short for "0x0\n" ps = &(buffer[0]); *ps='0';ps++; *ps='x';ps++; if (value<0.0) { // use complement rest = -(value+1.0); sign=-1; } else { rest = value; sign=+1.0; } if (rest>0.0) hex = pow(base,floor(log(rest)/log(base))); else hex = 1.0; if ((value<0.0)||(ndigits>0)) { if (fabs(ndigits)>1) nhex = pow(base,fabs(ndigits)-1.0); else nhex = 1.0; if (hex=1.0)&&(ps0) ) { switch (errval) { case NumSuccess : strncpy(buffer,"success",buflen-1); buffer[buflen-1]='\0'; break; case NumMemoryAllocationError : strncpy(buffer,"memory allocation failed",buflen-1); buffer[buflen-1]='\0'; break; case NumScanError : strncpy(buffer,"error scanning expression",buflen-1); buffer[buflen-1]='\0'; break; case NumCommaExpected : strncpy(buffer,"missing comma in expression",buflen-1); buffer[buflen-1]='\0'; break; case NumBadParenthesis : strncpy(buffer,"bad parenthesis in expression",buflen-1); buffer[buflen-1]='\0'; break; case NumNoFloatNumber : strncpy(buffer,"expression is not a float number",buflen-1); buffer[buflen-1]='\0'; break; case NumNoFloatFunction : strncpy(buffer,"unknown float function in expression",buflen-1); buffer[buflen-1]='\0'; break; case NumDomainError : strncpy(buffer,"domain error",buflen-1); buffer[buflen-1]='\0'; break; case NumNoIntegerNumber : strncpy(buffer,"expression is not an integer number",buflen-1); buffer[buflen-1]='\0'; break; case NumIntegerOverflow : strncpy(buffer,"integer overflow",buflen-1); buffer[buflen-1]='\0'; break; case NumDivByZero : strncpy(buffer,"division by zero",buflen-1); buffer[buflen-1]='\0'; break; case NumWriteError : strncpy(buffer,"error writing value",buflen-1); buffer[buflen-1]='\0'; break; case NumProgramError : strncpy(buffer,"error creating program",buflen-1); buffer[buflen-1]='\0'; break; case NumNoVariable : strncpy(buffer,"undefined variable",buflen-1); buffer[buflen-1]='\0'; break; case NumNoInstruction : strncpy(buffer,"unknown program instruction",buflen-1); buffer[buflen-1]='\0'; break; case NumNoAccumulator : strncpy(buffer,"not enough program registers",buflen-1); buffer[buflen-1]='\0'; break; default: strncpy(buffer,"unknown error value",buflen-1); buffer[buflen-1]='\0'; } // switch } else value=NULL; return( value ); } /* num_errval2str */ /*--------------------------------------------------------------------------- NAME num_strncasecmp --- strncasecmp SYNOPSIS int num_strncasecmp(const char *s1, const char *s2, size_t n); DESCRIPTION The function compares the first n characters ot the two strings s1 and s2, ignoring the case of the characters. It returns an integer less than, equal to, or greater than zero if s1 is less than, to matches, or is greater than s2. It can be used instead of the function strncasecmp if this function is not available. RETURN VALUE The function returns an integer less than, equal to, or greater than zero. ---------------------------------------------------------------------------*/ int num_strncasecmp(const char *s1, const char *s2, size_t n) { int value; size_t s1len, s2len; char *_s1, *_s2; register unsigned int i; s1len = strlen(s1); s1len = (s1len. */ # define ISOTIME_VERSION "isotime : V1.4 Peter Boesecke 2010-12-12" /*+++------------------------------------------------------------------------ NAME isotime --- routines for isotime conversion SYNOPSIS # include isotime.h HISTORY 2006-05-30 V1.0 Peter Boesecke 2006-06-05 V1.1 PB 2007-04-19 V1.2 PB code corrected to avoid compiler warnings with -Wall 2010-05-27 V1.3 PB trim: unsigned long -> long, otherwise the condition i>=0 in for loop would always be TRUE 2010-12-12 V1.4 PB _convert2epoch: all epoch value preset PUBLIC extern IsotimeEpoch isotime2epoch( const char * isotime_s ), const char * epoch2isotime( char buffer[], size_t buflen, IsotimeEpoch epoch ); LIMITATION earliest date: 1901-12-13T20:45:52.000000+0000 latest date: 2038-01-19T03:14:07.999999+0000 To extend this range the structure IsotimeEpoch needs to be extended. It would be possible to add the number of days since 1970-01-01. This would increase the time to +-~5e6 years. ----------------------------------------------------------------------------*/ /****************************************************************************** * Include Files * ******************************************************************************/ # include "isotime.h" /****************************************************************************** * Private Definitions * ******************************************************************************/ #ifndef MIN2 # define MIN2( x, y ) (( x ) > ( y ))?( y ):( x ) #endif /****************************************************************************** * Private Constants * ******************************************************************************/ # define TRIMLEN 64 // YYYYMMDDhhmmss.uuuuuu+HhMmSs # define EPOLEN EPOCHLEN // sssssss...sssssssss.uuuuuu # define ISOLEN ISOTIMELEN // sssssss...sssssssss.uuuuuu # define SLEN 64 // sssssss...ssssssssssssssss # define DLEN 9 // YYYYMMDD # define TLEN 7 // hhmmss # define FLEN 8 // .uuuuuu # define OLEN 8 // +HhMmSs # define DAYS_19700101 719528l /**************************************************************************** * Static Variables * ****************************************************************************/ static int ISOTIME_debug = 0; /*--------------------------------------------------------------------------*/ /* long leap_days: number of accumulated leap days until 1st day of the year*/ /*--------------------------------------------------------------------------*/ long leap_days ( long year ) { long ldays; year-=1; ldays = floor(year/4)-floor(year/100)+floor(year/400); return( ldays ); } // leap_days /*--------------------------------------------------------------------------*/ /* int leap_year: returns 1 for leap years, 0 otherwise */ /*--------------------------------------------------------------------------*/ int leap_year ( long year ) { int lyear; if (((!(year%4))&&(year%100))||(!(year%400))) lyear=1; else lyear=0; return ( lyear ); } // leap_year /*--------------------------------------------------------------------------*/ /* char *trim : copy to buffer, to uppercase and trim */ /*--------------------------------------------------------------------------*/ char *trim( char buffer[], size_t buflen, const char * s ) { const char *pstart, *pend, *ps; size_t slen=0; // unsigned long i; condition i>=0 in for loop would always be true long i; if ( s ) { pstart = s; while (isspace(*pstart)) pstart++; // skip leading white spaces for (i = strlen (s) -1; i>=0 && isspace(s[i]); i--); pend = &s[i+1]; // end position slen = pend-pstart; slen = MIN2(slen,buflen-1); ps = pstart; for ( i=0;i0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=4) goto cpderr; // skip separator if (!isdigit(*ps)) { if (*ps=='-') ps++; else goto cpderr; } // copy month (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) goto cpderr; // skip separator if (!isdigit(*ps)) { if (*ps=='-') ps++; else goto cpderr; } // copy day (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) goto cpderr; *pb='\0'; } return ( ps ); cpderr : buffer[0]='\0'; return( s ); } // cpd /*--------------------------------------------------------------------------*/ /* cpt: copy time from s to buffer, return pointer to next char in s */ /* In the case of an error the buffer contains an empty string and */ /* the pointer to the input string s is returned. */ /* The string s can start with 'T' or space or with a digit */ /*--------------------------------------------------------------------------*/ char * cpt( char buffer[], size_t buflen, char * s ) { char *ps, *pb; size_t cnt; long i; ps = s; pb = buffer; *pb='\0'; cnt = buflen-1; if ( s ) { // skip start character 'T' or white space if (!isdigit(*ps)) { if ((*ps=='T')||(*ps==' ')) ps++; else goto cpterr; } // copy hour (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) goto cpterr; // skip separator if (!isdigit(*ps)) { if (*ps==':') ps++; else goto cpterr; } // copy minute (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) goto cpterr; // skip separator if (!isdigit(*ps)) { if (*ps==':') ps++; else goto cpterr; } // copy second (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) goto cpterr; *pb='\0'; } return ( ps ); cpterr : buffer[0]='\0'; return( s ); } // cpt /*--------------------------------------------------------------------------*/ /* cpf: copy a fraction from s to buffer, return pointer to next char in s */ /* In the case of an error the buffer contains an empty string and */ /* the pointer to the input string s is returned. */ /* The string s must start with '.' or ','. */ /* The copying stops at the first non digit character */ /*--------------------------------------------------------------------------*/ char * cpf( char buffer[], size_t buflen, char * s ) { char *ps, *pb; size_t cnt; long i; ps = s; pb = buffer; *pb='\0'; cnt = buflen-1; if ( s ) { // check start character '.' or ',' if ((*ps!='.')&&(*ps!=',')) goto cpferr; // copy start character (1 character) if ( (*ps)&&(cnt>0) ) { *pb='.'; pb++;ps++;cnt--; } // copy fraction (undetermined length) for (i=0;(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } // skip the rest for (;(*ps);) { if (isdigit(*ps)) { ps++; } else break; } *pb='\0'; } return ( ps ); cpferr : buffer[0]='\0'; return( s ); } // cpf /*--------------------------------------------------------------------------*/ /* cps: copy integer part of seconds from s to buffer, return pointer to */ /* next char in s. */ /* In the case of an error the buffer contains an empty string and */ /* the pointer to the input string s is returned. */ /* The string s must start with '-', '+' or a digit. */ /* The copying stops at the first non digit character after the start. */ /*--------------------------------------------------------------------------*/ char * cps( char buffer[], size_t buflen, char * s ) { char *ps, *pb; size_t cnt; long i; ps = s; pb = buffer; *pb='\0'; cnt = buflen-1; if ( s ) { // check start character '-' or '+' if ((*ps!='-')&&(*ps!='+')&&(!isdigit(*ps))) goto cpserr; // copy start character (1 character) if ( (*ps)&&(cnt>0) ) { *pb=*ps; pb++;ps++;cnt--; } // copy seconds (undetermined length) for (i=0;(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } // check that all digits are read if (isdigit(*ps)&&(strlen(ps))) goto cpserr; *pb='\0'; } return ( ps ); cpserr : buffer[0]='\0'; return( s ); } // cps /*--------------------------------------------------------------------------*/ /* cpo: copy an offset from s to buffer, return pointer to next char in s */ /* In the case of an error the buffer contains an empty string and */ /* the pointer to the input string s is returned. */ /* The string s must start with '+' or '-'. */ /* The string can contain ':' as separator. */ /* The copying stops at the end of the line or after 7 copied digits. */ /*--------------------------------------------------------------------------*/ char * cpo( char buffer[], size_t buflen, char * s ) { char *ps, *pb; size_t cnt; long i; int stop=0; ps = s; pb = buffer; *pb='\0'; cnt = buflen-1; if ( s ) { // check start character '-' or '+' if ((*ps!='-')&&(*ps!='+')&&(*ps!='Z')) goto cpoerr; // copy start character (1 character) if ( (*ps)&&(cnt>0) ) { *pb=*ps; pb++;ps++;cnt--; } if (pb[-1]=='Z') { pb[-1]='+'; pb[0]='0'; pb++; // UTC } else { // copy hour (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) { if (i==1) stop=1; else goto cpoerr; } if (!stop) { // skip separator if (!isdigit(*ps)) { if (*ps==':') ps++; else stop=1; } if (isdigit(*ps)&&!stop) { // read only 2 character if *ps is a digit // copy minute (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) goto cpoerr; } } if (!stop) { // skip separator if (!isdigit(*ps)) { if (*ps==':') ps++; else stop=1; } if (isdigit(*ps)&&!stop) { // read only 2 character if *ps is a digit // copy second (2 digits) for (i=0;(i<2)&&(*ps)&&(cnt>0);i++) { if (isdigit(*ps)) { *pb=*ps; pb++;ps++;cnt--; } else break; } if (i!=2) goto cpoerr; } } } *pb='\0'; } return ( ps ); cpoerr : buffer[0]='\0'; return( s ); } // cpo /*--------------------------------------------------------------------------*/ /* _convert2epoch: Convert to IsotimeEpoch, */ /* returns epoch.status!=0 in case of an error */ /*--------------------------------------------------------------------------*/ IsotimeEpoch _convert2epoch(long year, long month, long day, long hh, long mm, long ss, double uuuuuu, long osign, long Hh, long Mm, long Ss) { long days, base; IsotimeEpoch epoch; if (ISOTIME_debug>0) fprintf(stderr,"_convert2epoch BEGIN\n"); epoch.offset = (long int) 0; epoch.fract = (double) 0.0; epoch.sec = (long int) 0; epoch.status = -1; days = year*365+leap_days(year) - DAYS_19700101; switch (month) { case 1: days+=day; break; case 2: days+=day+31; break; case 3: days+=day+59; break; case 4: days+=day+90; break; case 5: days+=day+120; break; case 6: days+=day+151; break; case 7: days+=day+181; break; case 8: days+=day+212; break; case 9: days+=day+243; break; case 10: days+=day+273; break; case 11: days+=day+304; break; case 12: days+=day+334; break; default : month=0; // invalid } if ( month ) { // correct march to december leap years if ( leap_year ( year ) ) { if (month>2) days+=1; } epoch.offset = osign*( (Hh*60+Mm)*60+Ss ); base = floor(uuuuuu); epoch.fract = uuuuuu - (double) base; epoch.sec = ((days*24+hh)*60+mm)*60+ss+base-epoch.offset; // normalize fract and sec base = floor(epoch.fract); epoch.fract -= (double) base; epoch.sec += base; epoch.status = 0; // success } if (ISOTIME_debug>2) fprintf(stderr," %ld (DAYS_%04ld%02ld%02ld) - %ld (DAYS_19700101) = %ld\n", days+DAYS_19700101,year,month,day,DAYS_19700101,days); if (ISOTIME_debug>0) fprintf(stderr,"_convert2epoch END\n"); return ( epoch ); } // _convert2epoch /*--------------------------------------------------------------------------*/ /* Scans isotime_s and converts it to epoch, .status!=0 in case of an error.*/ /* The input string must describe a full date and time in seconds. */ /* returns epoch, epoch.status!=0 in case of an error */ /*--------------------------------------------------------------------------*/ IsotimeEpoch _isotime2epoch(const char * isotime_s) { char osign_c; long osign; long year=0, month=0, day=0, hh=0, mm=0, ss=0; long Hh=0, Mm=0, Ss=0; double uuuuuu=0.0; char trimmed[TRIMLEN], *pd, *pt, *pf, *po, *pr; char datbuf[DLEN]; char timbuf[TLEN]; char frabuf[FLEN]; char offbuf[OLEN]; IsotimeEpoch epoch; if (ISOTIME_debug>0) fprintf(stderr,"_isotime2epoch >>%s<< BEGIN\n", isotime_s); // trim isotime_s, convert to uppercase and copy to trimmed pd = trim( trimmed, TRIMLEN, isotime_s ); if (ISOTIME_debug>1) fprintf(stderr," trim returns >>%s<<\n",pd); // copy date pt = cpd( datbuf, DLEN, pd ); if (ISOTIME_debug>1) fprintf(stderr," date >>%s<<\n",datbuf); // copy time pf = cpt( timbuf, TLEN, pt ); if (ISOTIME_debug>1) fprintf(stderr," time >>%s<<\n",timbuf); // copy fraction po = cpf( frabuf, FLEN, pf ); if (ISOTIME_debug>1) fprintf(stderr," fraction >>%s<<\n",frabuf); // copy offset pr = cpo( offbuf, OLEN, po ); if (ISOTIME_debug>1) fprintf(stderr," offset >>%s<<\n",offbuf); sscanf(datbuf,"%4ld%2ld%2ld",&year,&month,&day); sscanf(timbuf,"%2ld%2ld%2ld",&hh,&mm,&ss); sscanf(frabuf,"%lf",&uuuuuu); sscanf(offbuf,"%c%2ld%2ld%2ld",&osign_c,&Hh, &Mm, &Ss); if ( strlen(pr)||(day==0) ) month=0; // error, if rest is not empty or day 0 osign = (osign_c=='-')?-1:+1; epoch = _convert2epoch(year,month,day,hh,mm,ss,uuuuuu,osign,Hh,Mm,Ss); if ( epoch.status ) { fprintf( stderr, "ERROR: Cannot read time \"%s\"\n",trimmed ); fprintf( stderr, " Format: YYYY-MM-DDThh:mm:ss[.uuuuuu][+Hh:Mm]\n" ); } if (ISOTIME_debug>0) fprintf(stderr,"_isotime2epoch >>%s<< END\n", isotime_s); return( epoch ); } // _isotime2epoch /*--------------------------------------------------------------------------*/ /* Scans epoch string and converts it to epoch. The input string has the */ /* format [.]. */ /* Returns epoch, epoch.status!=0 in case of an error */ /*--------------------------------------------------------------------------*/ IsotimeEpoch _string2epoch(const char *string) { IsotimeEpoch epoch; char epobuf[EPOLEN], *pr; char secbuf[SLEN], *ps; char frabuf[SLEN], *pf; long sec=0; double fract=0.0; if (ISOTIME_debug>0) fprintf(stderr,"_string2epoch >>%s<<\n",string); epoch.status = -1; epoch.sec = 0; epoch.fract = 0.0; epoch.offset = 0; // trim isotime_s, convert to uppercase and copy to trimmed ps = trim( epobuf, EPOLEN, string ); if (ISOTIME_debug>1) fprintf(stderr," trim returns >>%s<<\n",ps); // copy seconds pf = cps( secbuf, SLEN, ps ); if (ISOTIME_debug>1) fprintf(stderr," section >>%s<<\n",secbuf); // copy fraction pr = cpf( frabuf, SLEN, pf ); if (ISOTIME_debug>1) fprintf(stderr," fraction >>%s<<\n",frabuf); if ( strlen(pr) ) { // error, if rest is not empty fprintf( stderr, "ERROR: Cannot read epoch \"%s\"\n",epobuf ); fprintf( stderr, " Format: [+|-]sssssssssss[.uuuuuuu]\n" ); fprintf( stderr, " e.g. \"1149254287\", \"+1149254287.1\"\n"); goto _string2epocherr; } sscanf(secbuf,"%ld",&sec); sscanf(frabuf,"%lf",&fract); epoch.sec = sec; epoch.fract = fract; epoch.status = 0; if (ISOTIME_debug>0) fprintf(stderr,"_string2epoch END\n"); return ( epoch ); _string2epocherr: if (ISOTIME_debug>0) fprintf(stderr,"_string2epoch END\n"); return ( epoch ); } // _string2epoch /*+++------------------------------------------------------------------------ NAME string2epoch --- Convert epoch string to epoch SYNOPSIS IsotimeEpoch string2epoch(const char *string); DESCRIPTION Scans epoch string and converts it to epoch. The input string has the format [.]. RETURN VALUE Returns epoch, epoch.status!=0 in case of an error ----------------------------------------------------------------------------*/ IsotimeEpoch string2epoch(const char *string) { return ( _string2epoch( string ) ); } // string2epoch /*+++------------------------------------------------------------------------ NAME addoffset2epoch --- Relative change of the time zone SYNOPSIS IsotimeEpoch addoffset2epoch( IsotimeEpoch epoch, const char * offset_s ); DESCRIPTION Changing the time zone relatively by incrementing the offset and decrementing epoch. RETURN VALUE updated epoch ----------------------------------------------------------------------------*/ IsotimeEpoch addoffset2epoch( IsotimeEpoch epoch, const char * offset_s ) { char osign_c; char trimmed[TRIMLEN], *po, *pr; char offbuf[OLEN]; long offset=0, Hh=0, Mm=0, Ss=0; if (ISOTIME_debug>0) fprintf(stderr,"addoffset2epoch >>%s<< BEGIN\n",offset_s); if ( epoch.status ) goto offerr; // trim offset_s, convert to uppercase and copy to trimmed po = trim( trimmed, TRIMLEN, offset_s ); if (ISOTIME_debug>1) fprintf(stderr," trim returns >>%s<<\n",po); // copy offset pr = cpo( offbuf, OLEN, po ); if (ISOTIME_debug>1) fprintf(stderr," offset >>%s<<\n",offbuf); if ( strlen(pr) ) { epoch.status=-1; fprintf( stderr, "ERROR: Cannot read offset \"%s\"\n",trimmed ); fprintf( stderr, " Format: +HhMm | -HhMm, e.g. \"+0200\"\n" ); goto offerr; } if ( !epoch.status ) { sscanf(offbuf,"%c%2ld%2ld%2ld",&osign_c,&Hh, &Mm, &Ss); offset = (Hh*60+Mm)*60+Ss; if (osign_c=='-') offset*=-1; epoch.offset += offset; epoch.sec -= offset; } if (ISOTIME_debug>0) fprintf(stderr,"addoffset2epoch END\n"); return ( epoch ); offerr: if (ISOTIME_debug>0) fprintf(stderr,"addoffset2epoch END\n"); return ( epoch ); } // addoffset2epoch /*+++------------------------------------------------------------------------ NAME setoffset2epoch --- Set time zone SYNOPSIS IsotimeEpoch setoffset2epoch( IsotimeEpoch epoch, const char * offset_s ); DESCRIPTION Setting the time zone offset. RETURN VALUE updated epoch ----------------------------------------------------------------------------*/ IsotimeEpoch setoffset2epoch( IsotimeEpoch epoch, const char * offset_s ) { char osign_c; char trimmed[TRIMLEN], *po, *pr; char offbuf[OLEN]; long offset=0, Hh=0, Mm=0, Ss=0; if (ISOTIME_debug>0) fprintf(stderr,"setoffset2epoch BEGIN\n"); if ( epoch.status ) goto offerr; // trim offset_s, convert to uppercase and copy to trimmed po = trim( trimmed, TRIMLEN, offset_s ); if (ISOTIME_debug>1) fprintf(stderr," trim returns >>%s<<\n",po); // copy offset pr = cpo( offbuf, OLEN, po ); if (ISOTIME_debug>1) fprintf(stderr," offset >>%s<<\n",offbuf); if ( strlen(pr) ) { epoch.status=-1; fprintf( stderr, "ERROR: Cannot read offset \"%s\"\n",trimmed ); fprintf( stderr, " Format: +HhMm | -HhMm, e.g. \"+0200\"\n" ); goto offerr; } if ( !epoch.status ) { sscanf(offbuf,"%c%2ld%2ld%2ld",&osign_c,&Hh, &Mm, &Ss); offset = (Hh*60+Mm)*60+Ss; if (osign_c=='-') offset *= -1; epoch.offset = offset; } if (ISOTIME_debug>0) fprintf(stderr,"setoffset2epoch END\n"); return ( epoch ); offerr: if (ISOTIME_debug>0) fprintf(stderr,"setoffset2epoch END\n"); return ( epoch ); } // setoffset2epoch /*+++------------------------------------------------------------------------ NAME isotime2epoch --- convert isotime string to IsotimeEpoch SYNOPSIS IsotimeEpoch isotime2epoch( const char * isotime_s ) DESCRIPTION Scans isotime_s and converts it to epoch, .status!=0 in case of an error. The input string must describe a full date and time in seconds. Supported input formats: 123456789A123456789B123456789C12345 YYYY-MM-DD hh:mm:ss.uuuuuu+Hh:Mm:Ss (space is not ISO standard, but used) YYYY-MM-DD hh:mm:ss.uuuuuu-Hh:Mm:Ss (space is not ISO standard, but used) YYYY-MM-DDThh:mm:ss.uuuuuu+Hh:Mm:Ss YYYY-MM-DDThh:mm:ss.uuuuuu-Hh:Mm:Ss YYYY-MM-DD hh:mm:ss.uuuuuu (space is not ISO standard, but used) YYYY-MM-DDThh:mm:ss.uuuuuu YYYY-MM-DD hh:mm:ss (space is not ISO standard, but used) YYYY-MM-DDThh:mm:ss short forms YYYYMMDDThhmmss.uuuuuu+HhMmSs YYYYMMDDhhmmss.uuuuuu+HhMmSs YYYYMMDDThhmmss+HhMmSs YYYYMMDDhhmmss+HhMmSs YYYYMMDDThhmmss.uuuuuu YYYYMMDDhhmmss.uuuuuu YYYYMMDDThhmmss YYYYMMDDhhmmss YYYYMMDD date (8 bytes) hhmmss time (6 bytes) .uuuuuu fraction (not limited) +HhMmSs offset (7 bytes) The UTC time offset (+00:00) can be abbreviated with Z RETURN VALUE .status==0 : success, the returned value contains epoch .status<0 : error ----------------------------------------------------------------------------*/ IsotimeEpoch isotime2epoch( const char * isotime_s ) { if (ISOTIME_debug>0) fprintf(stderr,"isotime2epoch\n"); return ( _isotime2epoch(isotime_s) ); } // isotime2epoch /*+++------------------------------------------------------------------------ NAME epoch2isotime --- convert IsotimeEpoch to isotime string SYNOPSIS const char * epoch2isotime( char buffer[], size_t buflen, IsotimeEpoch epoch ) DESCRIPTION (not implemented) RETURN VALUE pointer to isotime string in buffer ----------------------------------------------------------------------------*/ const char * epoch2isotime( char buffer[], size_t buflen, IsotimeEpoch epoch ) { char epobuf[EPOLEN]; char osign_c; long year=0, month=0, day=0; long hh=0, mm=0, ss=0; double fract=0.0; long Hh=0, Mm=0, Ss=0; long days, yd, ts, tz, leap; long base; if (ISOTIME_debug>0) fprintf(stderr,"epoch2isotime %s BEGIN\n", epoch2string( epobuf, EPOLEN, epoch ) ); if ( (!buffer)||(buflen0) fprintf(stderr,"epoch2isotime END\n"); return ( ( const char *) NULL ); } buffer[0] ='\0'; if (!epoch.status) { // normalize fract and sec base = floor(epoch.fract); epoch.fract -= (double) base; epoch.sec += base; // convert2time fract = epoch.fract; if (epoch.offset<0) osign_c='-'; else osign_c='+'; tz = epoch.offset; Hh = floor(tz/3600); tz -= Hh*3600; Mm = floor(tz/60); tz -= Mm*60; Ss = tz; Hh=labs(Hh); Mm=labs(Mm); Ss = labs(Ss); if (ISOTIME_debug>3) fprintf(stderr," osign=%c1, Hh=%ld, Mm=%ld, Ss=%ld\n",osign_c,Hh,Mm,Ss); ts = epoch.sec + epoch.offset; // add time zone offset days = floor( ts/3600/24 ); ts -= days*3600*24; if (ts<0) { days-=1; ts+=3600*24; } hh = floor(ts/3600); ts -= hh*3600; mm = floor(ts/60); ts -= mm*60; ss = ts; days += DAYS_19700101; // == year*365+leap_days year = floor( days/365 ); yd = days - year*365 - leap_days( year ); // day in the year if (ISOTIME_debug>3) fprintf(stderr," hh=%ld, hm=%ld, ss=%ld\n",hh,mm,ss); // days contains all leap_days => year is correct or too high while ( yd <= 0 ) { year--; yd = days - year*365 - leap_days( year ); // day in the year } if (ISOTIME_debug>3) fprintf(stderr," year=%ld, yd=%ld\n",year,yd); // get number of leap days in the year if ( leap_year ( year ) ) leap=1; else leap=0; if (yd<=31) { month= 1; day=yd; } // Jan else if (yd<=59+leap) { month= 2; day=yd-31; } // Feb else if (yd<=90+leap) { month= 3; day=yd-59-leap; } // Mar else if (yd<=120+leap) { month= 4; day=yd-90-leap; } // Apr else if (yd<=151+leap) { month= 5; day=yd-120-leap; } // May else if (yd<=181+leap) { month= 6; day=yd-151-leap; } // Jun else if (yd<=212+leap) { month= 7; day=yd-181-leap; } // Jul else if (yd<=243+leap) { month= 8; day=yd-212-leap; } // Aug else if (yd<=273+leap) { month= 9; day=yd-243-leap; } // Sep else if (yd<=304+leap) { month=10; day=yd-273-leap; } // Oct else if (yd<=334+leap) { month=11; day=yd-304-leap; } // Nov else { month=12; day=yd-334-leap; } // Dec // print sprintf( buffer, "%04ld-%02ld-%02ldT%02ld:%02ld:%02ld.%06ld%c%02ld%02ld", year,month,day,hh,mm,ss,(long) floor(epoch.fract*1e6+0.5), osign_c,labs(Hh),labs(Mm) ); } if (ISOTIME_debug>0) fprintf(stderr,"epoch2isotime %s END\n",buffer); return( buffer ); } // epoch2isotime /*+++------------------------------------------------------------------------ NAME epoch2string --- write epoch to string SYNOPSIS const char *epoch2string ( char buffer[], size_t buflen, IsotimeEpoch epoch ); DESCRIPTION RETURN VALUE pointer to output string in buffer ----------------------------------------------------------------------------*/ const char * epoch2string ( char buffer[], size_t buflen, IsotimeEpoch epoch ) { long base; if ( (!buffer)||(buflen. */ /*+++*********************************************************************** NAME angle.h SYNOPSIS #include "angle.h" DESCRIPTION Header of the module "angle.c" ***********************************************************************---*/ #ifndef _ANGLE_ # define ANGLE_VERSION "angle : V1.4 Peter Boesecke 2009-10-02" /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include # include # include "reference.h" # include "numio.h" # include "ipol.h" /*===========================================================================*/ /****************************************************************************** * Functions * ******************************************************************************/ PUBLIC extern float angle_limits( int mode, int I1Dim_1, int I1Dim_2, float Off_11, float Ps_11, float Off_21, float Ps_21, float Wcenter_1, float Wcenter_2 ); PUBLIC extern void angle_sum ( float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float Off_10, float Ps_10, float Off_20, float Ps_20, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float Off_11, float Ps_11, float Off_21, float Ps_21, float I1Dummy, float I1DDummy, float Wcenter_1, float Wcenter_2, int vsum, int ave, int testbit, int * pstatus ); # define _ANGLE_ #endif spd-1.3.0/edfpack/gauss.h0000644000175000017500000000525311633462462012126 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME gauss.h SYNOPSIS #include "gauss.h" DESCRIPTION Header of the module "gauss.c" ***********************************************************************---*/ #ifndef _GAUSS_ # define _GAUSS_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include # include /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern double Gauss ( double x, double sigma ), // gaussian normal distribution IntGauss ( double x, double sigma ), // integral of gaussian InvIntGauss ( double y, double sigma ), // inverse integral GaussNoise( double sigma ); // creates gaussian noise PUBLIC extern void GaussNoiseSeed( unsigned int seed ), // set random number seed GaussDebug( int mode ); // 0: no debug mode, 1: debug #endif spd-1.3.0/edfpack/raster.h0000755000175000017500000001313211633462461012301 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ #ifndef _RASTER_ # define _RASTER_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif #ifndef TRUE # define TRUE 1 # define FALSE 0 #endif # include # include # include /*************************************************************************** * Definitions * ***************************************************************************/ # define MAX_RASTER_NUMBER_DIMENSION_32 9 /* for 32 bit long int */ # define MAX_RASTER_NUMBER_DIMENSION_64 16 /* for 64 bit long int */ # define MAX_RASTER_NUMBER_DIMENSION MAX_RASTER_NUMBER_DIMENSION_32 /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern long raster_numbers ( long n ); PUBLIC extern int raster_normalization ( void * dest, const void * src, const long data_dim[], long raster_number, size_t item, int *perrval ); PUBLIC extern long raster_multiplication ( long a, long x ); PUBLIC extern long raster_inversion ( long x ); PUBLIC extern long raster_order2number ( const long order[] ); /* if buffer is NULL an output array with n+1 elements is allocated and needs to be released */ PUBLIC extern long * raster_number2order ( long * buffer, size_t nelem, long n, long raster_number ); PUBLIC extern int raster_order_normalization ( void * dest, const void * src, const long data_dim[], const long order[], size_t item, int *perrval); /* if buffer is NULL an output array with n+1 elements is allocated and needs to be released */ PUBLIC extern long * raster_order_multiplication (long *buffer, size_t nelem, const long a_order[] , const long x_order[]); /* if buffer is NULL an output array with n+1 elements is allocated and needs to be released */ PUBLIC extern long * raster_order_inversion ( long *buffer, size_t nelem, const long x_order[] ); PUBLIC extern long raster_order_determinante ( const long order[] ); /* if buffer is NULL a sufficiently large output string is allocated and needs to be released */ PUBLIC extern char * raster_order2str( char * buffer, size_t nelem, long order[], int *perrval ); /* if buffer is NULL an output array with n+1 elements is allocated and needs to be released */ PUBLIC extern long * raster_str2order( long * buffer, size_t nelem, long n, const char *str, const char **tail, int *perrval ); PUBLIC extern long raster_str2number( long n, const char *str, const char **tail, int *perrval ); /* if buffer is NULL an output array with order[0]*order[0] elements is allocated and needs to be released */ PUBLIC extern double * raster_order2matrix ( double * buffer, size_t nelem, const long order[] ); /* if buffer is NULL an output array with L*N elements is allocated and needs to be released */ PUBLIC extern double * raster_matrix_product ( double * buffer, size_t nelem, double A[], double B[], int L, int M, int N ); /* print matrix M[col][row] */ PUBLIC extern int raster_fprint_matrix( FILE *out, size_t nrows, size_t ncols, double M[], const char * label ); PUBLIC extern void raster_debug ( int debug ); PUBLIC extern const char *raster_version ( void ); #endif spd-1.3.0/edfpack/cmpr.c0000755000175000017500000005270611633462461011747 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*-------------------------------------------------------------------------- NAME cmpr.c --- de/compression functions DESCRIPTION zlib compression/decompression of binary data - GzipCompression - ZCompression AUTHOR 2010-12-19 Peter Boesecke HISTORY 2011-01-07 V1.1 PB no gzip compression possible for zlib version<1.2.4, zlib version checked and error message given, CMPR_DEF_MEM_LEVEL defined with respect to MAX_MEM_LEVEL, more debug added to cmpr_deflate and cmpr_inflate. 2011-01-20 V1.2 PB only info in case of an error for zlib version<1.2.4 --------------------------------------------------------------------------*/ # define CMPR_VERSION "cmpr : V1.2 Peter Boesecke 2011-01-20 -- zlib : " ZLIB_VERSION /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include # include "cmpr.h" /**************************************************************************** * PRIVATE part * ****************************************************************************/ #if MAX_MEM_LEVEL >= 8 # define CMPR_DEF_MEM_LEVEL 8 #else # define CMPR_DEF_MEM_LEVEL MAX_MEM_LEVEL #endif # define CHUNK 16384 /**************************************************************************** * Static Variables * ****************************************************************************/ static int CMPR_debug = 0; /*-------------------------------------------------------------------------- NAME cmpr_debug --- set / reset module cmpr into debug mode SYNOPSIS void cmpr_debug ( int debug ); DESCRPTION Writes ´debug´ into CMPR_debug. --------------------------------------------------------------------------*/ void cmpr_debug ( int debug ) { CMPR_debug = debug; } /* cmpr_debug */ /*-------------------------------------------------------------------------- NAME cmpr_deflate --- compress using zlib SYNOPSIS int cmpr_deflate ( void * out, size_t outlen, const void * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ); DESCRIPTION Compress a maximum of inplen bytes in steps of CHUNK bytes from inp to out using zlib deflate routine. The size of the output buffer is outlen. cmpr_deflate returns 0 on success and -1 on error. The *perrval returns more specific information: Z_OK on success, Z_MEM_ERROR if memory could not be allocated for processing, Z_DATA_ERROR if the deflate data is invalid or incomplete, Z_VERSION_ERROR if the version of zlib.h and the version of the library linked do not match, Z_ERRNO in case of an output error, e.g. if the output buffer is too short or the compression method is not defined. ARGUMENTS void * out pointer to output buffer size_t outlen length of output buffer in bytes const void * inp pointer to input buffer size_t inplen length of input buffer in bytes int cmpr_method compression method size_t * pconverted number of valid bytes in output buffer int * perrval zlib error value AUTHOR Peter Boesecke 2010-12-12 -----------------------------------------------------------------------------*/ int cmpr_deflate ( void * out, size_t outlen, const void * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ) { int errval, flush; z_stream strm; unsigned char *pinp; unsigned char *pout; size_t rest_inp=(size_t) 0, rest_out=(size_t) 0; size_t avail_inp=(size_t) 0, avail_out=(size_t) 0; size_t incr_inp=(size_t) 0, incr_out=(size_t) 0; size_t converted=(size_t) 0; if (CMPR_debug) printf("\n cmpr_deflate BEGIN\n"); if (!out) outlen=(size_t) 0; if (!inp) inplen=(size_t) 0; /* compress all input */ errval = Z_STREAM_END; if (inplen>0) { /* if there is something to compress */ /* Compresssion Levels: Z_NO_COMPRESSION Z_BEST_SPEED Z_BEST_COMPRESSION Z_DEFAULT_COMPRESSION */ /* allocate deflate state */ strm.zalloc = Z_NULL; strm.zfree = Z_NULL; strm.opaque = Z_NULL; strm.avail_in = 0; strm.next_in = Z_NULL; switch ( cmpr_method ) { case GzipCompression: /* initialize gzip compression */ if (CMPR_debug) { printf(" gzip: deflateInit2(strm,level,method,windowBits,memLevel,strategy)\n"); printf(" deflateInit2(...,%d,%d,%d,%d,%d)\n", Z_DEFAULT_COMPRESSION, Z_DEFLATED, (MAX_WBITS+16), CMPR_DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY); } errval = deflateInit2(&strm, Z_DEFAULT_COMPRESSION, \ Z_DEFLATED, (MAX_WBITS+16), \ CMPR_DEF_MEM_LEVEL, Z_DEFAULT_STRATEGY); // +16 for gzip if (errval != Z_OK) { #if !defined(ZLIB_VERNUM) || (ZLIB_VERNUM < 0x1204) /* Versions of zlib < 1.2.4 do not support raw deflate or gzip */ fprintf(stderr,"cmpr_deflate: zlib library %s < 1.2.4 does not support gzip.\n", ZLIB_VERSION); #endif goto cmpr_deflate_error; } break; case ZCompression: if (CMPR_debug) { printf(" Z: deflateInit(strm,level)\n"); printf(" deflateInit(...,%d)\n", Z_DEFAULT_COMPRESSION); } /* initialize Z compression */ errval = deflateInit(&strm, Z_DEFAULT_COMPRESSION); if (errval != Z_OK) goto cmpr_deflate_error; break; default: errval=Z_ERRNO; goto cmpr_deflate_error; } /* compress all input */ pinp = (unsigned char *) inp; rest_inp = inplen; pout = (unsigned char *) out; rest_out = outlen; do { /* read not more than CHUNK bytes */ if ( rest_inp>CHUNK ) { /* more input follows */ avail_inp = CHUNK; flush = Z_NO_FLUSH; } else { /* input finished */ avail_inp = rest_inp; flush = Z_FINISH; } strm.avail_in = avail_inp; /* maximum number of bytes to read */ strm.next_in = pinp; /* pointer to input buffer */ do { /* do not write more than CHUNK bytes */ avail_out = (rest_out>CHUNK)?CHUNK:rest_out; strm.avail_out = avail_out; /* maximum number of bytes to write */ strm.next_out = pout; /* pointer to output buffer */ errval = deflate(&strm, flush); /* no bad return value */ if ( (errval!=Z_STREAM_END)&&(errval!=Z_OK) ) goto cmpr_deflate_error; incr_out = avail_out-strm.avail_out; // number of used bytes rest_out -= incr_out; pout += incr_out; } while ( (strm.avail_out == 0)&&(rest_out>0) ); incr_inp = avail_inp-strm.avail_in; /* number of unread bytes */ rest_inp -= incr_inp; pinp += incr_inp; } while ( (flush != Z_FINISH)&&(rest_out>0) ); converted=pout-(unsigned char *) out; /* clean up */ (void)deflateEnd(&strm); } // if (inplen>0) if ( (errval!=Z_STREAM_END) && (rest_inp>0) && (rest_out==0) ) { if (CMPR_debug) { printf(" cmpr_deflate: output buffer too short (%lu of %lu bytes used)\n", rest_out,outlen); printf(" %lu of %lu input bytes unprocessed.\n", rest_inp,inplen); } errval=Z_ERRNO; goto cmpr_deflate_error; } if (errval!=Z_STREAM_END) { fprintf(stderr, "deflate should report Z_STREAM_END\n"); errval=Z_DATA_ERROR; goto cmpr_deflate_error; } else errval=Z_OK; if (CMPR_debug) printf(" cmpr_deflate END\n"); if (pconverted) *pconverted=converted; if (perrval) *perrval=errval; return(0); cmpr_deflate_error: /* clean up and return */ (void)deflateEnd(&strm); fprintf(stderr,"cmpr_deflate: %s (%s)\n",cmpr_errval2string(errval), cmpr_version()); if (CMPR_debug) printf(" cmpr_deflate END (errval=%d)\n",errval); if (pconverted) *pconverted=converted; if (perrval) *perrval=errval; return(-1); } // cmpr_deflate /*-------------------------------------------------------------------------- NAME cmpr_inflate --- uncompress using zlib SYNOPSIS int cmpr_inflate ( void * out, size_t outlen, const void * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ); DESCRIPTION Decompress a maximum of inplen bytes in steps of CHUNK bytes from inp to out using zlib deflate routine. The size of the output buffer is outlen. cmpr_inflate returns 0 on success and -1 on error. The *perrval returns more specific information: Z_OK on success, Z_MEM_ERROR if memory could not be allocated for processing, Z_DATA_ERROR if the deflate data is invalid or incomplete, Z_VERSION_ERROR if the version of zlib.h and the version of the library linked do not match, Z_ERRNO in case of an output error, e.g. if the output buffer is too short or the compression method is not defined. ARGUMENTS void * out pointer to output buffer size_t outlen length of output buffer in bytes const void * inp pointer to input buffer size_t inplen length of input buffer in bytes int cmpr_method compression method size_t * pconverted number of valid bytes in output buffer int * perrval zlib error value AUTHOR Peter Boesecke 2010-12-12 -----------------------------------------------------------------------------*/ int cmpr_inflate ( void * out, size_t outlen, const void * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ) { int errval; z_stream strm; unsigned char *pinp; unsigned char *pout; size_t rest_inp=(size_t) 0, rest_out=(size_t) 0; size_t avail_inp=(size_t) 0, avail_out=(size_t) 0; size_t incr_inp=(size_t) 0, incr_out=(size_t) 0; size_t converted=(size_t) 0; if (CMPR_debug) printf("\n cmpr_inflate BEGIN\n"); if (!out) outlen=(size_t) 0; if (!inp) inplen=(size_t) 0; /* decompress all input */ errval = Z_STREAM_END; if (inplen>0) { /* if there is something to decompress */ pinp = (unsigned char *) inp; rest_inp = inplen; pout = (unsigned char *) out; rest_out = outlen; /* allocate inflate state */ strm.zalloc = Z_NULL; strm.zfree = Z_NULL; strm.opaque = Z_NULL; strm.avail_in = 0; strm.next_in = Z_NULL; switch ( cmpr_method ) { case GzipCompression: /* initialize gzip decompression */ if (CMPR_debug) { printf(" gzip: inflateInit2(strm,windowBits)\n"); printf(" inflateInit2(...,%d)\n", (MAX_WBITS+16)); } errval = inflateInit2(&strm, (MAX_WBITS+16)); // +16 for gzip if (errval != Z_OK) { #if !defined(ZLIB_VERNUM) || (ZLIB_VERNUM < 0x1204) /* Versions of zlib < 1.2.4 do not support raw deflate or gzip */ fprintf(stderr,"cmpr_inflate: zlib library %s < 1.2.4 does not support gzip.\n", ZLIB_VERSION); #endif goto cmpr_inflate_error; } break; case ZCompression: /* initialize Z decompression */ if (CMPR_debug) { printf(" Z: inflateInit(strm)\n"); printf(" inflateInit(...)\n"); } errval = inflateInit(&strm); if (errval != Z_OK) goto cmpr_inflate_error; break; default: errval=Z_ERRNO; goto cmpr_inflate_error; } do { avail_inp = (rest_inp>CHUNK)?CHUNK:rest_inp; strm.avail_in = avail_inp; strm.next_in = pinp; /* run inflate() on input until output buffer not full */ do { avail_out = rest_out>CHUNK?CHUNK:rest_out; strm.avail_out = avail_out; strm.next_out = pout; errval = inflate(&strm, Z_NO_FLUSH); switch (errval) { case Z_STREAM_ERROR: goto cmpr_inflate_error; case Z_NEED_DICT: errval = Z_DATA_ERROR; /* and fall through */ case Z_DATA_ERROR: case Z_MEM_ERROR: goto cmpr_inflate_error; } incr_out = avail_out-strm.avail_out; rest_out -= incr_out; pout += incr_out; } while ( (strm.avail_out==0)&&(rest_out>0) ); incr_inp = avail_inp-strm.avail_in; rest_inp -= incr_inp; pinp += incr_inp; } while ( (errval != Z_STREAM_END)&&(rest_out>0) ); converted=pout-(unsigned char *) out; /* clean up */ (void)inflateEnd(&strm); } if ( (errval!=Z_STREAM_END) && (rest_inp>0) && (rest_out==0) ) { if (CMPR_debug) { printf(" cmpr_inflate: output buffer too short (%lu of %lu bytes used)\n", rest_out,outlen); printf(" %lu of %lu input bytes unprocessed.\n", rest_inp,inplen); } errval=Z_ERRNO; goto cmpr_inflate_error; } if (errval!=Z_STREAM_END) { fprintf(stderr, "inflate should report Z_STREAM_END\n"); errval=Z_DATA_ERROR; goto cmpr_inflate_error; } else errval=Z_OK; if (CMPR_debug) printf(" cmpr_inflate END\n"); if (pconverted) *pconverted=converted; if (perrval) *perrval=errval; return(0); cmpr_inflate_error: /* clean up and return */ (void)inflateEnd(&strm); fprintf(stderr,"cmpr_inflate: %s (%s)\n",cmpr_errval2string(errval), cmpr_version()); if (CMPR_debug) printf(" cmpr_inflate END (errval=%d)\n",errval); if (pconverted) *pconverted=converted; if (perrval) *perrval=errval; return(-1); } // cmpr_inflate /*-------------------------------------------------------------------------- NAME cmpr_frinflate --- read from file and uncompress using zlib SYNOPSIS int cmpr_frinflate ( void * out, size_t outlen, FILE * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ); DESCRIPTION Decompress a maximum of inplen bytes in steps of CHUNK bytes from inp to out using zlib deflate routine. The size of the output buffer is outlen. cmpr_frinflate returns 0 on success and -1 on error. The *perrval returns more specific information: Z_OK on success, Z_MEM_ERROR if memory could not be allocated for processing, Z_DATA_ERROR if the deflate data is invalid or incomplete, Z_VERSION_ERROR if the version of zlib.h and the version of the library linked do not match, Z_ERRNO in case of an output error, e.g. if the output buffer is too short or the compression method is not defined. ARGUMENTS void * out pointer to output buffer size_t outlen length of output buffer in bytes FILE * inp file channel opened for binary read size_t inplen maximum number of bytes to read int cmpr_method compression method size_t * pconverted number of valid bytes in output buffer int * perrval zlib error value AUTHOR Peter Boesecke 2010-12-13 -----------------------------------------------------------------------------*/ int cmpr_frinflate ( void * out, size_t outlen, FILE * inp, size_t inplen, int cmpr_method, size_t * pconverted, int * perrval ) { int errval; z_stream strm; unsigned char *pout; unsigned char in[CHUNK]; size_t rest_inp=(size_t) 0, rest_out=(size_t) 0; size_t avail_inp=(size_t) 0, avail_out=(size_t) 0; size_t incr_inp=(size_t) 0, incr_out=(size_t) 0; size_t converted=(size_t) 0; if (CMPR_debug) printf("\n cmpr_frinflate BEGIN\n"); if (!out) outlen=(size_t) 0; if (!inp) inplen=(size_t) 0; /* decompress all input */ errval = Z_STREAM_END; if (inplen>0) { /* if there is something to decompress */ rest_inp = inplen; pout = (unsigned char *) out; rest_out = outlen; /* allocate inflate state */ strm.zalloc = Z_NULL; strm.zfree = Z_NULL; strm.opaque = Z_NULL; strm.avail_in = 0; strm.next_in = Z_NULL; switch ( cmpr_method ) { case GzipCompression: /* initialize gzip decompression */ if (CMPR_debug) { printf(" gzip: inflateInit2(strm,windowBits)\n"); printf(" inflateInit2(...,%d)\n", (MAX_WBITS+16)); } errval = inflateInit2(&strm, (MAX_WBITS+16)); // +16 for gzip if (errval != Z_OK) { #if !defined(ZLIB_VERNUM) || (ZLIB_VERNUM < 0x1204) /* Versions of zlib < 1.2.4 do not support raw deflate or gzip */ fprintf(stderr,"cmpr_frinflate: zlib library %s < 1.2.4 does not support gzip.\n", ZLIB_VERSION); #endif goto cmpr_frinflate_error; } break; case ZCompression: /* initialize Z decompression */ if (CMPR_debug) { printf(" Z: inflateInit(strm)\n"); printf(" inflateInit(...)\n"); } errval = inflateInit(&strm); if (errval != Z_OK) goto cmpr_frinflate_error; break; default: errval=Z_ERRNO; goto cmpr_frinflate_error; } do { avail_inp = (rest_inp>CHUNK)?CHUNK:rest_inp; incr_inp = fread(in, 1, avail_inp, inp); if (ferror(inp)) { errval=Z_ERRNO; goto cmpr_frinflate_error; } strm.avail_in = incr_inp; if (strm.avail_in == 0) break; strm.next_in = in; /* run inflate() on input until output buffer not full */ do { avail_out = rest_out>CHUNK?CHUNK:rest_out; strm.avail_out = avail_out; strm.next_out = pout; errval = inflate(&strm, Z_NO_FLUSH); switch (errval) { case Z_STREAM_ERROR: goto cmpr_frinflate_error; case Z_NEED_DICT: errval = Z_DATA_ERROR; /* and fall through */ case Z_DATA_ERROR: case Z_MEM_ERROR: goto cmpr_frinflate_error; } incr_out = avail_out-strm.avail_out; rest_out -= incr_out; pout += incr_out; } while ( (strm.avail_out==0)&&(rest_out>0) ); rest_inp -= incr_inp; } while ( (errval != Z_STREAM_END)&&(rest_out>0) ); converted=pout-(unsigned char *) out; /* clean up */ (void)inflateEnd(&strm); } if ( (errval!=Z_STREAM_END) && (rest_inp>0) && (rest_out==0) ) { if (CMPR_debug) { printf(" cmpr_inflate: output buffer too short (%lu of %lu bytes used)\n", rest_out,outlen); printf(" %lu of %lu input bytes unprocessed.\n", rest_inp,inplen); } errval=Z_ERRNO; goto cmpr_frinflate_error; } if (errval!=Z_STREAM_END) { fprintf(stderr, "inflate should report Z_STREAM_END\n"); errval=Z_DATA_ERROR; goto cmpr_frinflate_error; } else errval=Z_OK; if (CMPR_debug) printf(" cmpr_inflate END\n"); if (pconverted) *pconverted=converted; if (perrval) *perrval=errval; return(0); cmpr_frinflate_error: /* clean up and return */ (void)inflateEnd(&strm); fprintf(stderr,"cmpr_frinflate: %s (%s)\n",cmpr_errval2string(errval), cmpr_version()); if (CMPR_debug) printf(" cmpr_frinflate END (errval=%d)\n",errval); if (pconverted) *pconverted=converted; if (perrval) *perrval=errval; return(-1); } // cmpr_frinflate /*-------------------------------------------------------------------------- NAME cmpr_errval2string --- convert zlib error value to string SYNOPSIS const char * cmpr_errval2string(int errval); DESCRIPTION ARGUMENTS int errval zlib error value RETURN VALUE const char * : error value converted to string AUTHOR Peter Boesecke 2010-12-12 -----------------------------------------------------------------------------*/ const char * cmpr_errval2string(int errval) { switch (errval) { case Z_ERRNO: return("error reading or writing data buffer"); break; case Z_STREAM_ERROR: return("invalid compression level"); break; case Z_DATA_ERROR: return("invalid or incomplete deflate data"); break; case Z_MEM_ERROR: return("out of memory"); break; case Z_VERSION_ERROR: return("zlib version mismatch!"); } return(""); // to make compiler happy } // cmpr_errval2string const char *cmpr_version ( void ) { return(CMPR_VERSION); } spd-1.3.0/edfpack/sx.c0000644000175000017500000016310411635105403011420 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define SX_VERSION "sx : V1.08 Peter Boesecke 2011-09-07" /*+++------------------------------------------------------------------------ NAME sx.c --- 3d orientation parameter transformation INCLUDE FILES # include sx.h PURPOSE Transformation of parameters during change of sx orientation. See PUBLIC functions for detail. AUTHOR 2011 Peter Boesecke (PB) HISTORY 2011-04-27 V1.0 PB 2011-05-18 V1.01 PB axis types added 2011-05-25 V1.02 PB sx_tf_img etc. 2011-06-07 V1.03 PB void * params_in -> const void * params_in sx_tf_img: array_ -> data_, variance_, Usage sx_tf_img: initialize outp after copying input 2011-06-16 V1.04 PB double constants marked, e.g. 1->1.0 2011-07-14 V1.05 PB calculation of bdis does neither require cen nor bcenr, calculation of cen or bcen from bcen or cen requires dis or bdis and rotations. 2011-07-16 V1.06 PB sx_tf_params, sx_tf_img: parameter rot added, use default rotations, when necessary 2011-07-26 V1.07 PB sx_init function added 2011-09-07 V1.08 PB SXPARAMS: space between # and pro removed to facilitate usage of awk, e.g. sxparams {} | awk '{print $5}' returns on the first line the parameter name and on the second line its calculated value. --------------------------------------------------------------------------*/ /**************************************************************************** * Include * ****************************************************************************/ # include "sx.h" /**************************************************************************** * Definitions * ****************************************************************************/ # define SXPARAMS "#pro ori axis1 axis2 dim1 dim2 off1 off2 bis1 bis2 \ ras1 ras2 pix1 pix2 cen1 cen2 dis rot1 rot2 rot3 wvl \ bcen1 bcen2 bdis tilt1 tilt2 tilt3" /**************************************************************************** * Static Variables * ****************************************************************************/ PRIVATE const double rad2deg = 180.0/NUM_PI; PRIVATE const double SxEps = 1e-8; PRIVATE int SxDebug = 0; PRIVATE int SxLevel = 0; PRIVATE char SX_Usage[SXBUFLEN]; /*-------------------------------------------------------------------------- NAME sx_version --- returns pointer to the version string SYNOPSIS const char *sx_version ( void ); DESCRPTION Returns pointer to the version string. --------------------------------------------------------------------------*/ PUBLIC const char *sx_version ( void ) { return ( SX_VERSION ); } /* sx_version */ /*-------------------------------------------------------------------------- NAME sx_usage2str --- return debug mode usage string SYNOPSIS const char *sx_usage2str( void ); DESCRPTION Return debug mode usage string. --------------------------------------------------------------------------*/ PUBLIC const char *sx_usage2str( void ) { sprintf(SX_Usage, "verbose:0x%x,level:0x%x,showdata:0x%x,showtemp:0x%x,sxdebug:0x%x,sxraster:0x%x", SX_VERBOSE, SX_LEVEL, SX_SHOWDATA, SX_SHOWTEMP, SX_DEBUG, SX_RASTER_DEBUG); return(SX_Usage); } // roca_usage2str int fprint_debug( FILE *out ) { fprintf(out,"debug = 0x%x\n", SxDebug); fprintf(out,"verbose = %d\n", SxDebug&SX_VERBOSE?1:0); fprintf(out,"level = %d\n", SxLevel); fprintf(out,"showdata = %d\n", SxDebug&SX_SHOWDATA?1:0); fprintf(out,"showtemp = %d\n", SxDebug&SX_SHOWTEMP?1:0); fprintf(out,"sxdebug = %d\n", SxDebug&SX_DEBUG?1:0); fprintf(out,"sxraster = %d\n", SxDebug&SX_RASTER_DEBUG?1:0); return(0); } // fprint_debug /*-------------------------------------------------------------------------- NAME sx_debug_set --- set / reset module sx into debug mode SYNOPSIS int sx_debug_set( int debug ); DESCRPTION Set / reset module sx into debug mode. --------------------------------------------------------------------------*/ PUBLIC int sx_debug_set( int debug ) { SxDebug = debug; SxLevel = (SxDebug&SX_LEVEL)>>1; raster_debug ( SxDebug&SX_RASTER_DEBUG?1:0 ); if (SxDebug&SX_DEBUG) fprint_debug( stdout ); return(0); } // sx_debug_set /*-------------------------------------------------------------------------- NAME sx_level --- return debug level SYNOPSIS int sx_level ( void ); --------------------------------------------------------------------------*/ PUBLIC int sx_level ( void ) { return( SxLevel ); } // sx_Level /*-------------------------------------------------------------------------- NAME sx_debug --- return debug value SYNOPSIS int sx_debug ( void ); --------------------------------------------------------------------------*/ PUBLIC int sx_debug ( void ) { return( SxDebug ); } // sx_debug /*-------------------------------------------------------------------------- NAME sx_init_params --- initializes sx parameters SYNOPSIS SXParams * sx_init_params ( SXParams * params ); DESCRPTION Initializes sx parameters with default values. --------------------------------------------------------------------------*/ SXParams * sx_init_params ( SXParams * params ) { if (SxDebug&SX_DEBUG) printf( "sx_init_params\n" ); if ( params ) { // projection type as defined in reference.h params->pro.V = IO_ProSaxs; params->pro.I = 0; // orientation number (1-16) params->ori.V = 1l; params->ori.I = 0; // axis types as defined in reference.h params->axis1.V = IO_AxisTypeDistance; params->axis1.I = 0; params->axis2.V = IO_AxisTypeDistance; params->axis2.I = 0; // dimensions of 2d array params->dim1.V = 0l; params->dim1.I = 0; params->dim2.V = 1l; params->dim2.I = 0; // offsets of array coordinates params->off1.V = 0.0; params->off1.I = 0; params->off2.V = 0.0; params->off2.I = 0; // binning sizes params->bis1.V = 1.0; params->bis1.I = 0; params->bis2.V = 1.0; params->bis2.I = 0; // raster region of 2d array params->ras1.V = 0.0; params->ras1.I = 0; params->ras2.V = 0.0; params->ras2.I = 0; // pixel sizes [m] params->pix1.V = 1.0; params->pix1.I = 0; params->pix2.V = 1.0; params->pix2.I = 0; // PONI (point of normal incidence) params->cen1.V = 0.0; params->cen1.I = 0; params->cen2.V = 0.0; params->cen2.I = 0; // distance sample-PONI [m] params->dis.V = 1.0; params->dis.I = 0; // detector rotations [rad] params->rot1.V = 0.0; params->rot1.I = 0; params->rot2.V = 0.0; params->rot2.I = 0; params->rot3.V = 0.0; params->rot3.I = 0; // wavelength [m] params->wvl.V = 1.0; params->wvl.I = 0; // beam center (alt. cen1, cen2) params->bcen1.V = 0.0; params->bcen1.I = 0; params->bcen2.V = 0.0; params->bcen2.I = 0; // distance sample-bcen [m] (alt. dis) params->bdis.V = 1.0; params->bdis.I = 0; // detector rotations [rad] params->tilt1.V = 0.0; params->tilt1.I = 0; params->tilt2.V = 0.0; params->tilt2.I = 0; params->tilt3.V = 0.0; params->tilt3.I = 0; } if (SxDebug&SX_DEBUG) printf( "sx_init_params END\n" ); return( params ); } // sx_init_params /*-------------------------------------------------------------------------- NAME sx_cp_params --- copies input parameters to output SYNOPSIS SXParams * sx_cp_params ( SXParams * params_out, const SXParams * params_in ); DESCRPTION Copies all params_in to params_out --------------------------------------------------------------------------*/ PUBLIC SXParams * sx_cp_params ( SXParams *params_out, const SXParams *params_in ) { SXParams * out=NULL; if (SxDebug&SX_DEBUG) printf( "sx_cp_params\n" ); if ( params_in && params_out ) { out = (SXParams *) memcpy( (void *) params_out, (const void *) params_in, sizeof( SXParams )); } if (SxDebug&SX_DEBUG) printf( "sx_cp_params END\n" ); return( out ); } // sx_cp_params /*-------------------------------------------------------------------------- NAME sx_new --- allocates and initializes new sx parameters SYNOPSIS SXParams * sx_new ( SXParams * params ); DESCRPTION Returns pointer to the successfully allocated and initialized parameters, otherwise NULL. If params is the NULL pointer, new memory is allocated and initialized, otherwise params is only initialized. --------------------------------------------------------------------------*/ PUBLIC SXParams * sx_new ( SXParams * params ) { SXParams * new = NULL; if (SxDebug&SX_DEBUG) printf( "sx_new\n" ); if (!params) { if (!(new=malloc ( sizeof(SXParams) ))) goto sx_new_error; params=new; } // initialize params if (!sx_init_params( params )) goto sx_new_error; if (SxDebug&SX_DEBUG) printf( "sx_new END\n" ); return( params ); sx_new_error: if (new) free(new); if (SxDebug&SX_DEBUG) printf( "sx_new END (error)\n" ); return(NULL); } // sx_new /*-------------------------------------------------------------------------- NAME sx_init --- initializes sx parameters SYNOPSIS SXParams * sx_init ( SXParams * params ); DESCRPTION Returns pointer to the successfully allocated and initialized parameters, otherwise NULL. Like sx_new, but without allocation of memory. --------------------------------------------------------------------------*/ PUBLIC SXParams * sx_init ( SXParams * params ) { if (SxDebug&SX_DEBUG) printf( "sx_init\n" ); if (!params) goto sx_init_error; // initialize params if (!sx_init_params( params )) goto sx_init_error; if (SxDebug&SX_DEBUG) printf( "sx_init END\n" ); return( params ); sx_init_error: if (SxDebug&SX_DEBUG) printf( "sx_init END (error)\n" ); return(NULL); } // sx_init /*-------------------------------------------------------------------------- NAME sx_free --- releases the memory of sx parameters SYNOPSIS SXParams * sx_free ( SXParams * params ); DESCRPTION Returns NULL if successfully released, otherwise params. --------------------------------------------------------------------------*/ PUBLIC SXParams * sx_free ( SXParams * params ) { if (SxDebug&SX_DEBUG) printf( "sx_free\n" ); if ( params ) free( params ); if (SxDebug&SX_DEBUG) printf( "sx_free END\n" ); return( NULL ); } // sx_free /*-------------------------------------------------------------------------- NAME sx_pr_params --- print sx parameters SYNOPSIS int sx_pr_params( FILE * out, const SXParams * params ); DESCRPTION Prints the value of the structure params. RETURN VALUE 0: success; -1: error --------------------------------------------------------------------------*/ PUBLIC int sx_pr_params( FILE * out, const SXParams * params ) { if (SxDebug&SX_DEBUG) printf( "sx_pr_params\n" ); if ((params)&&(out)) { fprintf(out," %s pro = %10d : projection type (%d,%d)\n", params->pro.I?"X":" ",params->pro.V,IO_ProSaxs,IO_ProWaxs); fprintf(out," %s ori = %10ld : orientation number (1-16)\n", params->ori.I?"X":" ",params->ori.V); fprintf(out," %s axis1 = %10d : type of axis 1 (%d,%d,%d)\n", params->axis1.I?"X":" ",params->axis1.V,IO_AxisTypeDistance, IO_AxisTypeAngle, IO_AxisTypeNumerator); fprintf(out," %s axis2 = %10d : type of axis 2 (%d,%d,%d)\n", params->axis2.I?"X":" ",params->axis2.V,IO_AxisTypeDistance, IO_AxisTypeAngle, IO_AxisTypeNumerator); fprintf(out," %s dim1 = %10ld : dimension 1 of 2d array\n", params->dim1.I?"X":" ",params->dim1.V); fprintf(out," %s dim2 = %10ld : dimension 2 of 2d array\n", params->dim2.I?"X":" ",params->dim2.V); fprintf(out," %s off1 = %10lg : offset 1 of array coordinates\n", params->off1.I?"X":" ",params->off1.V); fprintf(out," %s off2 = %10lg : offset 2 of array coordinates\n", params->off2.I?"X":" ",params->off2.V); fprintf(out," %s bis1 = %10lg : binning size 1\n", params->bis1.I?"X":" ",params->bis1.V); fprintf(out," %s bis2 = %10lg : binning size 2\n", params->bis2.I?"X":" ",params->bis2.V); fprintf(out," %s ras1 = %10lg : raster region of axis 1\n", params->ras1.I?"X":" ",params->ras1.V); fprintf(out," %s ras2 = %10lg : raster region of axis 2\n", params->ras2.I?"X":" ",params->ras2.V); fprintf(out," %s pix1 = %10lg : pixel size 1 [m]\n", params->pix1.I?"X":" ",params->pix1.V); fprintf(out," %s pix2 = %10lg : pixel size 2 [m]\n", params->pix2.I?"X":" ",params->pix2.V); fprintf(out," %s cen1 = %10lg : PONI 1 (point of normal incidence)\n", params->cen1.I?"X":" ",params->cen1.V); fprintf(out," %s cen2 = %10lg : PONI 2 (point of normal incidence)\n", params->cen2.I?"X":" ",params->cen2.V); fprintf(out," %s dis = %10lg : distance sample-PONI [m]\n", params->dis.I?"X":" ",params->dis.V); fprintf(out," %s rot1 = %10lg : detector rotation 1 [rad] (%10lg deg)\n", params->rot1.I?"X":" ",params->rot1.V,params->rot1.V*rad2deg); fprintf(out," %s rot2 = %10lg : detector rotation 2 [rad] (%10lg deg)\n", params->rot2.I?"X":" ",params->rot2.V,params->rot2.V*rad2deg); fprintf(out," %s rot3 = %10lg : detector rotation 3 [rad] (%10lg deg)\n", params->rot3.I?"X":" ",params->rot3.V,params->rot3.V*rad2deg); fprintf(out," %s wvl = %10lg : wavelength [m]\n", params->wvl.I?"X":" ",params->wvl.V); fprintf(out," %s bcen1 = %10lg : beam center 1\n", params->bcen1.I?"X":" ",params->bcen1.V); fprintf(out," %s bcen2 = %10lg : beam center 2\n", params->bcen2.I?"X":" ",params->bcen2.V); fprintf(out," %s bdis = %10lg : distance sample-bcen [m]\n", params->bdis.I?"X":" ",params->bdis.V); fprintf(out," %s tilt1 = %10lg : detector tilt 1 [rad] (%10lg deg)\n", params->tilt1.I?"X":" ",params->tilt1.V,params->tilt1.V*rad2deg); fprintf(out," %s tilt2 = %10lg : detector tilt 2 [rad] (%10lg deg)\n", params->tilt2.I?"X":" ",params->tilt2.V,params->tilt2.V*rad2deg); fprintf(out," %s tilt3 = %10lg : detector tilt 3 [rad] (%10lg deg)\n", params->tilt3.I?"X":" ",params->tilt3.V,params->tilt3.V*rad2deg); } if (SxDebug&SX_DEBUG) fprintf( stdout, "sx_pr_params END\n" ); return(0); } // sx_pr_params /*--------------------------------------------------------------------------- NAME sx_pr_params_line --- print sx parameters in a single line SYNOPSIS int sx_pr_params_line( FILE *out, const SXParams *params, int head ); DESCRIPTION Prints the value of the structure params. If head is > 0 a commented head line with the name of all values is written on top. The parameters are SXI pro; // projection (IO_SaxsPro, IO_WaxsPro) SXL ori; // orientation number (1-16) SXI axis1, axis2; // axis type (IO_AxisTypeDistance, // IO_AxisTypeAngle, IO_AxisTypeNumerator) SXL dim1; SXL dim2; // dimensions of 2d array SXD off1; SXD off2; // offsets of array coordinates SXD bis1; SXD bis2; // binning sizes SXD ras1; SXD ras2; // raster region of 2d array SXD pix1; SXD pix2; // pixel sizes [m] SXD cen1; SXD cen2; // PONI (point of normal incidence) SXD dis; // distance sample-PONI [m] SXD rot1; SXD rot2; SXD rot3; // detector rotations [rad] SXD wvl; // wavelength [m] SXD bcen1; SXD bcen2; // beam center (alt. cen1, cen2) SXD bdis; // distance sample-bcen [m] (alt. dis) SXD tilt1; SXD tilt2; SXD tilt3; // detector tilts [rad] RETURN VALUE 0 ---------------------------------------------------------------------------*/ PUBLIC int sx_pr_params_line( FILE *out, const SXParams *params, int head ) { if (SxDebug&SX_DEBUG) fprintf( stdout, "sx_pr_params_line\n" ); if (head>0) fprintf(out,"%s\n",SXPARAMS); if (params->pro.I) fprintf(out,"%d ",params->pro.V); else fprintf(out,"- "); if (params->ori.I) fprintf(out,"%ld ",params->ori.V); else fprintf(out,"- "); if (params->axis1.I) fprintf(out,"%d ",params->axis1.V); else fprintf(out,"- "); if (params->axis2.I) fprintf(out,"%d ",params->axis2.V); else fprintf(out,"- "); if (params->dim1.I) fprintf(out,"%ld ",params->dim1.V); else fprintf(out,"- "); if (params->dim2.I) fprintf(out,"%ld ",params->dim2.V); else fprintf(out,"- "); if (params->off1.I) fprintf(out,"%lg ",params->off1.V); else fprintf(out,"- "); if (params->off2.I) fprintf(out,"%lg ",params->off2.V); else fprintf(out,"- "); if (params->bis1.I) fprintf(out,"%lg ",params->bis1.V); else fprintf(out,"- "); if (params->bis2.I) fprintf(out,"%lg ",params->bis2.V); else fprintf(out,"- "); if (params->ras1.I) fprintf(out,"%lg ",params->ras1.V); else fprintf(out,"- "); if (params->ras2.I) fprintf(out,"%lg ",params->ras2.V); else fprintf(out,"- "); if (params->pix1.I) fprintf(out,"%lg ",params->pix1.V); else fprintf(out,"- "); if (params->pix2.I) fprintf(out,"%lg ",params->pix2.V); else fprintf(out,"- "); if (params->cen1.I) fprintf(out,"%lg ",params->cen1.V); else fprintf(out,"- "); if (params->cen2.I) fprintf(out,"%lg ",params->cen2.V); else fprintf(out,"- "); if (params->dis.I) fprintf(out,"%lg ",params->dis.V); else fprintf(out,"- "); if (params->rot1.I) fprintf(out,"%lg ",params->rot1.V); else fprintf(out,"- "); if (params->rot2.I) fprintf(out,"%lg ",params->rot2.V); else fprintf(out,"- "); if (params->rot3.I) fprintf(out,"%lg ",params->rot3.V); else fprintf(out,"- "); if (params->wvl.I) fprintf(out,"%lg ",params->wvl.V); else fprintf(out,"- "); if (params->bcen1.I) fprintf(out,"%lg ",params->bcen1.V); else fprintf(out,"- "); if (params->bcen2.I) fprintf(out,"%lg ",params->bcen2.V); else fprintf(out,"- "); if (params->bdis.I) fprintf(out,"%lg ",params->bdis.V); else fprintf(out,"- "); if (params->tilt1.I) fprintf(out,"%lg ",params->tilt1.V); else fprintf(out,"- "); if (params->tilt2.I) fprintf(out,"%lg ",params->tilt2.V); else fprintf(out,"- "); if (params->tilt3.I) fprintf(out,"%lg ",params->tilt3.V); else fprintf(out,"- "); if (SxDebug&SX_DEBUG) fprintf( stdout, "sx_pr_params_line END\n" ); return(0); } // sx_pr_params_line /*--------------------------------------------------------------------------- NAME sx_rd_params --- reads the parameters from the string array argv[] SYNOPSIS SXParams * sx_rd_params ( SXParams * params_out, char *argv[], int * perrval ); DESCRIPTION The sx parameters are successively read from argv[0], argv[1], ... until the end of argv[], indicated by a NULL pointer, or until all possible parameters have been read. If params_out is NULL a new parameter structure is allocated and needs, in case of success, to be released by the calling program. In case of success the pointer to the params_out or to the alloated parameter structure is returned. RETURN VALUE In case of success the pointer to the parameter structure is returned, otherwise NULL. ---------------------------------------------------------------------------*/ PUBLIC SXParams * sx_rd_params ( SXParams * params_out, char *argv[], int * perrval ) { char *nul = (char *) NULL; int errval=0; char **pargv=NULL; SXParams * params=NULL; long N=3; if (SxDebug&SX_DEBUG) printf( "sx_rd_params\n" ); if (argv) pargv=&(argv[0]); else goto sx_rd_params_error; // initialize params_out (if NULL allocate and initialize) if ( !(params=sx_new ( params_out )) ) goto sx_rd_params_error; if (*pargv==nul) goto sx_rd_params_end; // read params from argument list // projection (IO_ProSaxs, IO_ProWaxs) if (sx_debug()&SX_DEBUG) printf( "reading pro from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { strlib_tolower(*pargv); if ( (strcmp( *pargv,"saxs" ) == 0)|| (strcmp( *pargv,"s" ) == 0)|| (strncmp( *pargv,"no", 2 ) == 0) ) params->pro.V = IO_ProSaxs; // no projection else if ( (strcmp( *pargv,"waxs" ) == 0)|| (strcmp( *pargv,"sp" ) == 0)|| (strncmp( *pargv,"ewa",3 ) == 0) ) params->pro.V = IO_ProWaxs; // ewald sphere projection else { params->pro.V = (int) num_str2long ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; } params->pro.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // ori orientation number (1-16) if (sx_debug()&SX_DEBUG) printf( "reading ori from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->ori.V = raster_str2number( N, *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->ori.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // axis type (IO_AxisTypeDistance, IO_AxisTypeAngle, IO_AxisTypeNumerator) if (sx_debug()&SX_DEBUG) printf( "reading axis1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { strlib_tolower(*pargv); if ( (strcmp( *pargv,"angle" ) == 0) ) params->axis1.V = IO_AxisTypeDistance; // distance else if ( (strcmp( *pargv,"angle" ) == 0) ) params->axis1.V = IO_AxisTypeAngle; // angle else if ( (strcmp( *pargv,"numerator" ) == 0) ) params->axis1.V = IO_AxisTypeNumerator; // numerator else { params->axis1.V = (int) num_str2long ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; } params->axis1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; if (sx_debug()&SX_DEBUG) printf( "reading axis2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { strlib_tolower(*pargv); if ( (strcmp( *pargv,"angle" ) == 0) ) params->axis2.V = IO_AxisTypeDistance; // distance else if ( (strcmp( *pargv,"angle" ) == 0) ) params->axis2.V = IO_AxisTypeAngle; // angle else if ( (strcmp( *pargv,"numerator" ) == 0) ) params->axis2.V = IO_AxisTypeNumerator; // numerator else { params->axis2.V = (int) num_str2long ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; } params->axis2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // dim1 dimensions of 2d array if (sx_debug()&SX_DEBUG) printf( "reading dim1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->dim1.V = num_str2long ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->dim1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // dim2 dimensions of 2d array if (sx_debug()&SX_DEBUG) printf( "reading dim2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->dim2.V = num_str2long ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->dim2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // off1 offsets of array coordinates if (sx_debug()&SX_DEBUG) printf( "reading off1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->off1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->off1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // off2 offsets of array coordinates if (sx_debug()&SX_DEBUG) printf( "reading off2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->off2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->off2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // bis1 binning sizes if (sx_debug()&SX_DEBUG) printf( "reading bis1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->bis1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->bis1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // bis2 binning sizes if (sx_debug()&SX_DEBUG) printf( "reading bis2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->bis2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->bis2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // ras1 raster region of 2d array if (sx_debug()&SX_DEBUG) printf( "reading ras1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->ras1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->ras1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // ras2 raster region of 2d array if (sx_debug()&SX_DEBUG) printf( "reading ras2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->ras2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->ras2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // pix1 pixel sizes [m] if (sx_debug()&SX_DEBUG) printf( "reading pix1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->pix1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->pix1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // pix2 pixel sizes [m] if (sx_debug()&SX_DEBUG) printf( "reading pix2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->pix2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->pix2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // cen1 PONI (point of normal incidence) if (sx_debug()&SX_DEBUG) printf( "reading cen1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->cen1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->cen1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // cen2 PONI (point of normal incidence) if (sx_debug()&SX_DEBUG) printf( "reading cen2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->cen2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->cen2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // dis distance sample-PONI [m] if (sx_debug()&SX_DEBUG) printf( "reading dis from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->dis.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->dis.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // rot1 detector rotations [rad] if (sx_debug()&SX_DEBUG) printf( "reading rot1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->rot1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->rot1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // rot2 detector rotations [rad] if (sx_debug()&SX_DEBUG) printf( "reading rot2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->rot2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->rot2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // rot3 detector rotations [rad] if (sx_debug()&SX_DEBUG) printf( "reading rot3 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->rot3.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->rot3.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // wvl wavelength [m] if (sx_debug()&SX_DEBUG) printf( "reading wvl from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->wvl.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->wvl.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // bcen1 beam center (alt. cen1, cen2) if (sx_debug()&SX_DEBUG) printf( "reading bcen1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->bcen1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->bcen1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // bcen2 beam center (alt. cen1, cen2) if (sx_debug()&SX_DEBUG) printf( "reading bcen2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->bcen2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->bcen2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // bdis distance sample-bcen [m] (alt. dis) if (sx_debug()&SX_DEBUG) printf( "reading bdis from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->bdis.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->bdis.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // tilt1 detector tilts [rad] if (sx_debug()&SX_DEBUG) printf( "reading tilt1 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->tilt1.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->tilt1.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // tilt2 detector tilt [rad] if (sx_debug()&SX_DEBUG) printf( "reading tilt2 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->tilt2.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->tilt2.I = 1; } if (*(++pargv)==nul) goto sx_rd_params_end; // tilt3 detector tilts [rad] if (sx_debug()&SX_DEBUG) printf( "reading tilt3 from >>%s<<\n", *pargv ); if (strlib_is_no_skip(*pargv)) { params->tilt3.V = num_str2double ( *pargv, NULL, &errval ); if (errval) goto sx_rd_params_error; params->tilt3.I = 1; } sx_rd_params_end: if (perrval) *perrval = errval; if (SxDebug&SX_DEBUG) printf( "sx_rd_params END\n" ); return(params); sx_rd_params_error: if ((!params_out)&&(params)) sx_free(params); if (perrval) *perrval = errval; if (SxDebug&SX_DEBUG) printf( "sx_rd_params END (errval=%d)\n",errval ); return(NULL); } // sx_rd_params /*-------------------------------------------------------------------------- NAME sx_tf_params --- transforms sx parameters to orientation ori SYNOPSIS SXParams *sx_tf_params ( SXParams * params_out, const SXParams * params_in, long ori, int rot, int *perrval ); DESCRPTION Returns a pointer to the successfully transformed sx input parameters, otherwise NULL. If the output pointer out is NULL memory is allocated and must be released by the calling program, otherwise out is used. The input (*in) and output (*buffer) buffers can be identical. params_in->pro.V: input projection (if 0, IO_ProSaxs is used) params_in->ori.V: input orientation (if 0, orientation 1 is used) long ori: output orientation (if 0, in->ori.V is used) int rot: use default rotations, when necessary --------------------------------------------------------------------------*/ PUBLIC SXParams *sx_tf_params ( SXParams * params_out, const SXParams * params_in, long ori, int rot, int *perrval ) { SXParams *new=NULL, *outp=NULL; SXParams in_buffer, *inp; long t_ori, inv_t_ori; long *t_order=NULL, *inv_t_order=NULL; double *T=NULL, *inv_T=NULL; long omod2, omod4, omod8, omod16; int N=3; double R[3][3], RT[3][3], TRT[3][3]; double Angle[3], TAngle[3]; double Tilt[3], TTilt[3]; int tmpX; long tmpL; double tmpV; int tmpI; int RotI=0; int errval=0; if (SxDebug&SX_DEBUG) printf( "sx_tf_params BEGIN\n" ); if (params_in) { // copy input parameters to an internal buffer if (!(inp=sx_cp_params ( &in_buffer, params_in ))) { errval=SX_COPY_ERROR; goto sx_tf_params_error; } // normalize input projection if ( inp->pro.V == 0 ) inp->pro.V = IO_ProSaxs; // normalize input orientation if ( inp->ori.V == 0l ) inp->ori.V=1l; // default else if ( inp->ori.V < 0l ) inp->ori.V = raster_inversion( -inp->ori.V ); // normalize axis types if ( inp->axis1.V == 0 ) inp->axis1.V = IO_AxisTypeDistance; if ( inp->axis2.V == 0 ) inp->axis2.V = IO_AxisTypeDistance; if (SxDebug&SX_SHOWDATA) { printf( " Input parameters\n"); sx_pr_params( stdout, inp ); } if ( !(( inp->pro.V == IO_ProSaxs )||( inp->pro.V == IO_ProWaxs )) ) { errval=SX_INVALID_PROJECTION; goto sx_tf_params_error; } if ( inp->ori.V > 16l ) { errval=SX_INVALID_ORIENTATION; goto sx_tf_params_error; } if ( !(( inp->axis1.V == IO_AxisTypeDistance )||\ ( inp->axis1.V == IO_AxisTypeAngle )||\ ( inp->axis1.V == IO_AxisTypeNumerator )) ) { errval=SX_INVALID_AXISTYPE; goto sx_tf_params_error; } if ( !(( inp->axis2.V == IO_AxisTypeDistance )||\ ( inp->axis2.V == IO_AxisTypeAngle )||\ ( inp->axis2.V == IO_AxisTypeNumerator )) ) { errval=SX_INVALID_AXISTYPE; goto sx_tf_params_error; } // set output orientation default if ( ori == 0l ) ori = inp->ori.V; else if ( ori < 0l ) ori = raster_inversion( -ori ); if (SxDebug&SX_SHOWDATA) printf( " Output orientation = %ld\n",ori); if ( ori > 16l ) { errval=SX_INVALID_ORIENTATION; goto sx_tf_params_error; } // calculate tilts from rotations Angle[0] = inp->rot1.V; Angle[1] = inp->rot2.V; Angle[2] = inp->rot3.V; if (rot3d_matrix(Angle, R)) { errval=SX_MATRIX_CALCULATION_ERROR; goto sx_tf_params_error; } if (tilt3d_angles(Tilt, R)) { errval=SX_ANGLE_CALCULATION_ERROR; goto sx_tf_params_error; } // update tilt1, tilt2, tilt3 if (inp->tilt1.I) Tilt[0] = inp->tilt1.V; if (inp->tilt2.I) Tilt[1] = inp->tilt2.V; if (inp->tilt3.I) Tilt[2] = inp->tilt3.V; if (tilt3d_matrix(Tilt, R)) { errval=SX_MATRIX_CALCULATION_ERROR; goto sx_tf_params_error; } RotI=((RotI)||(inp->tilt1.I)||(inp->tilt2.I)||(inp->tilt3.I))?1:0; // recalculate rot1, rot2, rot3 if (rot3d_angles(Angle, R)) { errval=SX_ANGLE_CALCULATION_ERROR; goto sx_tf_params_error; } // update rotations if (inp->rot1.I) Angle[0] = inp->rot1.V; if (inp->rot2.I) Angle[1] = inp->rot2.V; if (inp->rot3.I) Angle[2] = inp->rot3.V; if (SxDebug&SX_SHOWTEMP) // display Angle raster_fprint_matrix( stdout, N, 1, Angle, "Angle[3]" ); // calculation rotation matrix if (rot3d_matrix(Angle, R)) { errval=SX_MATRIX_CALCULATION_ERROR; goto sx_tf_params_error; } RotI=((RotI)||(inp->rot1.I)||(inp->rot2.I)||(inp->rot3.I))?1:0; if (SxDebug&SX_SHOWTEMP) // display R[3][3] raster_fprint_matrix( stdout, N, N, (double*) R, "R[3][3]" ); // update beam parameters, if possible if (SxDebug&SX_SHOWTEMP) // fabs( R[2][2] ) printf("R[2][2] = %lg, SxEps = %lg\n", R[2][2],SxEps); if ( fabs( R[2][2] ) > SxEps ) { // the detector normal is not perpendicular to the beam // update bcen and bdis if not set (to allow default values) // SXD bcen1; SXD bcen2; // beam center (alt. cen1, cen2) // SXD bdis; // distance sample-bcen [m] (alt. dis) if ( inp->pro.V==IO_ProSaxs ) { if (!inp->bdis.I) { if (r2t_bdis ( &(inp->bdis.V),inp->dis.V,R )) { errval=SX_BEAMDISTANCE_CALCULATION_ERROR; goto sx_tf_params_error; } if (SxDebug&SX_SHOWTEMP) printf("inp->bdis.V = %lg (updated)\n", inp->bdis.V); } if (!inp->bcen1.I) { if (r2t_bcen1( &(inp->bcen1.V),inp->pix1.V,inp->cen1.V,inp->dis.V,R ) ) { errval=SX_BEAMCENTER_CALCULATION_ERROR; goto sx_tf_params_error; } if (SxDebug&SX_SHOWTEMP) printf("inp->bcen1.V = %lg (updated)\n", inp->bcen1.V); } if (!inp->bcen2.I) { if (r2t_bcen2( &(inp->bcen2.V),inp->pix2.V,inp->cen2.V,inp->dis.V,R ) ) { errval=SX_BEAMCENTER_CALCULATION_ERROR; goto sx_tf_params_error; } if (SxDebug&SX_SHOWTEMP) printf("inp->bcen2.V = %lg (updated)\n", inp->bcen2.V); } } else { // IO_ProWaxs if (!inp->bcen1.I) { inp->bcen1.V = inp->cen1.V; if (SxDebug&SX_SHOWTEMP) printf("inp->bcen1.V = %lg (updated)\n", inp->bcen1.V); } if (!inp->bcen2.I) { inp->bcen2.V = inp->cen2.V; if (SxDebug&SX_SHOWTEMP) printf("inp->bcen2.V = %lg (updated)\n", inp->bcen2.V); } if (!inp->bdis.I) { inp->bdis.V = inp->dis.V; if (SxDebug&SX_SHOWTEMP) printf("inp->bdis.V = %lg (updated)\n", inp->bdis.V); } } // update dis, cen1, cen2 if not set // SXD bcen1; SXD bcen2; // beam center (alt. cen1, cen2) // SXD bdis; // distance sample-bcen [m] (alt. dis) if ( inp->pro.V==IO_ProSaxs ) { if (rot) RotI=((inp->bdis.I))?1:RotI; if (!inp->dis.I) { if (r2t_dis ( &(inp->dis.V),inp->bdis.V,R )) { errval=SX_DISTANCE_CALCULATION_ERROR; goto sx_tf_params_error; } inp->dis.I=((RotI)&&(inp->bdis.I))?1:0; if (SxDebug&SX_SHOWTEMP) printf("inp->dis.V = %lg (updated)\n", inp->dis.V); } if (rot) RotI=((inp->bcen1.I)&&(inp->pix1.I)&& ((inp->bdis.I)||(inp->dis.I)))?1:RotI; if (!inp->cen1.I) { if (r2t_cen1 ( &(inp->cen1.V),inp->pix1.V,inp->bcen1.V,inp->bdis.V,R )) { errval=SX_CENTER_CALCULATION_ERROR; goto sx_tf_params_error; } inp->cen1.I=((RotI)&&(inp->bcen1.I)&&(inp->pix1.I)&&(inp->bdis.I))?1:0; if (SxDebug&SX_SHOWTEMP) printf("inp->cen1.V = %lg (updated)\n", inp->cen1.V); } if (rot) RotI=((inp->bcen2.I)&&(inp->pix2.I)&& ((inp->bdis.I)||(inp->dis.I)))?1:RotI; if (!inp->cen2.I) { if (r2t_cen2 ( &(inp->cen2.V),inp->pix2.V,inp->bcen2.V,inp->bdis.V,R )) { errval=SX_CENTER_CALCULATION_ERROR; goto sx_tf_params_error; } inp->cen2.I=((RotI)&&(inp->bcen2.I)&&(inp->pix2.I)&&(inp->bdis.I))?1:0; if (SxDebug&SX_SHOWTEMP) printf("inp->cen2.V = %lg (updated)\n", inp->cen2.V); } } else { // IO_ProWaxs if (!inp->dis.I) { inp->dis.V=inp->bdis.V; inp->dis.I=(inp->bdis.I)?1:0; if (SxDebug&SX_SHOWTEMP) printf("inp->dis.V = %lg (updated)\n", inp->dis.V); } if (!inp->cen1.I) { inp->cen1.V=inp->bcen1.V; inp->cen1.I=(inp->bcen1.I)?1:0; if (SxDebug&SX_SHOWTEMP) printf("inp->cen1.V = %lg (updated)\n", inp->cen1.V); } if (!inp->cen2.I) { inp->cen2.V=inp->bcen2.V; inp->cen2.I=(inp->bcen1.I)?1:0; if (SxDebug&SX_SHOWTEMP) printf("inp->cen2.V = %lg (updated)\n", inp->cen2.V); } } } // if ( fabs( R[2][2] ) > SxEps ) // initialize output buffer if (!params_out) { if (!(new=sx_new( NULL ))) { errval=SX_MEMORY_ALLOCATION_ERROR; goto sx_tf_params_error; } outp = new; } else if (!(outp=sx_new( params_out ))) { errval=SX_MEMORY_ALLOCATION_ERROR; goto sx_tf_params_error; } // copy input parameters to output parameters if (!sx_cp_params ( outp, inp )) { errval=SX_COPY_ERROR; goto sx_tf_params_error; } outp->ori.V = ori; outp->ori.I = 1; // calculate relative transformation t_ori from inp->ori.V to outp->ori.V if (SxDebug&SX_SHOWTEMP) // display outp->ori.V and inp->ori.V printf( " outp->ori.V = %ld, inp->ori.V = %ld\n",outp->ori.V,inp->ori.V); t_ori = raster_multiplication( outp->ori.V, raster_inversion( inp->ori.V ) ); if (SxDebug&SX_SHOWTEMP) // display t_ori printf( " t_ori = %ld\n",t_ori); t_order = raster_number2order ( NULL, 0, 3, t_ori ); if (!t_order) { errval=SX_ORDER_CALCULATION_ERROR; goto sx_tf_params_error; } inv_t_ori = raster_inversion ( t_ori ); if (SxDebug&SX_SHOWTEMP) // display inv_t_ori printf( " inv_t_ori = %ld\n",inv_t_ori); inv_t_order = raster_number2order ( NULL, 0, 3, inv_t_ori ); if (!inv_t_order) { errval=SX_ORDER_CALCULATION_ERROR; goto sx_tf_params_error; } T = raster_order2matrix ( NULL, 0, t_order ); if (!T) { errval=SX_MATRIX_CALCULATION_ERROR; goto sx_tf_params_error; } if (SxDebug&SX_SHOWTEMP) // display T raster_fprint_matrix( stdout, N, N, T, "T[3][3]" ); inv_T = raster_order2matrix ( NULL, 0, inv_t_order ); if (!inv_T) { errval=SX_MATRIX_CALCULATION_ERROR; goto sx_tf_params_error; } if (SxDebug&SX_SHOWTEMP) // display inv_T raster_fprint_matrix( stdout, N, N, inv_T, "inv_T[3][3]" ); omod2 = (t_ori-1l) % 2l; omod4 = (t_ori-1l) % 4l; omod8 = (t_ori-1l) % 8l; omod16 = (t_ori-1l) % 16l; if ( omod2 >= 1l ) { // invert first coordinate if (SxDebug&SX_DEBUG) printf(" invert first coordinate\n"); if (inp->ras1.I) { outp->off1.V = OSWAP2(inp->ras1.V,inp->bis1.V,inp->off1.V,inp->dim1.V); outp->off1.I = 1; } outp->cen1.V = CSWAP2(outp->off1.V,inp->cen1.V,inp->off1.V,inp->dim1.V); outp->cen1.I = inp->cen1.I; } if ( omod4 >= 2l ) { // invert second coordinate if (SxDebug&SX_DEBUG) printf(" invert second coordinate\n"); if (inp->ras2.I) { outp->off2.V = OSWAP2(inp->ras2.V,inp->bis2.V,inp->off2.V,inp->dim2.V); outp->off2.I = 1; } outp->cen2.V = CSWAP2(outp->off2.V,inp->cen2.V,inp->off2.V,inp->dim2.V); outp->cen2.I = inp->cen2.I; } if ( omod8 >= 4l ) { // swap coordinates if (SxDebug&SX_DEBUG) printf(" swap first and second coordinates\n"); tmpX = outp->axis1.V; tmpI = outp->dim1.I; outp->axis1.V = outp->axis2.V; outp->axis1.I = outp->axis2.I; outp->axis2.V = tmpX; outp->axis2.I = tmpI; tmpL = outp->dim1.V; tmpI = outp->dim1.I; outp->dim1.V = outp->dim2.V; outp->dim1.I = outp->dim2.I; outp->dim2.V = tmpL; outp->dim2.I = tmpI; tmpV = outp->off1.V; tmpI = outp->off1.I; outp->off1.V = outp->off2.V; outp->off1.I = outp->off2.I; outp->off2.V = tmpV; outp->off2.I = tmpI; tmpV = outp->cen1.V; tmpI = outp->cen1.I; outp->cen1.V = outp->cen2.V; outp->cen1.I = outp->cen2.I; outp->cen2.V = tmpV; outp->cen2.I = tmpI; tmpV = outp->bis1.V; tmpI = outp->bis1.I; outp->bis1.V = outp->bis2.V; outp->bis1.I = outp->bis2.I; outp->bis2.V = tmpV; outp->bis2.I = tmpI; tmpV = outp->pix1.V; tmpI = outp->pix1.I; outp->pix1.V = outp->pix2.V; outp->pix1.I = outp->pix2.I; outp->pix2.V = tmpV; outp->pix2.I = tmpI; tmpV = outp->ras1.V; tmpI = outp->ras1.I; outp->ras1.V = outp->ras2.V; outp->ras1.I = outp->ras2.I; outp->ras2.V = tmpV; outp->ras2.I = tmpI; } outp->dis.V = inp->dis.V; outp->dis.I = inp->dis.I; outp->wvl.V = inp->wvl.V; outp->wvl.I = inp->wvl.I; // SXD rot1; SXD rot2; SXD rot3; // detector rotations [rad] raster_matrix_product ( (double*) RT, N*N, (double *) R, T, N, N, N ); if (SxDebug&SX_SHOWTEMP)// display RT raster_fprint_matrix( stdout, N, N, (double*) RT, "RT[3][3]" ); raster_matrix_product ( (double*) TRT, N*N, inv_T, (double *) RT, N, N, N ); if (SxDebug&SX_SHOWTEMP)// display TRT raster_fprint_matrix( stdout, N, N, (double*) TRT, "TRT[3][3]" ); if (rot3d_angles(TAngle, TRT)) { errval=SX_ANGLE_CALCULATION_ERROR; goto sx_tf_params_error; } if (SxDebug&SX_SHOWTEMP)// display TAngle raster_fprint_matrix( stdout, N, 1, TAngle, "TAngle[3]" ); outp->rot1.V = TAngle[0]; outp->rot2.V = TAngle[1]; outp->rot3.V = TAngle[2]; outp->rot1.I = RotI; outp->rot2.I = RotI; outp->rot3.I = RotI; // update tilt1, tilt2, tilt3 if (tilt3d_angles(TTilt, TRT)) { errval=SX_ANGLE_CALCULATION_ERROR; goto sx_tf_params_error; } if (SxDebug&SX_SHOWTEMP)// display TTilts raster_fprint_matrix( stdout, N, 1, TTilt, "TTilts[3]" ); outp->tilt1.V = TTilt[0]; outp->tilt2.V = TTilt[1]; outp->tilt3.V = TTilt[2]; outp->tilt1.I = RotI; outp->tilt2.I = RotI; outp->tilt3.I = RotI; // update beam parameters if detector plane is not perpendicular to beam if (SxDebug&SX_SHOWTEMP) // fabs( TRT[2][2] ) printf("TRT[2][2] = %lg, SxEps = %lg\n", TRT[2][2],SxEps); if ( fabs( TRT[2][2] ) > SxEps ) { // update bcen and bdis // SXD bcen1; SXD bcen2; // beam center (alt. cen1, cen2) // SXD bdis; // distance sample-bcen [m] (alt. dis) if ( outp->pro.V==IO_ProSaxs ) { if (r2t_bdis ( &(outp->bdis.V),outp->dis.V,TRT )) { errval=SX_BEAMDISTANCE_CALCULATION_ERROR; goto sx_tf_params_error; } outp->bdis.I=((outp->dis.I)&&(RotI))?1:0; if (SxDebug&SX_SHOWTEMP) printf("outp->bdis.V = %lg (updated)\n", outp->bdis.V); if (r2t_bcen1( &(outp->bcen1.V),outp->pix1.V,outp->cen1.V,outp->dis.V,TRT )){ errval=SX_BEAMCENTER_CALCULATION_ERROR; goto sx_tf_params_error; } outp->bcen1.I=((outp->cen1.I)&&(RotI)&&(outp->pix1.I))?1:0; if (SxDebug&SX_SHOWTEMP) printf("outp->bcen1.V = %lg (updated)\n", outp->bcen1.V); if (r2t_bcen2( &(outp->bcen2.V),outp->pix2.V,outp->cen2.V,outp->dis.V,TRT )){ errval=SX_BEAMCENTER_CALCULATION_ERROR; goto sx_tf_params_error; } outp->bcen2.I=((outp->cen2.I)&&(RotI)&&(outp->pix2.I))?1:0; if (SxDebug&SX_SHOWTEMP) printf("outp->bcen2.V = %lg (updated)\n", outp->bcen2.V); } else { // IO_ProWaxs outp->bdis.V=outp->dis.V; outp->bdis.I=((outp->dis.I)&&(RotI))?1:0; if (SxDebug&SX_SHOWTEMP) printf("outp->bdis.V = %lg (updated)\n", outp->bdis.V); outp->bcen1.V=outp->cen1.V; outp->bcen1.I=((outp->cen1.I)&&(RotI))?1:0; if (SxDebug&SX_SHOWTEMP) printf("outp->bcen1.V = %lg (updated)\n", outp->bcen1.V); outp->bcen2.V=outp->cen2.V; outp->bcen2.I=((outp->cen2.I)&&(RotI))?1:0; if (SxDebug&SX_SHOWTEMP) printf("outp->bcen2.V = %lg (updated)\n", outp->bcen2.V); } } // if ( fabs( TRT[2][2] ) > SxEps ) if (inv_T) free(inv_T); if (T) free(T); if (inv_t_order) free(inv_t_order); if (t_order) free(t_order); } errval = SX_SUCCESS; if (SxDebug&SX_SHOWDATA) { printf(" Output parameters\n"); sx_pr_params( stdout, outp ); } if (perrval) *perrval=errval; if (SxDebug&SX_DEBUG) printf( "sx_tf_params END\n" ); return( outp ); sx_tf_params_error: if (inv_T) free(inv_T); if (T) free(T); if (inv_t_order) free(inv_t_order); if (t_order) free(t_order); if (new) free(new); if (perrval) *perrval=errval; if (SxDebug&SX_DEBUG) printf( "sx_tf_params END (error=%d)\n",errval ); return( NULL ); } // sx_tf_params /*-------------------------------------------------------------------------- NAME sx_tf_img --- transforms an image to a different orientation SYNOPSIS int sx_tf_img ( SXParams *params_out, void *data_out, void *variance_out, size_t item_number, const SXParams *params_in, const void *data_in, const void *variance_in, size_t item_size, long ori, int rot, int *perrval ); ARGUMENTS SXParams *params_out (o) : output sx params (must be allocated) void *data_out (o) : output data array (must be allocated) size_t item_number (i) : allocated number of array elements (all arrays) const SXParams *params_in (i) : input sx params const void *data_in (i) : input data array size_t item_size (i) : size of a single array element (both arrays) long ori (i) : output raster orientation int rot (i) : use default rotations, if they are not supplied int * perrval (o) : error message DESCRPTION params_in contains the image parameters, data_in the pixel data. ori is the orientation of the output image. The transformed parameters are written to params_out and the pixel data to data_out. params_out and data_out must be sufficiently large. If data_in or data_out is the NULL pointer, only the parameter are converted. Input (params_in, data_in) and output (params_out, data_out) parameters can be identical. RETURN VALUE 0 in case of success -1 otherwise --------------------------------------------------------------------------*/ PUBLIC int sx_tf_img ( SXParams *params_out, void *data_out, void *variance_out, size_t item_number, const SXParams *params_in, const void *data_in, const void *variance_in, size_t item_size, long ori, int rot, int *perrval ) { int errval; long order_in[4], order_out[4], order_inv[4], order_tf[4]; long data_dim_in[4]; size_t used_number; SXParams params; // copy of *params_in if (SxDebug&SX_DEBUG) printf( "sx_tf_img BEGIN\n" ); if (!params_out) { errval=SX_NULL_POINTER; goto sx_tf_img_error; } /* make a copy of params_in */ if ( !(sx_cp_params ( ¶ms, params_in )) ) { errval=SX_COPY_ERROR; goto sx_tf_img_error; } if ( !(sx_tf_params (params_out, ¶ms, ori, rot, &errval)) ) goto sx_tf_img_error; /* reorder arrays */ if ( ((data_in)&&(data_out))||((variance_in)&&(variance_out)) ) { if (SxDebug&SX_DEBUG) printf( " reorder arrays: orientation %ld -> %ld\n", params.ori.V, params_out->ori.V ); if ( !(raster_number2order ( order_in, 4, 3, params.ori.V )) ) { errval=SX_INVALID_ORIENTATION; goto sx_tf_img_error; } if (SxDebug&SX_DEBUG) printf(" order_in=%ld\n",raster_order2number(order_in)); if ( (!raster_number2order ( order_out, 4, 3, params_out->ori.V )) ) { errval=SX_INVALID_ORIENTATION; goto sx_tf_img_error; } if (SxDebug&SX_DEBUG) printf(" order_out=%ld\n",raster_order2number(order_out)); if ( (!raster_order_inversion ( order_inv, 4, order_out )) ) { errval=SX_INVALID_ORIENTATION; goto sx_tf_img_error; } if (SxDebug&SX_DEBUG) printf(" order_out_inv=%ld\n",raster_order2number(order_inv)); if ( (!raster_order_multiplication(order_tf, 4, order_inv, order_in)) ) { errval=SX_INVALID_ORIENTATION; goto sx_tf_img_error; } if (SxDebug&SX_DEBUG) printf(" order_tf=%ld\n",raster_order2number(order_tf)); data_dim_in[0]=3l; data_dim_in[1]=params.dim1.V; data_dim_in[2]=params.dim2.V; data_dim_in[3]=1l; // third dimension is 1 /* check, that item_number is sufficiently large */ used_number = (unsigned long) ( data_dim_in[1]*data_dim_in[2] ); if (item_number0) ) { switch (errval) { case SX_SUCCESS: strncpy(buffer,"success",buflen-1); buffer[buflen-1]='\0'; break; case SX_NULL_POINTER: strncpy(buffer,"NULL pointer",buflen-1); buffer[buflen-1]='\0'; break; case SX_INVALID_PROJECTION: strncpy(buffer,"invalid projection",buflen-1); buffer[buflen-1]='\0'; break; case SX_INVALID_ORIENTATION: strncpy(buffer,"invalid orientation",buflen-1); buffer[buflen-1]='\0'; break; case SX_INVALID_AXISTYPE: strncpy(buffer,"invalid axis type",buflen-1); buffer[buflen-1]='\0'; break; case SX_MEMORY_ALLOCATION_ERROR: strncpy(buffer,"memory allocation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_ORDER_CALCULATION_ERROR: strncpy(buffer,"order calculation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_MATRIX_CALCULATION_ERROR: strncpy(buffer,"matrix calculation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_ANGLE_CALCULATION_ERROR: strncpy(buffer,"angle calculation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_BEAMCENTER_CALCULATION_ERROR: strncpy(buffer,"beam center calculation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_BEAMDISTANCE_CALCULATION_ERROR: strncpy(buffer,"beam distance calculation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_CENTER_CALCULATION_ERROR: strncpy(buffer,"center calculation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_DISTANCE_CALCULATION_ERROR: strncpy(buffer,"distance calculation error",buflen-1); buffer[buflen-1]='\0'; break; case SX_COPY_ERROR: strncpy(buffer,"copying error",buflen-1); buffer[buflen-1]='\0'; break; case SX_ARRAY_TOOSMALL: strncpy(buffer,"array size too small",buflen-1); buffer[buflen-1]='\0'; break; case SX_RASTER_ERROR: strncpy(buffer,"raster error",buflen-1); buffer[buflen-1]='\0'; break; default: strncpy(buffer,"error value",buflen-1); buffer[buflen-1]='\0'; } // switch } else value=NULL; return( value ); } // sx_errval2str /****************************************************************************/ spd-1.3.0/edfpack/bslio.c0000644000175000017500000014614511633462462012115 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define BSLIO_VERSION "bslio : V0.65 Peter Boesecke 2010-12-18" /*+++*********************************************************************** NAME bslio.c SYNOPSIS #include "edfio.h" typedef struct Bsl_Data_Specification { char *BinaryFileName; // defined in edfio unsigned long BinaryFilePos; // defined in edfio unsigned long BinaryFileLen; // defined in edfio void *Data; // defined in edfio long *Dim; // defined in edfio int DataType; // defined in edfio int ByteOrder; // defined in edfio long RasterConfiguration; // defined in edfio int Compression; // defined in edfio } BslDataSpec; extern int open_bsl_file ( const char * FileName , const char * mode ), close_bsl_file ( int stream ); bsl_memory_range( int stream, long * minmem, long *maxmem ); bsl_frame_range( int stream, long memnum, long * minfra, long * maxfra ); extern BslDataSpec *read_bsl_data_spec ( int stream, long memnum, long franum ); extern void print_bsl_data_spec ( FILE * out, const BslDataSpec * data_spec ), print_bsl_filetable ( FILE * out, int level, int verbose ), read_bsl_file_headers ( int stream, char **first_header, char **second_header ); extern char char *bslio_version ( void ); DESCRIPTION Library for access to bsl and otoko files. Public routines are defined in "bslio.h" HISTORY 22-Mar-1998 Peter Boesecke V0.50 (read only version) 27-Apr/1998 PB V0.51 (BSL read with HighByteFirst if not a PC) 17-May-1998 PB open bsl file with "new", "old", "any" and "read" 31-Dec-2000 PB V0.53 Dim[3] not used any more 2000-01-12 PB V0.54 for VisualC++ compatibility: u_long replaced by unsigned long strncmp replaced by STRNCASECMP still undefined in VCC: getcwd 2001-01-15 PB V0.55 GETCWD 2001-01-24 PB V0.56 _getcwd 2001-02-05 PB V0.57 all unreferenced variables removed 2001-02-05 PB V0.58 not included for __MSVC__ 2001-04-11 PB V0.59 __MSVC__ -> WIN32 2001-07-01 PB V0.60 __MSVC__ -> WIN32 2004-03-16 PB V0.61 STRNCASECMP now in numio, bslio must be linked with numio 2004-03-24 PB V0.62 STRNCASECMP -> num_strncasecmp 2007-04-19 PB V0.63 sizeof is always first operand, corrected to avoid compiler warnings with -Wall 2007-11-23 PB V0.64 edf_byteorder() function used 2010-12-18 PB V0.65 read_bsl_header: (memory_key) is always TRUE ***************************************************************************/ /*************************************************************************** * Private part * ***************************************************************************/ #include #include #include #ifndef WIN32 # include #endif #include #ifdef sun /* sun specific stuff */ # include # include #else # include #endif # include "bslio.h" # include "numio.h" /*****************************************************************************/ # define MaxBslFiles 20 /* maximum opened bsl files */ # define BslIndicNumber 10 /* minimum size of the indicator array */ # define BslBufferSize 512 /* size of the I/O buffer */ # define MaxBslLineLen 80 /* maximum length per line in output */ /*****************************************************************************/ typedef struct Bsl_Frame { char *FrameKey; BslDataSpec *DataSpec; struct Bsl_Frame *Previous, *Next; /* previous and next memory */ struct Bsl_Memory *Memory; /* the owning memory */ } BslFrame; typedef struct Bsl_Memory { char *MemoryKey; char *FileName; /* name of the memory file */ char *Indicator; BslFrame *FrameList; struct Bsl_Memory *Previous, *Next; /* previous and next memory */ struct Bsl_File *File; /* the owning file */ } BslMemory; typedef struct Bsl_File { char *Name; /* file name with path */ char *Path; /* path only */ FILE *Channel; /* i/o channel */ char *Buffer; /* pointer to IO Buffer */ char *FirstHeader; char *SecondHeader; BslMemory *MemoryList; /* the list of memories in this file */ } BslFile; PRIVATE int InitBslTable = 0; PRIVATE BslFile BslTable[MaxBslFiles]; PRIVATE char *BslNew = "new", *BslOld = "old", *BslAny = "any", *BslRead = "read"; PRIVATE char end_of_line[3] = { '\r', '\n', '\0' }; enum BslOpenMode { NewBslFile, OldBslFile, AnyBslFile }; enum BslSortMode { Bsl_CaseSensitive, Bsl_UpperCase, Bsl_Number }; enum IndicIndex { index_dim_1=1, index_dim_2, index_dim_3, index4, index5, index6, index7, index8, index9, lastindex, IndicEnd }; /*************************************************************************** * Defines * ***************************************************************************/ #ifdef sun # include # define GETCWD(x,y) getwd (x) #else # ifdef WIN32 # include # define GETCWD(x,y) _getcwd(x, y) # else # define GETCWD(x,y) getcwd (x, y) # endif #endif /*****************************************************************************/ /*--------------------------------------------------------------------------- NAME bslio_version --- returns the current version of bslio SYNOPSIS char *bslio_version ( void ); RETURN VALUE char * version string ---------------------------------------------------------------------------*/ char *bslio_version ( void ) { return ( BSLIO_VERSION ); } /* bslio_version */ /*--------------------------------------------------------------------------- NAME newstr_bsl --- allocate memory and copy a character string into it SYNOPSIS char * newstr_bsl( const char * string ); DESCRIPTION Allocates strlen(´string´)+1 bytes of memory and copies ´string´ into it. In case of success the pointer to the allocated memory is returned. The null pointer is returned in case of an error. RETURN VALUE Returns the pointer to the allocated string or (char *) NULL in case of an error. ---------------------------------------------------------------------------*/ char * newstr_bsl( const char * string ) { char * newstr_bsling; if (!(newstr_bsling = (char *) malloc(strlen(string)+1))) return((char *) NULL); (void) strcpy(newstr_bsling,string); return( newstr_bsling ); } /* newstr_bsl */ /*--------------------------------------------------------------------------- NAME trim_bsl --- remove leading and trailing white spaces SYNOPSIS char * trim_bsl ( char * str ); DESCRIPTION Leading and trailing characters in ´str´ that return true when checked with isspace are removed. The string ´str´ is actually modified. The first non-isspace character is copied to the start of ´str´ and the character after the last non-isspace character is set to '\0'. removed. If ´str´ is the NULL pointer the NULL pointer is returned. HISTORY 23-Mar-1998 Peter Boesecke ---------------------------------------------------------------------------*/ char * trim_bsl ( char * str ) { char *ps1, *ps2; if ( !str ) return ( str ); ps1 = ps2 = str; while ( (*ps1) && (isspace(*ps1)) ) ps1++; while (*ps1) *ps2++ = *ps1++; *ps2--='\0'; while ( (ps2>=str) && (isspace(*ps2)) ) *ps2--='\0'; return ( str ); } /* trim_bsl */ /*--------------------------------------------------------------------------- NAME getpath_bsl --- extract path from filename SYNOPSIS char *getpath_bsl ( char *buffer, size_t buflen, const char * filename ); DESCRIPTION Extract path from filename and copies it into buffer. If the buffer is too short or another error has occurred NULL is returned. If filename has no path the current working directory is determined with getcwd and returned. HISTORY 23-Mar-1998 Peter Boesecke ---------------------------------------------------------------------------*/ char * getpath_bsl ( char * buffer, size_t buflen, const char * filename ) { size_t str_len; char *ps; str_len = strlen(filename); if (str_len>=buflen) return( (char *) NULL ); if ( (ps = strrchr( filename, (int) '/' )) ) { memcpy( buffer, filename, (ps-filename) ); buffer[(ps-filename)]='\0'; } else GETCWD( buffer, buflen ); str_len = strlen(buffer); if (str_len s2 the return value is 1 In SortMode SM_UpperCase the sorting is not case sensitive In SortMode SM_Number the strings are converted to numbers and the numbers are compared. If the conversion fails the comparison is case insensitive. RETURN VALUE int -1, 0, +1 depending on the comparison ---------------------------------------------------------------------------*/ int compare_bsl_keys ( const char * s1, const char * s2, int smode ) { int comp_result; long l1, l2; char * err1, *err2; switch ( smode ) { case Bsl_CaseSensitive: comp_result = strncmp ( s1, s2, MaxBslLineLen ); break; case Bsl_UpperCase: comp_result = num_strncasecmp ( s1, s2, MaxBslLineLen ); break; case Bsl_Number: l1 = strtol(s1, &err1 ,10); l2 = strtol(s2, &err2 ,10); if (err1) if (strlen(err1)==0) err1 = (char *) NULL; if (err2) if (strlen(err2)==0) err2 = (char *) NULL; if (!((err1)||(err2))) { if (l1Name = (char *) NULL; file->Path = (char *) NULL; file->Channel = (FILE *) NULL; file->Buffer = (char *) NULL; file->FirstHeader = (char *) NULL; file->SecondHeader = (char *) NULL; file->MemoryList = (BslMemory *) NULL; } /* init_bsl_file */ /*--------------------------------------------------------------------------- NAME init_bsl_file_table --- initialization of the bsl file table cells ---------------------------------------------------------------------------*/ void init_bsl_file_table ( BslFile ftb[] ) { register int i; for (i=0;i= 0 error: <0 ---------------------------------------------------------------------------*/ int search_free_bsl_stream ( BslFile ftb[] ) { register int i; for (i=0;iBinaryFileName = (char *) NULL; data_spec->BinaryFilePos = 0U; data_spec->BinaryFileLen = 0U; data_spec->Data = (void *) NULL; data_spec->Dim = (long *) NULL; data_spec->DataType = FloatIEEE32; data_spec->ByteOrder = edf_byteorder (); data_spec->RasterConfiguration = 1; data_spec->Compression = UnCompressed; } /* init_bsl_data_spec */ /*--------------------------------------------------------------------------- NAME new_bsl_data --- creates a new bsl data structure and initializes it RETURN VALUE success: BslDataSpec * pointer to new bsl data specification error: NULL pointer ---------------------------------------------------------------------------*/ BslDataSpec * new_bsl_data_spec ( void ) { BslDataSpec * newdata_spec; if ( (newdata_spec = (BslDataSpec *) malloc( sizeof(BslDataSpec) )) ) init_bsl_data_spec ( newdata_spec ); return(newdata_spec); } /* new_bsl_data_spec */ /*--------------------------------------------------------------------------- NAME free_bsl_data_spec --- deallocate ´data_spec´ and all its contents SYNOPSIS BslDataSpec * free_bsl_data ( BslDataSpec * data_spec ) DESCRIPTION The allocated memory of the contents of ´data_spec´ is removed and (BslDataSpec *) NULL is returned. If ´data_spec´ is NULL, nothing is done. RETURN VALUE (BslDataSpec *) NULL ---------------------------------------------------------------------------*/ BslDataSpec * free_bsl_data_spec ( BslDataSpec * data_spec ) { if (!data_spec) return ( data_spec ); if (data_spec->BinaryFileName) free ( data_spec->BinaryFileName ); if (data_spec->Data) free ( data_spec->Data ); if (data_spec->Dim) free ( data_spec->Dim ); free(data_spec); return( (BslDataSpec *) NULL ); } /* free_bsl_data_spec */ /*--------------------------------------------------------------------------- NAME init_bsl_frame --- initialization of the bsl frame structure ---------------------------------------------------------------------------*/ void init_bsl_frame ( BslFrame * frame ) { frame->FrameKey = (char *) NULL; frame->DataSpec = (BslDataSpec *) NULL; frame->Previous = (BslFrame *) NULL; frame->Next = (BslFrame *) NULL; frame->Memory = (BslMemory *) NULL; } /* init_bsl_frame */ /*--------------------------------------------------------------------------- NAME new_bsl_frame --- creates a new bsl frame and initializes it RETURN VALUE success: BslFrame * pointer to new bsl frame error: NULL pointer ---------------------------------------------------------------------------*/ BslFrame * new_bsl_frame ( const char * FrameKey ) { BslFrame * newframe; if ( (newframe = (BslFrame *) malloc( sizeof(BslFrame) )) ) init_bsl_frame ( newframe ); newframe->FrameKey = newstr_bsl(FrameKey); newframe->DataSpec = new_bsl_data_spec(); return(newframe); } /* new_bsl_frame */ /*--------------------------------------------------------------------------- NAME search_bsl_frame --- searches the bsl ´frame´ in the frame list of ´memory´ SYNOPSIS BslFrame * search_bsl_frame ( BslMemory * memory, char * FrameKey ) DESCRIPTION RETURN VALUE success BslFrame * frame error NULL ---------------------------------------------------------------------------*/ BslFrame * search_bsl_frame ( BslMemory * memory, const char * FrameKey ) { BslFrame * current = (BslFrame *) NULL; if (memory == (BslMemory *) NULL) return( current ); /* search frame */ current = memory->FrameList; if (current!=(BslFrame *) NULL ) while( ( current!=(BslFrame *) NULL ) && ( compare_bsl_keys(current->FrameKey,FrameKey,Bsl_Number)!=0 ) ) { current = current->Next; } return( current ); } /* search_bsl_frame */ /*--------------------------------------------------------------------------- NAME insert_bsl_frame --- insert a bsl frame into the frame list of a bsl memory SYNOPSIS BslFrame * insert_bsl_frame ( BslMemory * memory, const char * FrameKey ) DESCRIPTION RETURN VALUE success: pointer to inserted frame error: NULL pointer ---------------------------------------------------------------------------*/ BslFrame * insert_bsl_frame ( BslMemory * memory, const char * FrameKey ) { BslFrame *frame, *previous, *next, *newframe; int notfound = -1; frame = (BslFrame *) NULL; previous = (BslFrame *) NULL; if ( memory == (BslMemory *) NULL ) return( frame ); /* search insertion point (insertion before *pnext) */ next = memory->FrameList; while( ( next!=(BslFrame *) NULL ) && (notfound<0) ) { notfound = compare_bsl_keys(next->FrameKey,FrameKey,Bsl_Number); if (notfound<0) { previous = next; next = next->Next; } } /* create new frame, if no frame found */ if ( next==(BslFrame *) NULL ) { /* create new frame */ newframe = new_bsl_frame ( FrameKey ); if ( newframe == (BslFrame *) NULL ) return( frame ); /* insert new frame before *pnext */ if (next) next->Previous = newframe; newframe->Next=next; newframe->Previous=previous; if (previous) previous->Next=newframe; else memory->FrameList=newframe; /* link to owning memory */ newframe->Memory = memory; next = newframe; } frame = next; return( frame ); } /* insert_bsl_frame */ /*--------------------------------------------------------------------------- NAME remove_bsl_frame --- removes ´frame´ from the frame list SYNOPSIS void remove_bsl_frame ( BslFrame * frame ) DESCRIPTION The allocated memory of the contents of ´frame´ is removed. The frame is removed from the frame list of the owning memory. If ´frame´ was the only frame in ´frame->Memory->FrameList´ ´frame->Memory->FrameList´ is set to (BslFrame *) NULL. If ´frame´ is NULL, nothing is done. ---------------------------------------------------------------------------*/ void remove_bsl_frame ( BslFrame * frame ) { BslFrame **proot, *previous, *next; if (frame==(BslFrame*) NULL) return; proot = &(frame->Memory->FrameList); previous = frame->Previous; next = frame->Next; if (next!=(BslFrame*) NULL) next->Previous = previous; if (previous!=(BslFrame*) NULL) previous->Next = next; if (*proot==frame) { *proot = ((BslFrame*) NULL); } if (frame->FrameKey) free(frame->FrameKey); free_bsl_data_spec( frame->DataSpec ); free(frame); return; } /* remove_bsl_frame */ /*--------------------------------------------------------------------------- NAME remove_bsl_frame_list --- empty the frame list of ´memory´ SYNOPSIS void remove_bsl_frame_list ( BslMemory * memory ); ---------------------------------------------------------------------------*/ void remove_bsl_frame_list ( BslMemory * memory ) { BslFrame *frame, *next; if (memory==(BslMemory*) NULL) return; next = memory->FrameList; while ( next!=(BslFrame*) NULL ) { frame = next; next = next->Next; remove_bsl_frame ( frame ); } return; } /* free_bsl_frame_list */ /*--------------------------------------------------------------------------- NAME print_bsl_data_spec --- prints ´data_spec´ SYNOPSIS void print_bsl_data_spec ( FILE * out, const BslDataSpec * data_spec ); ---------------------------------------------------------------------------*/ void print_bsl_data_spec ( FILE * out, const BslDataSpec * data_spec ) { const char * SeparationLine = "- - - - - - - -"; long i_dim; if (!data_spec) return; fprintf(out," %s\n",SeparationLine); fprintf(out," BinaryFileName = "); if ( data_spec->BinaryFileName ) fprintf(out,"\"%s\"\n",data_spec->BinaryFileName); else fprintf(out,"(no binary file name)\n"); fprintf(out," BinaryFilePos = %lu\n",data_spec->BinaryFilePos); fprintf(out," BinaryFileLen = %lu\n",data_spec->BinaryFileLen); fprintf(out," Data = %p\n",data_spec->Data); fprintf(out," Dim = %p\n",data_spec->Dim); if (data_spec->Dim) for (i_dim=0;i_dim<=data_spec->Dim[0];i_dim++) fprintf(out," Dim[%1lu] = %ld\n", i_dim,(data_spec->Dim)[i_dim]); fprintf(out," DataType = %u\n",data_spec->DataType); fprintf(out," ByteOrder = %u\n",data_spec->ByteOrder); fprintf(out," RasterConfiguration = %lu\n", data_spec->RasterConfiguration); fprintf(out," Compression = %u\n",data_spec->Compression); fprintf(out," %s\n",SeparationLine); } /* print_bsl_data_spec */ /*--------------------------------------------------------------------------- NAME print_bsl_frame_list --- prints frame list contents of ´memory´ SYNOPSIS void print_bsl_frame_list ( FILE * out, const BslMemory * memory, int level, int verbose ) ---------------------------------------------------------------------------*/ void print_bsl_frame_list ( FILE * out, const BslMemory * memory, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - -"; const BslFrame * frame; if (level<1) return; frame = memory->FrameList; while(frame!=(BslFrame*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," FrameKey = %s\n",frame->FrameKey); fprintf(out," DataSpec = %p\n",frame->DataSpec); print_bsl_data_spec ( out, frame->DataSpec ); fprintf(out," Previous FrameKey = "); if ((frame->Previous)!=(BslFrame*) NULL) fprintf(out,"%s\n", frame->Previous->FrameKey); else fprintf(out,"(no previous frame)\n"); fprintf(out," Next FrameKey = "); if ((frame->Next)!=(BslFrame*) NULL) fprintf(out,"%s\n", frame->Next->FrameKey); else fprintf(out,"(no next frame)\n"); fprintf(out," Owner Memory = %s\n",frame->Memory->MemoryKey); fprintf(out," %s\n",SeparationLine); } else { fprintf(out," FrameKey = '%s'\n",frame->FrameKey); } frame=frame->Next; } } /* print_bsl_frame_list */ /*--------------------------------------------------------------------------- NAME init_bsl_memory --- initialization of the bsl memory structure ---------------------------------------------------------------------------*/ void init_bsl_memory ( BslMemory * memory ) { memory->MemoryKey = (char *) NULL; memory->FileName = (char *) NULL; memory->Indicator = (char *) NULL; memory->FrameList = (BslFrame *) NULL; memory->Previous = (BslMemory *) NULL; memory->Next = (BslMemory *) NULL; memory->File = (BslFile *) NULL; } /* init_bsl_memory */ /*--------------------------------------------------------------------------- NAME new_bsl_memory --- creates a new bsl memory with name MemoryKey RETURN VALUE success: BslMemory * pointer to new bsl memory error: NULL pointer ---------------------------------------------------------------------------*/ BslMemory * new_bsl_memory ( const char * MemoryKey ) { BslMemory * newmemory; if ( (newmemory = (BslMemory*) malloc( sizeof(BslMemory) )) ) init_bsl_memory ( newmemory ); newmemory->MemoryKey = newstr_bsl(MemoryKey); return(newmemory); } /* new_bsl_memory */ /*--------------------------------------------------------------------------- NAME search_bsl_memory --- searches the bsl ´memory´ in the memory list of ´file´ SYNOPSIS BslMemory * search_bsl_memory ( BslFile * file, char * MemoryKey ) DESCRIPTION RETURN VALUE success BslMemory * found memory error NULL ---------------------------------------------------------------------------*/ BslMemory * search_bsl_memory ( BslFile * file, const char * MemoryKey ) { BslMemory * current = (BslMemory *) NULL; if (file == (BslFile *) NULL) return( current ); /* search memory */ current = file->MemoryList; if (current!=(BslMemory *) NULL ) while( ( current!=(BslMemory *) NULL ) && ( compare_bsl_keys(current->MemoryKey,MemoryKey,Bsl_UpperCase)!=0 ) ) { current = current->Next; } return( current ); } /* search_bsl_memory */ /*--------------------------------------------------------------------------- NAME insert_bsl_memory --- insert a bsl memory into the memory list of a bsl file SYNOPSIS BslMemory * insert_bsl_memory ( BslFile * file, const char * MemoryKey ) DESCRIPTION RETURN VALUE success: pointer to inserted memory error: NULL pointer ---------------------------------------------------------------------------*/ BslMemory * insert_bsl_memory ( BslFile * file, const char * MemoryKey ) { BslMemory *memory, *previous, *next, *newmemory; int notfound = -1; memory = (BslMemory *) NULL; previous = (BslMemory *) NULL; if ( file == (BslFile *) NULL ) return( memory ); /* search insertion point (insertion before *pnext) */ next = file->MemoryList; while( ( next!=(BslMemory *) NULL ) && (notfound<0) ) { notfound = compare_bsl_keys(next->MemoryKey,MemoryKey,Bsl_UpperCase); if (notfound<0) { previous = next; next = next->Next; } } /* create new memory, if no memory found */ if ( next==(BslMemory *) NULL ) { /* create new memory */ newmemory = new_bsl_memory ( MemoryKey ); if ( newmemory == (BslMemory *) NULL ) return( memory ); /* insert new memory before *pnext */ if (next) next->Previous = newmemory; newmemory->Next=next; newmemory->Previous=previous; if (previous) previous->Next=newmemory; else file->MemoryList=newmemory; /* link to owning file */ newmemory->File = file; next = newmemory; } memory = next; return( memory ); } /* insert_bsl_memory */ /*--------------------------------------------------------------------------- NAME remove_bsl_memory --- removes ´memory´ from the memory list SYNOPSIS void remove_bsl_memory ( BslMemory * memory ); DESCRIPTION The allocated memory of the contents of ´memory´ is removed. ´memory´ is removed from the memory list of the owning file. If ´memory´ was the only memory in ´memory->File->MemoryList´ ´memory->File->MemoryList´ is set to (BslMemory *) NULL. If ´memory´ is NULL, nothing is done. ---------------------------------------------------------------------------*/ void remove_bsl_memory ( BslMemory * memory ) { BslMemory **proot, *previous, *next; if (memory==(BslMemory*) NULL) return; proot = &(memory->File->MemoryList); previous = memory->Previous; next = memory->Next; remove_bsl_frame_list ( memory ); if (next!=(BslMemory*) NULL) next->Previous = previous; if (previous!=(BslMemory*) NULL) previous->Next = next; if (*proot==memory) { *proot = ((BslMemory*) NULL); } if (memory->MemoryKey) free(memory->MemoryKey); if (memory->FileName) free(memory->FileName); if (memory->Indicator) free(memory->Indicator); free(memory); return; } /* remove_bsl_memory */ /*--------------------------------------------------------------------------- NAME remove_bsl_memory_list --- empty the memory list of ´file´ SYNOPSIS void remove_bsl_memory_list ( BslFile * file ) ---------------------------------------------------------------------------*/ void remove_bsl_memory_list ( BslFile * file ) { BslMemory *memory, *next; if (file==(BslFile*) NULL) return; next = file->MemoryList; while ( next!=(BslMemory*) NULL ) { memory = next; next=next->Next; remove_bsl_memory ( memory ); } return; } /* remove_bsl_memory_list */ /*--------------------------------------------------------------------------- NAME print_bsl_memory_list --- prints bsl memory contents SYNOPSIS void print_bsl_memory_list ( FILE * out, const BslFile * file, int level, int verbose ); ---------------------------------------------------------------------------*/ void print_bsl_memory_list ( FILE * out, const BslFile * file, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - - - - - - - - - - - - - - - -"; BslMemory * memory; if (level<1) return; memory = file->MemoryList; while(memory!=(BslMemory*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," MemoryKey = %s\n",memory->MemoryKey); fprintf(out," FileName = \"%s\"\n",memory->FileName); fprintf(out," Indicator string = \n\"%s\"\n",memory->Indicator); fprintf(out," Previous MemoryKey = "); if ((memory->Previous)!=(BslMemory*) NULL) fprintf(out,"%s\n", memory->Previous->MemoryKey); else fprintf(out,"(no previous memory)\n"); fprintf(out," Next MemoryKey = "); if ((memory->Next)!=(BslMemory*) NULL) fprintf(out,"%s\n", memory->Next->MemoryKey); else fprintf(out,"(no next memory)\n"); // fprintf(out," Owner file = %#x\n",memory->File->Channel); fprintf(out," Owner file = %p\n",memory->File->Channel); fprintf(out," FrameList = %p\n",memory->FrameList); print_bsl_frame_list( out, memory, level-1, verbose ); fprintf(out," %s\n",SeparationLine); } else { /* short */ fprintf(out," MemoryKey = '%s'\n",memory->MemoryKey); print_bsl_frame_list( out, memory, level-1, verbose ); } memory=memory->Next; } } /* print_bsl_memory_list */ /*--------------------------------------------------------------------------- NAME print_bsl_filetable --- prints bsl file contents SYNOPSIS void print_bsl_filetable ( FILE * out, int level, int verbose ) ---------------------------------------------------------------------------*/ void print_bsl_filetable ( FILE * out, int level, int verbose ) { const char * SeparationLine = "========================================================="; int stream; if (level<1) return; if (!InitBslTable) { printf("Bsl file table is not initialized\n");return;} for (stream=0;streamIndicator´. ARGUMENTS const BslMemory * memory input memory RETURN VALUE long * error : (long *) NULL success : Dim Dim[0] : 2 = number of dimensions Dim[1] : number of elements in first dimension Dim[2] : number of elements in nn-th dimension ---------------------------------------------------------------------------*/ long * get_bsl_dim ( const BslMemory * memory ) { long * dim = (long *) NULL; long * indic; if (!memory) return( dim ); indic = indicator2table ( memory->Indicator ); if (!indic) return( dim ); if (indic[0]Indicator´. ARGUMENTS const BslMemory * memory input memory RETURN VALUE error : long int <0 success : long int number of frames ---------------------------------------------------------------------------*/ long get_bsl_number ( const BslMemory * memory ) { long * indic, number = -1l; if (!memory) return( number ); indic = indicator2table ( memory->Indicator ); if (!indic) return( number ); if (indic[0]FrameList´ is released. ARGUMENTS BslMemory * memory memory RETURN VALUE Success: int 0 error: int <0 ---------------------------------------------------------------------------*/ int indicator2frame_list ( BslMemory * memory ) { long number; /* number of frames */ BslFrame *frame; /* inserted frame */ char frame_key[MaxBslLineLen+1]; BslDataSpec *data_spec; /* data specification */ char fullname[BslBufferSize]; BslFile *file; int i; if (!memory) return(-1); file = memory->File; number = get_bsl_number ( memory ); if (number<0) return (-1); for (i=1;i<=number;i++) { sprintf(frame_key,"%d",i); frame = insert_bsl_frame ( memory, frame_key ); if (!frame) return(-1); data_spec = frame->DataSpec; data_spec->Dim = get_bsl_dim ( memory ); if (!data_spec->Dim) return(-1); sprintf( fullname, "%s%s", file->Path, memory->FileName ); data_spec->BinaryFileName = newstr_bsl ( fullname ); if (!data_spec->BinaryFileName) return(-1); data_spec->BinaryFileLen = (unsigned long) (sizeof(float)*data_spec->Dim[1]*data_spec->Dim[2]); data_spec->BinaryFilePos = (unsigned long) (sizeof(float)*data_spec->Dim[1]*data_spec->Dim[2]*(i-1)); } return(0); } /* indicator2frame_list */ /*--------------------------------------------------------------------------- NAME read_bsl_line --- read a single line of an bsl header SYNOPSIS char * read_bsl_line ( BslFile * file, int * io_error ); DESCRIPTION Reads a single line from ´file´, allocates memory for it and returns it. ARGUMENTS BslFile * file opened input file int * io_error returned error value from ferror RETURN VALUE Success: char * allocated string error: NULL pointer ---------------------------------------------------------------------------*/ char * read_bsl_line ( BslFile * file, int * io_error ) { const int buflen = BslBufferSize; static char buffer[BslBufferSize]; char * str = (char *) NULL; FILE * channel = file->Channel; fgets (buffer, buflen, channel); if (!feof( channel )) if (!(*io_error=ferror( channel ))) str = newstr_bsl(buffer); return( rmeoln(str) ); } /* read_bsl_line */ /*--------------------------------------------------------------------------- NAME read_bsl_header --- read a bsl header file SYNOPSIS int read_bsl_header ( BslFile * file ); DESCRIPTION Reads the bsl header from ´file´. The bsl header has the following structure: * line 1. Header with up to 80 alphanumeric characters. * line 2. Header with up to 80 alphanumeric characters. * line 3. Integer indicators for the first binary file indicator(1) = number of pixels (dim_1) indicator(2) = number of rasters (dim_2) indicator(3) = number of time frames (dim_3) indicator(4) = indicator(5) = indicator(6) = indicator(7) = indicator(8) = indicator(9) = indicator(10) = 1, except for the last binary file, when it is zero * line 4. File name of the binary file The lines 3 and 4 are repeated for subsequent binary files. The panel below shows an example of a header file with two binary files. RETURN VALUE Success: int 0 error: int <0 ---------------------------------------------------------------------------*/ int read_bsl_header ( BslFile * file ) { BslMemory * memory; char *indicator, *file_name; char memory_key[MaxBslLineLen+1]; long int memory_number=1; int io_error; if (!(file->FirstHeader =trim_bsl(read_bsl_line(file,&io_error)))) return(-1); if (!(file->SecondHeader=trim_bsl(read_bsl_line(file,&io_error)))) return(-1); do { if ( (indicator = read_bsl_line( file, &io_error )) ) if ( (file_name = read_bsl_line( file, &io_error )) ) { sprintf(memory_key,"%ld",memory_number++); memory = insert_bsl_memory ( file, memory_key ); if (!(memory)) return(-1); memory->FileName = trim_bsl(file_name); memory->Indicator = trim_bsl(indicator); if (indicator2frame_list ( memory )) return(-1); } //++++++++{+ } while (( memory_key ) && ( indicator )); // always true } while ( indicator ); if (io_error) return(-1); return(0); } /* read_bsl_header */ /*--------------------------------------------------------------------------- NAME free_bsl_file --- deallocates and reinitializes a bsl file. SYNOPSIS int free_bsl_file ( BslFile * file ); DESCRIPTION Deallocates all memory of a bsl file. If it is already done nothing happens. RETURN VALUE success: int 0 error: int -1 ---------------------------------------------------------------------------*/ int free_bsl_file ( BslFile * file ) { /* remove memory list */ remove_bsl_memory_list( file ); /* close file */ if (fclose(file->Channel)) return(-1); file->Channel = (FILE *) NULL; /* release IO-buffer */ free(file->Buffer); file->Buffer = (char *) NULL; /* release file name */ free(file->Name); file->Name = (char *) NULL; /* release path */ free(file->Path); file->Path = (char *) NULL; /* free first and second header */ if (file->FirstHeader) free ( file->FirstHeader ); if (file->SecondHeader) free ( file->SecondHeader ); init_bsl_file ( file ); return(0); } /* free_bsl_file */ /*--------------------------------------------------------------------------- NAME open_bsl_file --- opens a bsl file SYNOPSIS int open_bsl_file ( const char * FileName , const char * mode ); DESCRIPTION Opens a bsl header file and analyzes the structure. If the contents of the file does not contain in line 2+n*2+1 at least ´BslIndicNumber´ long integer values separated by white space, the reading of the file is stopped, all memory is released and a negative value is returned. ARGUMENTS const char * FileName name of the file that should be opened const char * mode opening mode: "old", "new", "any" RETURN VALUE success: int stream >= 0 file stream error: int stream < 0 ---------------------------------------------------------------------------*/ int open_bsl_file ( const char * FileName , const char * mode ) { int stream; BslFile *file; int buflen = BslBufferSize; char buffer[BslBufferSize]; if (!InitBslTable) init_bsl_file_table ( BslTable ); stream = search_free_bsl_stream ( BslTable ); if (stream<0) return( stream ); file = &BslTable[stream]; init_bsl_file ( file ); if (strcmp(mode,BslOld)==0) { /* open old file */ file->Channel = fopen( FileName,"rb+"); } else if (strcmp(mode,BslNew)==0) { /* open new file */ file->Channel = fopen( FileName,"wb+"); } else if (strcmp(mode,BslAny)==0) { /* open old file or create new file */ if ( (file->Channel = fopen( FileName,"rb+")) ) { } else { file->Channel = fopen( FileName,"wb+"); } } else if (strcmp(mode,BslRead)==0) { /* open old file read-only */ file->Channel = fopen( FileName,"rb"); } if (file->Channel == (FILE *) NULL) { free_bsl_file( file ); return(-1); } /* allocate IO-buffer */ file->Buffer = (char *) malloc(sizeof(char)*BslBufferSize); if ( file->Buffer == (char *) NULL ) { free_bsl_file( file ); return(-1); } if ( setvbuf(file->Channel, file->Buffer, _IOFBF, BslBufferSize) ) { free_bsl_file( file ); return(-1); } /* file structure parameters */ file->Name = newstr_bsl( FileName ); file->Path = newstr_bsl( getpath_bsl( buffer, buflen, FileName )); /* read header(s) and locate data */ if (read_bsl_header ( file )) { free_bsl_file( file ); return(-1); } return( stream ); } /* open_bsl_file */ /*--------------------------------------------------------------------------- NAME close_bsl_file --- closes a bsl file SYNOPSIS int close_bsl_file ( int stream ); DESCRIPTION Closes a bsl file. If it is already closed nothing happens. RETURN VALUE success: int 0 error: int -1 ---------------------------------------------------------------------------*/ int close_bsl_file ( int stream ) { return(free_bsl_file(&BslTable[stream])); } /* close_bsl_file */ /*--------------------------------------------------------------------------- NAME bsl_memory_range --- returns the number of memories in the bsl file SYNOPSIS int bsl_memory_range( int stream, long * minmem, long *maxmem ); DESCRIPTION Returns the minimum memory number (*minmem) and the maximum memory number (*maxmem) of the bsl. RETURN VALUE success: int 0 error: int -1 ---------------------------------------------------------------------------*/ int bsl_memory_range( int stream, long * minmem, long *maxmem ) { BslFile * file; BslMemory * memory; long memnum; file = &BslTable[stream]; if (!(file->Channel)) return(-1); /* file not opened */ memory = file->MemoryList; if (!memory) return(-1); /* file is empty */ *minmem = *maxmem = s2long_bsl( memory->MemoryKey ); while (memory) { memnum = s2long_bsl( memory->MemoryKey ); if (memnum<*minmem) *minmem = memnum; else if (memnum>*maxmem) *maxmem = memnum; memory = memory->Next; } return(0); } /* bsl_memory_range */ /*--------------------------------------------------------------------------- NAME bsl_frame_range --- returns the number of frames in a bsl memory SYNOPSIS int bsl_frame_range( int stream, long memnum, long * minfra, long * maxfra ); DESCRIPTION Returns the minimum frame number (*minfra) and the maximum memory number (*maxfra) of the bsl memory with number ´memnum´. RETURN VALUE success: int 0 error: int -1 ---------------------------------------------------------------------------*/ int bsl_frame_range( int stream, long memnum, long * minfra, long * maxfra ) { BslFile * file; BslMemory * memory; BslFrame * frame; char memory_key[MaxBslLineLen+1]; long franum; file = &BslTable[stream]; if (!(file->Channel)) return(-1); /* file not opened */ sprintf(memory_key,"%ld",memnum); memory = search_bsl_memory ( file, memory_key ); if (!memory) return(-1); /* file is empty */ frame = memory->FrameList; if (!frame) return(-1); /* memory is empty */ *minfra = *maxfra = s2long_bsl( frame->FrameKey ); while (frame) { franum = s2long_bsl( frame->FrameKey ); if (franum<*minfra) *minfra = franum; else if (franum>*maxfra) *maxfra = franum; frame = frame->Next; } return(0); } /* bsl_frame_range */ /*--------------------------------------------------------------------------- NAME read_bsl_file_headers --- read the first and second header SYNOPSIS # include "edfio.h" void read_bsl_file_headers ( int stream, char **first_header, char **second_header ); DESCRIPTION Pointer to the first and second file header lines are returned. These pointers remain valid until the bsl file is closed. ---------------------------------------------------------------------------*/ void read_bsl_file_headers ( int stream, char **first_header, char **second_header ) { BslFile * file; *first_header = (char *) NULL; *second_header = (char *) NULL; file = &(BslTable[stream]); if (!(file->Channel)) return; /* file not opened */ *first_header = file->FirstHeader; *second_header = file->SecondHeader; } /* read_bsl_file_headers */ /*--------------------------------------------------------------------------- NAME read_bsl_data_spec --- read data spec of frame ´franum´ in memory ´memnum´ SYNOPSIS # include "edfio.h" BslDataSpec * read_bsl_data_spec ( int stream, long memnum, long franum ); DESCRIPTION RETURN VALUE success BslDataSpec * pointer to data spec of frame ´franum´ in memory ´memnum´ error NULL pointer ---------------------------------------------------------------------------*/ BslDataSpec * read_bsl_data_spec ( int stream, long memnum, long franum ) { BslFile * file; BslMemory * memory; BslFrame * frame; char memory_key[MaxBslLineLen+1]; char frame_key[MaxBslLineLen+1]; file = &(BslTable[stream]); if (!(file->Channel)) return((BslDataSpec *) NULL); /* file not opened */ sprintf(memory_key,"%ld",memnum); memory = search_bsl_memory ( file, memory_key ); if (!memory) return((BslDataSpec *) NULL); /* memory not found */ sprintf(frame_key,"%ld",franum); frame = search_bsl_frame ( memory, frame_key ); if (!frame) return((BslDataSpec *) NULL); /* frame not found */ return( frame->DataSpec ); } /* read_bsl_data_spec */ /******************************************************************************/ spd-1.3.0/edfpack/ipol.c0000644000175000017500000014431711633462461011746 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define IPOL_VERSION "ipol : V1.7 Peter Boesecke 2010-09-29" /*+++------------------------------------------------------------------------ NAME ipol --- interpolation routines SYNOPSIS # include ipol.h DESCRIPTION The module does not used externally defined routines and does not need to be linked to external libraries. HISTORY 2005-12-04 V1.0 Extracted from SaxsRoutines V1.38 2005-12-09 V1.1 Array and dummy definitions from SaxsDefinitions. Isum2ldw and Isum2ldwE: IPOL_ANTIALIASED 2006-05-16 V1.2 Isum2ldw and Isum2ldwE: in vicinity to dummies *weight can be zero if IPOL_ANTIALIASED is set, even if cnt is not zero. cnt is now explicitely set to 0 if *weight is 0. 2007-02-26 V1.3 IpolRebin2 added 2007-04-19 V1.4 code corrected to avoid compiler warnings with -Wall 2008-05-25 V1.5 Isum2ldwE (calculation of varsum): if VarDat is NULL pvarval is not incremented and points always to 0, unused variable pvarstart has been removed. Isum2ldwEw (weighted sum), Isum2ldwE renamed to Isum2ldwEe. Isum2ldwE uses Isum2ldwEe or Isum2ldwEw depending on the switch variable IPolWeight. 2008-05-27 V1.6 IPolMin: minimum coverage ratio of all non-dummy input pixels to the output pixel. If IPolMin*the output pixel area is larger than the sum of all contributing input pixel areas, the calculated value is rejected (cnt=0). To do: the weight mode should also be used for rebinning, probably better: pixels covering regions fully inside the output pixel should not be rejected, i.e. that are contributing with 100%. 2010-09-29 V1.7 IDX redefined using floor function DESCRIPTION ----------------------------------------------------------------------------*/ /****************************************************************************** * Include Files * ******************************************************************************/ # include "ipol.h" /****************************************************************************** * Private Macros * ******************************************************************************/ /****************************************************************************** * Private Variables * ******************************************************************************/ PRIVATE int IPolMode = IPOL_NORMAL; PRIVATE int IPolWeight = IPOL_EQUAL; PRIVATE float IPolMin = 0.5; // Minimum ratio of output to input pixel size /****************************************************************************** * Routines * ******************************************************************************/ /*--------------------------------------------------------------------------- NAME Ipolmode --- set/return interpolation mode DESCRIPTION Sets the interpolation mode and returns its new value: IPOL_NORMAL: normal, IPOL_ANTIALIASED: anti-aliased If the input value is 0 only the current mode is returned. ---------------------------------------------------------------------------*/ int Ipolmode ( int mode ) { switch (mode ) { case IPOL_NORMAL: IPolMode = IPOL_NORMAL; break; case IPOL_ANTIALIASED: IPolMode = IPOL_ANTIALIASED; break; } return ( IPolMode ); } /* Ipolmode */ const char *Ipolmode2str ( int mode ) { switch (mode ) { case IPOL_NORMAL: return("normal"); case IPOL_ANTIALIASED: return("antialiased"); default: return("undefined"); } } /* Ipolmode2str */ /*--------------------------------------------------------------------------- NAME Ipolweight --- set/return weight method DESCRIPTION Sets the method of weighting of data points and returns the new value: IPOL_EQUAL: each data point has equal weight, IPOL_WEIGHTED: each point is weighted with its inverse variance If the input value is 0 only the current method is returned. ---------------------------------------------------------------------------*/ int Ipolweight ( int method ) { switch (method ) { case IPOL_EQUAL: IPolWeight = IPOL_EQUAL; break; case IPOL_WEIGHTED: IPolWeight = IPOL_WEIGHTED; break; } return ( IPolWeight ); } /* Ipolweight */ const char *Ipolweight2str ( int method ) { switch (method ) { case IPOL_EQUAL: return("equal"); case IPOL_WEIGHTED: return("weighted"); default: return("undefined"); } } /* Ipolweight2str */ /*--------------------------------------------------------------------------- NAME Ipolmin --- set/return minimum ratio between input and output pixel area DESCRIPTION Sets the minimum accepted ratio between input and output pixel area If not used the default setting is 0.5. If the input value is negative only the actually used value is returned. ---------------------------------------------------------------------------*/ float Ipolmin ( float minimum ) { if (minimum>=0.0) IPolMin = minimum; return ( IPolMin ); } /* Ipolmin */ /*--------------------------------------------------------------------------- NAME Isum2ldwEw --- Weighted pixel area integral with variance array PURPOSE Like Isum2ldwEw but each point is additionally weighted with 1/variance. DESCRIPTION The output value "sum" is the weighted area integral of all pixel values in the region between (f1_1,f1_2) and (f3_1,f3_2). If one of the pixels lies outside the range of the image or if it is a dummy it is ignored (wi=0): All pixels are weighted with 1/variance. If at least one pixel of the sum has zero variance only the pixels with variance 0 will contribute to the sum according to the covered area. The output value "varsum" is the area integral of all variance values in the same region weighted with 1/variance. It is effectively the sum of all contributing pixels. If the variance value of at least one non-dummy pixel in the region is negative "varsum" cannot be calculated and is set to -1.0. area = (f1_2-f1_1)*(f3_2,f3_1) sum = vsign * Sum(Ii*wi/Ei)/Mean(1/Ei) (vsign * Sum(Ii*wi) if one of the Ei is 0) weight = vsign * Sum(wi/Ei)/Mean(1/Ei) (vsign * Sum(wi) if one of the Ei is 0) varsum = Sum(wi)/Mean(1/Ei) (Sum(Ei*wi) if one of the Ei is 0) or -1.0 if it cannot be calculated varweight = Sum(wi/Ei)/Mean(1/Ei) (Sum(wi) if one of the Ei is 0) cnt = number of contributing intensity values where Mean(1/Ei) = Sum(1/Ei)/cnt wi = overlap area of pixel i with [(f1_1,f1_2)..(f3_1,f3_2)] For non-zero weight, the averaged values are Sum(Ii*wi/Ei)/Sum(wi/Ei) and Sum(wi)/Sum(wi/Ei). vsign takes into account the direction of integration. If the integration along a single axis is done from positive to negative coordinates vsign is negative, otherwise positive. The variance values are always positive, independent of the integration direction. If the variance sum varsum is negative it is invalid. If VarDat is NULL, sum, weight and varweight are calculated, varsum is 0.0 for all non-dummy pixels inside the array and negative for all pixels outside the array. SYNOPSIS int Isum2ldwEw ( float *Data, float *VarDat, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight, float *varsum, float *varweight); return value (o) : number of pixels contributing to the output value (0..4), if 0, no valid data point found. float Data[Dim_1,Dim_2] (i) : input data array float VarDat[Dim_1,Dim_2] (i) : input variance array int Dim_1, Dim_2 (i) : dimension of array float Dummy, DDummy (i) : dummy specification float f1_1, f1_2 (i) : index coordinate of lower left corner float f3_1, f3_2 (i) : index coordinate of upper right corner float *sum (o) : area integral of data array (Data) float *weight (o) : area of contributing pixels to sum float *varsum (o) : area integral of variance array (VarDat) *varsum is set to -1.0 if one of the contributing non-dummy pixels is negative. float *varweight (o) : area of contributing pixels ---------------------------------------------------------------------------*/ int Isum2ldwEw ( float *Data, float *VarDat, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight, float *varsum, float *varweight) { // const float eps = IPOLEPS; // unused int cnt, varcnt; float *pval, *pstart; float *pvarval, varval, invvarval, wdvarval; float vsign=1.0, vvar=1.0; float w; float w1_1,w1_2,w3_1,w3_2; float null = 0.0; float weightv, sumv, varsumv; int cntv, varcntv; float suminvvar, meaninvvar; int varflag = 1; // set to 0 if one of the variances is 0 int i_1, i_2; int i1_1, i1_2, i3_1, i3_2; float Df_1, Df_2, Df_12; float Df_1A, Df_2A, Df_12A; float f_1A, f_2A; float tmp; Df_1 = f3_1-f1_1; Df_2 = f3_2-f1_2; Df_12 = Df_1*Df_2; /* sort range */ if (Df_1<0) {tmp=f1_1;f1_1=f3_1;f3_1=tmp;vsign*=-1.0;Df_1=-Df_1;} if (Df_2<0) {tmp=f1_2;f1_2=f3_2;f3_2=tmp;vsign*=-1.0;Df_2=-Df_2;} *weight=0.0; *varweight=0.0; *sum=0.0; *varsum=-1.0; cnt=0; varcnt=0; weightv = 0.0; sumv = 0.0; varsumv = 0.0; cntv = 0; varcntv = 0; suminvvar = 0.0; if (!Data) return(cnt); // return, if NULL pointer if (IPolMode == IPOL_ANTIALIASED) { /* Increase the integration range in both directions to 1. For renormalization of the results adjust vsign. */ if (Df_1<=1.0) { Df_1A = 1.0; f_1A = 0.5*(f1_1+f3_1); f1_1 =f_1A-0.5;f3_1=f_1A+0.5; } else Df_1A = Df_1; if (Df_2<=1.0) { Df_2A = 1.0; f_2A = 0.5*(f1_2+f3_2); f1_2 =f_2A-0.5;f3_2=f_2A+0.5; } else Df_2A = Df_2; Df_12A = Df_1A*Df_2A; if (Df_12A == 0.0) return(cnt); tmp = Df_12/Df_12A; vvar *= tmp; vsign *= tmp; } /* Add 0.5 to exclude negative array indices */ f1_1+=0.5; f1_2+=0.5; f3_1+=0.5; f3_2+=0.5; // Lower left edge f1, w1_i is the overlap area of pixel p1 // All w1_i are positive: 0<=w1_i<=1.0 i1_1 = floor(f1_1); if (i1_1 >= 0 ) w1_1 = 1.0 - (f1_1 - i1_1); else {i1_1 = 0; w1_1 = 1.0; } i1_2 = floor(f1_2); if (i1_2 >= 0 ) w1_2 = 1.0 - (f1_2 - i1_2); else {i1_2 = 0; w1_2 = 1.0; } // upper right edge f3, w3_i is the overestimated area of pixel p3 // All w3_i are negative or zero: -1.0<=w3_i<=0.0 i3_1 = ceil(f3_1); if (i3_1<=Dim_1) w3_1 = f3_1 - i3_1; else { i3_1 = Dim_1; w3_1 = 0.0; } i3_2 = ceil(f3_2); if (i3_2<=Dim_2) w3_2 = f3_2 - i3_2; else { i3_2 = Dim_2; w3_2 = 0.0; } // Stop, if already the lower left pixel p1 lies outside the array. // or if upper right pixel lies outside the array. if ((i1_1>=Dim_1)||((i1_2>=Dim_2))||(i3_1<0)||(i3_2<0)) return(cnt); pvarval = &null; // if VarDat is NULL *varsum = 0.0; cntv = 0; suminvvar = 0.0; weightv = 0.0; sumv = 0.0; varcntv = 0; varsumv = 0.0; varflag = 1; // set to 0 if one of the variances is 0 // p1 (lower left pixel) pstart = pval = ABSPTR(Data,Dim_1,Dim_2,i1_1,i1_2); if (VarDat) pvarval = VarDat-Data+pval; w = w1_1*w1_2; if NODUMMY(*pval,Dummy,DDummy) { varval=*pvarval; if (varval==0.0) { cnt++; *weight+=w; *sum+=*pval*w; //*varsum+=varval*w; varcnt++; varflag=0; } else { if ((varflag)&&(varval>0)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } // lower line between p1 and p2 for (i_1=i1_1+1;i_10)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } } // p2 (correct overestimation) w = w3_1*w1_2; if NODUMMY(*pval,Dummy,DDummy) { varval=*pvarval; if (varval==0.0) { cnt++; *weight+=w; *sum+=*pval*w; //*varsum+=varval*w; varcnt++; varflag=0; } else { if ((varflag)&&(varval>0)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } for (i_2=i1_2+1;i_20)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } // line for (i_1=i1_1+1;i_10)) { invvarval=1.0/varval; cntv++; weightv+=invvarval; sumv+=*pval*invvarval; suminvvar+=invvarval; varsumv+=1.0; varcntv++; } } } } // last column (correct overestimation) w=w3_1; if NODUMMY(*pval,Dummy,DDummy) { varval=*pvarval; if (varval==0.0) { cnt++; *weight+=w; *sum+=*pval*w; //*varsum+=varval*w; varcnt++; varflag=0; } else { if ((varflag)&&(varval>0)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } } // p4 (correct overestimation) pval = pstart; if (VarDat) pvarval = VarDat-Data+pval; w = w1_1*w3_2; if NODUMMY(*pval,Dummy,DDummy) { varval=*pvarval; if (varval==0.0) { cnt++; *weight+=w; *sum+=*pval*w; //*varsum+=varval*w; varcnt++; varflag=0; } else { if ((varflag)&&(varval>0)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } // upper line between p4 and p3 (correction) for (i_1=i1_1+1;i_10)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } } // p3 (correct underestimation) w = w3_1*w3_2; if NODUMMY(*pval,Dummy,DDummy) { varval=*pvarval; if (varval==0.0) { cnt++; *weight+=w; *sum+=*pval*w; //*varsum+=varval*w; varcnt++; varflag=0; } else { if ((varflag)&&(varval>0)) { invvarval=1.0/varval; wdvarval=w*invvarval; cntv++; weightv+=wdvarval; sumv+=*pval*wdvarval; suminvvar+=invvarval; varsumv+=w; varcntv++; } } } if (varflag) { meaninvvar = suminvvar/cntv; cnt = cntv; varcnt = varcntv; *sum = sumv/meaninvvar; *weight = weightv/meaninvvar; *varsum = varsumv/meaninvvar; } *sum *= vsign; *weight *= vsign; if (varcnt!=cnt) *varsum = -1.0; else *varsum *= vvar; *varweight = fabs(*weight); // *weight can apparently be zero when cnt is not if IPOL_ANTIALIASED is set if (fabs(*weight)<1e-32) cnt=0; else // reject pixels with less than IPolMin coverage if ( fabs(Df_12)*IPolMin > fabs(*weight) ) cnt=0; return(cnt); } /* Isum2ldwEw */ /*--------------------------------------------------------------------------- NAME Isum2ldwEe--- Pixel area integral with variance array PURPOSE Like Isum2ldw but additionally with calculation of variance array. DESCRIPTION The output value "sum" is the area integral of all pixel values in the region between (f1_1,f1_2) and (f3_1,f3_2). If one of the pixels lies outside the range of the image or if it is a dummy it is ignored (wi=0): The output value "varsum" is the area integral of all variance values in the same region. If the variance value of at least one non-dummy pixel in the region is negative "varsum" cannot be calculated and is set to -1.0. area = (f1_2-f1_1)*(f3_2,f3_1) sum = vsign * Sum(Ii*wi) weight = vsign * Sum(wi) varsum = Sum(Ei*wi) or -1.0 if it cannot be calculated varweight = Sum(wi) cnt = number of contributing intensity values wi = overlap area of pixel i with [(f1_1,f1_2)..(f3_1,f3_2)] For non-zero weight, the averaged values are Sum(Ii*wi)/Sum(wi) and Sum(Ei*wi)/Sum(wi). vsign takes into account the direction of integration. If the integration along a single axis is done from positive to negative coordinates vsign is negative, otherwise positive. The variance values are always positive, independent of the integration direction. If the variance sum varsum is negative it is invalid. If VarDat is NULL, sum, weight and varweight are calculated, varsum is 0.0 for all non-dummy pixels inside the array and negative for all pixels outside the array. SYNOPSIS int Isum2ldwEe ( float *Data, float *VarDat, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight, float *varsum, float *varweight); return value (o) : number of pixels contributing to the output value (0..4), if 0, no valid data point found. float Data[Dim_1,Dim_2] (i) : input data array float VarDat[Dim_1,Dim_2] (i) : input variance array int Dim_1, Dim_2 (i) : dimension of array float Dummy, DDummy (i) : dummy specification float f1_1, f1_2 (i) : index coordinate of lower left corner float f3_1, f3_2 (i) : index coordinate of upper right corner float *sum (o) : area integral of data array (Data) float *weight (o) : area of contributing pixels to sum float *varsum (o) : area integral of variance array (VarDat) *varsum is set to -1.0 if one of the contributing non-dummy pixels is negative. float *varweight (o) : area of contributing pixels ---------------------------------------------------------------------------*/ int Isum2ldwEe ( float *Data, float *VarDat, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight, float *varsum, float *varweight) { // const float eps = IPOLEPS; // unused int cnt, varcnt; float *pval, *pstart; float *pvarval; float vsign=1.0, vvar=1.0; float w; float w1_1,w1_2,w3_1,w3_2; float null = 0.0; int i_1, i_2; int i1_1, i1_2, i3_1, i3_2; float Df_1, Df_2, Df_12; float Df_1A, Df_2A, Df_12A; float f_1A, f_2A; float tmp; Df_1 = f3_1-f1_1; Df_2 = f3_2-f1_2; Df_12 = Df_1*Df_2; /* sort range */ if (Df_1<0) {tmp=f1_1;f1_1=f3_1;f3_1=tmp;vsign*=-1.0;Df_1=-Df_1;} if (Df_2<0) {tmp=f1_2;f1_2=f3_2;f3_2=tmp;vsign*=-1.0;Df_2=-Df_2;} *weight=0.0; *varweight=0.0; *sum=0.0; *varsum=-1.0; cnt=0; varcnt=0; if (!Data) return(cnt); // return, if NULL pointer if (IPolMode == IPOL_ANTIALIASED) { /* Increase the integration range in both directions to 1. For renormalization of the results adjust vsign. */ if (Df_1<=1.0) { Df_1A = 1.0; f_1A = 0.5*(f1_1+f3_1); f1_1 =f_1A-0.5;f3_1=f_1A+0.5; } else Df_1A = Df_1; if (Df_2<=1.0) { Df_2A = 1.0; f_2A = 0.5*(f1_2+f3_2); f1_2 =f_2A-0.5;f3_2=f_2A+0.5; } else Df_2A = Df_2; Df_12A = Df_1A*Df_2A; if (Df_12A == 0.0) return(cnt); tmp = Df_12/Df_12A; vvar *= tmp; vsign *= tmp; } /* Add 0.5 to exclude negative array indices */ f1_1+=0.5; f1_2+=0.5; f3_1+=0.5; f3_2+=0.5; // Lower left edge f1, w1_i is the overlap area of pixel p1 // All w1_i are positive: 0<=w1_i<=1.0 i1_1 = floor(f1_1); if (i1_1 >= 0 ) w1_1 = 1.0 - (f1_1 - i1_1); else {i1_1 = 0; w1_1 = 1.0; } i1_2 = floor(f1_2); if (i1_2 >= 0 ) w1_2 = 1.0 - (f1_2 - i1_2); else {i1_2 = 0; w1_2 = 1.0; } // upper right edge f3, w3_i is the overestimated area of pixel p3 // All w3_i are negative or zero: -1.0<=w3_i<=0.0 i3_1 = ceil(f3_1); if (i3_1<=Dim_1) w3_1 = f3_1 - i3_1; else { i3_1 = Dim_1; w3_1 = 0.0; } i3_2 = ceil(f3_2); if (i3_2<=Dim_2) w3_2 = f3_2 - i3_2; else { i3_2 = Dim_2; w3_2 = 0.0; } // Stop, if already the lower left pixel p1 lies outside the array. // or if upper right pixel lies outside the array. if ((i1_1>=Dim_1)||((i1_2>=Dim_2))||(i3_1<0)||(i3_2<0)) return(cnt); pvarval = &null; // if VarDat is NULL *varsum = 0.0; // p1 (lower left pixel) pstart = pval = ABSPTR(Data,Dim_1,Dim_2,i1_1,i1_2); if (VarDat) pvarval = VarDat-Data+pval; w = w1_1*w1_2; if NODUMMY(*pval,Dummy,DDummy) { cnt++; *weight+=w; *sum+=*pval*w; if (*pvarval>=0) { *varsum+=*pvarval*w; varcnt++; } } // lower line between p1 and p2 for (i_1=i1_1+1;i_1=0) { *varsum+=*pvarval*w1_2; varcnt++; } } } // p2 (correct overestimation) w = w3_1*w1_2; if NODUMMY(*pval,Dummy,DDummy) { cnt++; *weight+=w; *sum+=*pval*w; if (*pvarval>=0) { *varsum+=*pvarval*w; varcnt++; } } for (i_2=i1_2+1;i_2=0) { *varsum+=*pvarval*w1_1; varcnt++; } } // line for (i_1=i1_1+1;i_1=0) { *varsum+=*pvarval; varcnt++; } } } // last column (correct overestimation) if NODUMMY(*pval,Dummy,DDummy) { cnt++; *weight+=w3_1; *sum+=*pval*w3_1; if (*pvarval>=0) { *varsum+=*pvarval*w3_1; varcnt++; } } } // p4 (correct overestimation) pval = pstart; if (VarDat) pvarval = VarDat-Data+pval; w = w1_1*w3_2; if NODUMMY(*pval,Dummy,DDummy) { cnt++; *weight+=w; *sum+=*pval*w; if (*pvarval>=0) { *varsum+=*pvarval*w; varcnt++; } } // upper line between p4 and p3 (correction) for (i_1=i1_1+1;i_1=0) { *varsum+=*pvarval*w3_2; varcnt++; } } } // p3 (correct underestimation) w = w3_1*w3_2; if NODUMMY(*pval,Dummy,DDummy) { cnt++; *weight+=w; *sum+=*pval*w; if (*pvarval>=0) { *varsum+=*pvarval*w; varcnt++; } } *sum *= vsign; *weight *= vsign; if (varcnt!=cnt) *varsum = -1.0; else *varsum *= vvar; *varweight = fabs(*weight); // *weight can apparently be zero when cnt is not if IPOL_ANTIALIASED is set if (fabs(*weight)<1e-32) cnt=0; else // reject pixels with less than IPolMin coverage if ( fabs(Df_12)*IPolMin > fabs(*weight) ) cnt=0; return(cnt); } /* Isum2ldwEe*/ /*--------------------------------------------------------------------------- NAME Isum2ldwE --- Pixel area integral with variance array PURPOSE Use Isum2ldwEe or Isum2ldwEw depending on IPolWeight. DESCRIPTION See Isum2ldwEe and Isum2ldwEw. ---------------------------------------------------------------------------*/ int Isum2ldwE ( float *Data, float *VarDat, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight, float *varsum, float *varweight) { int cnt=0; switch (IPolWeight) { case IPOL_EQUAL: cnt = Isum2ldwEe ( Data, VarDat, Dim_1, Dim_2, Dummy, DDummy, f1_1, f1_2, f3_1, f3_2, sum, weight, varsum, varweight); break; case IPOL_WEIGHTED: cnt = Isum2ldwEw ( Data, VarDat, Dim_1, Dim_2, Dummy, DDummy, f1_1, f1_2, f3_1, f3_2, sum, weight, varsum, varweight); break; } return( cnt ); } // Isum2ldwE /*--------------------------------------------------------------------------- NAME Isum2ldw --- Pixel area integral PURPOSE Area integral of the array Data between index coordinate (f1_1,f1_2) and index coordinate (f3_1,f3_2). Dummy values and array limits are checked. The contributing area is returned in weight. The intensity value per pixel area is sum divided by weight. The return value of the function is the number of contributing pixels. A call with (f3_1,f3_2) = (f1_1+1,f1_2+1) corresponds to a call to Ipol2ldw with (f_1,f_2) = (f1_1+0.5,f1_2+0.5). See also Ipol2ldw. If the interpolation mode is IPOL_ANTIALIASED (default), the minimum side length of an integration area is 1. Smaller side lengths are increased to 1 and the results are renomalized to match the original side lengths. DESCRIPTION The output value "sum" is the area integral of all pixel values in the region between (f1_1,f1_2) and (f3_1,f3_2). If one of the pixels lies outside the range of the image or if it is a dummy it is ignored (wi=0): sum = Sum(Ii*wi) weight = Sum(wi) cnt = number of contributing intensity values wi = overlap area of pixel i with [(f1_1,f1_2)..(f3_1,f3_2)] For non-zero weight, the averaged value is Sum(Ii*wi)/Sum(wi). --------------------- --------------------- --------------------- f3_2 - | ******| |*******************| |************** | | ******|.|*******************|.|************** | | p4- -*-*-*-|.|-*-*-*-*-*-*-*-*-*-|.|-*-*-*-*p3**** | | | ******|.|*******************|.|*********|**** | | ******| |*******************| |************** | --------------------- --------------------- --------------------- ... ... ... --------------------- --------------------- --------------------- | ******| |*******************| |*********|**** | f = *** | | ******|.|*******************|.|************** | | ******|.|*******************|.|*********|**** | | | ******|.|*******************|.|************** | | ******| |*******************| |*********|**** | --------------------- --------------------- --------------------- ... ... ... --------------------- --------------------- --------------------- f1_2 - | ******| |*******************| |************** | | | |.| |.| | | | p1- - - - -|.|- - - - - - - - - -|.|- - - - p2 | | |.| |.| | | | | | | | --------------------- --------------------- --------------------- | | f1_1 f3_1 SYNOPSIS int Isum2ldw ( float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight); return value (o) : number of pixels contributing to the output value (0..4), if 0, no valid data point found. float Data[Dim_1,Dim_2] (i) : input array int Dim_1, Dim_2 (i) : dimension of array float Dummy, DDummy (i) : dummy specification float f1_1, f1_2 (i) : index coordinate of lower left corner float f3_1, f3_2 (i) : index coordinate of upper right corner float *sum (o) : area integral of Data array float *weight (o) : area of contributing pixels ---------------------------------------------------------------------------*/ int Isum2ldw ( float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f1_1, float f1_2, float f3_1, float f3_2, float *sum, float *weight) { // const float eps = IPOLEPS; // unused int cnt=0; float *pval, *pstart; float vsign=1.0; float w; float w1_1,w1_2,w3_1,w3_2; int i_1, i_2; int i1_1, i1_2, i3_1, i3_2; float Df_1, Df_2, Df_12; float Df_1A, Df_2A, Df_12A; float f_1A, f_2A; float tmp; Df_1 = f3_1-f1_1; Df_2 = f3_2-f1_2; Df_12 = Df_1*Df_2; /* use faster routine Ipol2ldw, if area size is 1x1 */ if ((Df_1==1.0)&&(Df_2==1.0)) return(Ipol2ldw(Data,Dim_1,Dim_2,Dummy,DDummy,f1_1+0.5,f1_2+0.5,sum,weight)); /* sort range */ if (Df_1<0) {tmp=f1_1;f1_1=f3_1;f3_1=tmp;vsign*=-1.0;Df_1=-Df_1;} if (Df_2<0) {tmp=f1_2;f1_2=f3_2;f3_2=tmp;vsign*=-1.0;Df_2=-Df_2;} *weight=0.0; *sum=0.0; cnt=0; if (!Data) return(cnt); // return, if NULL pointer if (IPolMode == IPOL_ANTIALIASED) { /* Increase the integration range in both directions to 1. For renormalization of the results adjust vsign. */ if (Df_1<=1.0) { Df_1A = 1.0; f_1A = 0.5*(f1_1+f3_1); f1_1 =f_1A-0.5;f3_1=f_1A+0.5; } else Df_1A = Df_1; if (Df_2<=1.0) { Df_2A = 1.0; f_2A = 0.5*(f1_2+f3_2); f1_2 =f_2A-0.5;f3_2=f_2A+0.5; } else Df_2A = Df_2; Df_12A = Df_1A*Df_2A; if (Df_12A == 0.0) return(cnt); vsign*=Df_12/Df_12A; } /* Add 0.5 to exclude negative array indices */ f1_1+=0.5; f1_2+=0.5; f3_1+=0.5; f3_2+=0.5; // Lower left edge f1, w1_i is the overlap area of pixel p1 // All w1_i are positive: 0<=w1_i<=1.0 i1_1 = floor(f1_1); if (i1_1 >= 0 ) w1_1 = 1.0 - (f1_1 - i1_1); else {i1_1 = 0; w1_1 = 1.0; } i1_2 = floor(f1_2); if (i1_2 >= 0 ) w1_2 = 1.0 - (f1_2 - i1_2); else {i1_2 = 0; w1_2 = 1.0; } // upper right edge f3, w3_i is the overestimated area of pixel p3 // All w3_i are negative or zero: -1.0<=w3_i<=0.0 i3_1 = ceil(f3_1); if (i3_1<=Dim_1) w3_1 = f3_1 - i3_1; else { i3_1 = Dim_1; w3_1 = 0.0; } i3_2 = ceil(f3_2); if (i3_2<=Dim_2) w3_2 = f3_2 - i3_2; else { i3_2 = Dim_2; w3_2 = 0.0; } // Stop, if already the lower left pixel p1 lies outside the array. // or if upper right pixel lies outside the array. if ((i1_1>=Dim_1)||((i1_2>=Dim_2))||(i3_1<0)||(i3_2<0)) return(cnt); // p1 (lower left pixel) pstart = pval = ABSPTR(Data,Dim_1,Dim_2,i1_1,i1_2); w = w1_1*w1_2; if NODUMMY(*pval,Dummy,DDummy) { cnt++; *weight+=w; *sum+=*pval*w; } // lower line between p1 and p2 for (i_1=i1_1+1;i_1 fabs(*weight) ) cnt=0; return(cnt); } /* Isum2ldw */ /*--------------------------------------------------------------------------- NAME Ipol2ldw --- Linear two dimensional interpolation PURPOSE Linear two dimensional interpolation including dummies with limit checks Ipol2ldw calculates the weighted sum and the sum of the weights of the contributing pixels. The array limits are checked. To calculate the interpolated value, sum must be devided by weight. The function returns the number of contributing pixels. See also Ipol2ld. The result corresponds to Isum2ldw(...,f_1-0.5,f_2-0.5,f_1+0.5,f_2+0.5,...). DESCRIPTION The output value "sum" is the weighted sum of the intensities of the 4 closest pixels p1 to p4 around pixel f. Pixel f is located at (f_1,f_2). The values of the pixels p1=Data[i_1,i_2], p2=Data[i_1+1,i_2], p3=Data[i_1+1,i_2+1] and p4=Data[I_1,i_2+1] are multiplied by the overlap areas wi of each pixel with the pixel f and added. The overlap areas w1 to w4 are calculated from the displacement r_1 and r_2 of f from p1. If one of the 4 pixels lies outside the range of the image or if it is a dummy it is ignored (wi=0): sum = Sum(Ii*wi) weight = Sum(wi) cnt = number of used intensity values w1 = (1-r_1)*(1-r_2) w2 = r_1*(1-r_2) w3 = r_1*r_2 w4 = (1-r_1)*r_2 with r_1 = f_1 - floor(f_1) and r_2 = f_2 - floor(f_2) For non-zero weight, the averaged value is Sum(Ii*wi)/Sum(wi). ----------------------------------------- | //////|************** | | //////|************** | w4 = /// | p4- -/-/-/-|-*-*-*-*p3**** | w3 = *** f_2 ----| | //////|***f*****|**** | ^ | //////|************** | | ----------------------------------------- w1 = +++ |r_2| ++++++|\\\\\\\\\\\\\\ | w2 = \\\ v | | | | | floor(f_2)-----| p1- - - - -|- - - - p2 | | | | | | | ----------------------------------------- | r_1 | |<----------->| | floor(f_1) f_1 SYNOPSIS int Ipol2ldw (float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f_1, float f_2, float *sum, float *weight) return value (o) : number of pixels contributing to the output value (0..4), if 0, no valid data point found. float Data[Dim_1,Dim_2] (i) : input array int Dim_1, Dim_2 (i) : dimension of array float Dummy, DDummy (i) : dummy specification float f_1, f_2 (i) : program array indices (interpolation point) float *sum (o) : weighted sum of interpolated pixels float *weight (o) : weight of sum minimum 0.0: no valid pixel found maximum 1.0: interpolation between 1 to 4 distance weighted pixels ---------------------------------------------------------------------------*/ int Ipol2ldw (float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f_1, float f_2, float *sum, float *weight ) { const float eps = IPOLEPS; int cnt; float *pval1, *pval2, *pval3, *pval4; float w1, w2, w3, w4; int i_1, i_2; float r_1, r_2; /* calculate integer indices and rest */ IDX(f_1,i_1,r_1); IDX(f_2,i_2,r_2); *weight=0.0; *sum=0.0; cnt=0; if (!Data) return(cnt); // return, if NULL pointer pval1 = ABSPTR(Data,Dim_1,Dim_2,i_1,i_2); /* General check */ if ( (i_1>=0) && (i_2>=0) && (i_1=-1) && (i_2>=-1) && (i_1=0) && (i_2>=0) ) /* pval1 OK? */ if NODUMMY(*pval1,Dummy,DDummy) { cnt++; *weight += 1.0; *sum = *pval1; /* no interpolation */ } /* if NODUMMY */ } else { if ( (i_1>=0) && (i_2>=0) ) /* pval1 OK? */ if NODUMMY(*pval1,Dummy,DDummy) { cnt++;w1=1.0-r_2; *weight+=w1; *sum+=*pval1*w1; } /* if NODUMMY */ if ( (i_1>=0) && (i_2=0) && (i_2>=0) ) /* pval1 OK? */ if NODUMMY(*pval1,Dummy,DDummy) { cnt++; w1=(1.0-r_1); *weight+=w1; *sum = *pval1*w1; } /* if NODUMMY */ if ( (i_2>=0) && (i_1=0) && (i_2>=0) ) /* pval1 OK? */ if NODUMMY(*pval1,Dummy,DDummy) { cnt++;w1=(1.0-r_1)*(1.0-r_2); *weight+=w1; *sum+=*pval1*w1; } /* if NODUMMY */ if ( (i_2>=0) && (i_1=0) && (i_2 fabs(*weight) ) cnt=0; return(cnt); } /* Ipol2ldw */ /*--------------------------------------------------------------------------- NAME Ipol2ld --- Interpolation including dummies with limit checks PURPOSE Linear two dimensional interpolation including dummies with limit checks Ipol2ld returns the interpolated value. To calculate the sum and the weight of the interpolated pixels use Ipol2ldw. METHOD See Ipol2ldw. Ipol2ld calculates only the interpolated value and returns the number of interpolated pixels. ---------------------------------------------------------------------------*/ int Ipol2ld (float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f_1, float f_2, float *value) { float weight; int cnt; cnt = Ipol2ldw(Data, Dim_1, Dim_2, Dummy, DDummy,f_1, f_2, value, &weight); if (cnt) *value = *value/weight; return ( cnt ); } /* Ipol2ld */ int Ipol2d (float *Data, int Dim_1, int Dim_2, float Dummy, float DDummy, float f_1, float f_2, float *value) { return(Ipol2ld (Data, Dim_1, Dim_2, Dummy, DDummy, f_1, f_2, value)); } /* Ipol2d */ /*--------------------------------------------------------------------------- NAME Ipol2 --- Two dimensional interpolation, no limit checks, no dummy checks SYNOPSIS void Ipol2 (float *Data, int Dim_1, int Dim_2, float f_1, float f_2, float *value) PURPOSE Linear two dimensional interpolation no limit checks, no dummy checks METHOD The point (f_1, f_2) is linearly interpolated between the 4 closest program array elements val1=Data[i_1,i_2], val2=Data[i_1+1,I_2], val3=Data[i_1+1,i_2+1] and val4=Data[I_1,i_2+1]. If a float index is an integer number 0, 1, 2, 3 etc. no interpolation is done in the corresponding direction. ARGUMENTS return value (o) : number of pixels contributing to the output value (0..4), if 0, only dummies found. float Data[Dim_1,Dim_2] (i) : input array int Dim_1, Dim_2 (i) : dimension of array float f_1, f_2 (i) : program array indices (interpolation point) float *value (o) : interpolated value 2 HISTORY 28-Apr-1995 PB from Ipol2d ---------------------------------------------------------------------------*/ void Ipol2 (float *Data, int Dim_1, int Dim_2, float f_1, float f_2, float *value) { const float eps = IPOLEPS; int cnt; float *pval1, *pval2, *pval3, *pval4; float w1, w2, w3, w4; float weight; int i_1, i_2; float r_1, r_2; /* calculate integer indices and rest */ IDX(f_1,i_1,r_1); IDX(f_2,i_2,r_2); weight=0.0; *value=0.0; cnt=0; if (!Data) return; // return, if NULL pointer pval1 = ABSPTR(Data,Dim_1,Dim_2,i_1,i_2); if (r_1=1) int Average (i) : flag: sum (0) or average (!0) pixel values Data and DataOut can be identical. If they are not identical, they must not overlap. The output variables *pOutDim_1 and *pOutDim_2 must have been allocated. They can be identical to Dim_1 and Dim_2. HISTORY 2007-02-26 PB from RebinFloat2d ---------------------------------------------------------------------------*/ void IpolRebin2 ( float *Data, int Dim_1, int Dim_2, float * DataOut, int * pOutDim_1, int * pOutDim_2, float Dummy, float DDummy, int Bin_1, int Bin_2, int Average ) { register long int j_1, j_2, i_1, i_2; float * pin, * pout; float value, sum, count; int bin_1, bin_2; int dim_1, dim_2; dim_1 = Dim_1; dim_2 = Dim_2; if (pOutDim_1!=NULL) *pOutDim_1=dim_1; if (pOutDim_2!=NULL) *pOutDim_2=dim_2; bin_1 = Bin_1>1?Bin_1:1; // max(1,bin_1) bin_2 = Bin_2>1?Bin_2:1; // max(1,bin_2) if ((bin_1>1) || (bin_2>1) || (DataOut!=Data)) { pout = DataOut; if (pout!=NULL) { for (j_2=0;j_2<=dim_2-bin_2;j_2+=bin_2) for (j_1=0;j_1<=dim_1-bin_1;j_1+=bin_1) { sum = 0.0; count = 0.0; for (i_2=j_2;i_20.0) *(pout++) = Average?sum/count:sum; else *(pout++) = Dummy; } dim_1 /= bin_1; dim_2 /= bin_2; if (pOutDim_1!=NULL) *pOutDim_1=dim_1; if (pOutDim_2!=NULL) *pOutDim_2=dim_2; } } } /* IpolRebin2 */ /*****************************************************************************/ spd-1.3.0/edfpack/raster.c0000755000175000017500000017254311633462461012310 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*-------------------------------------------------------------------------- NAME raster.c --- Raster configuration functions AUTHOR 1998-03-13 Peter Boesecke HISTORY 2010-07-07 V1.0 Peter Boesecke extracted from edfio.c V2.25 and adapted. 2011-04-11 V1.1 PB matrix functions added: raster_fprint_matrix, raster_matrix_product, raster_order2matrix, raster_order_determinante, strtol replaced with num_str2long with errval+1000 9 -> MAX_RASTER_NUMBER_DIMENSION 2011-05-25 V1.2 PB order2wrap: only N+1 elements accessed, ovlpchk added, raster_order_normalization: src and dest can overlap. 2011-06-01 V1.3 PB raster_order_normalization: if src and dest are identical and if raster orientation is 1 the array is not recalculated 2011-06-07 V1.4 PB fprintf -> printf --------------------------------------------------------------------------*/ # define RASTER_VERSION "raster : V1.4 Peter Boesecke 2011-06-07" /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include # include "raster.h" # include "numio.h" /**************************************************************************** * PRIVATE part * ****************************************************************************/ /**************************************************************************** * Static Variables * ****************************************************************************/ static int RN_debug = 0; /*-------------------------------------------------------------------------- NAME raster_debug --- set / reset module raster_conversion into debug mode SYNOPSIS void raster_debug ( int debug ); DESCRPTION Writes ´debug´ into RN_debug. --------------------------------------------------------------------------*/ void raster_debug ( int debug ) { RN_debug = debug; } /* raster_debug */ /*-------------------------------------------------------------------------- NAME ovlpchk --- returns 0 if the memory regions of a and b are distinct SYNOPSIS inv ovlpchk( void *a, size_t a_size, void *b, size_t b_size ); ARGUMENTS void *a (i) : start memory region a size_t a_size (i) : size of memory region a void *b (i) : start memory region b size_t b_size (i) : size of memory region b DESCRPTION RETURN VALUE 0 no overlap 1 overlap --------------------------------------------------------------------------*/ int ovlpchk( const void *a, size_t a_size, const void *b, size_t b_size ) { const void *ll, *uu; size_t ll_size; if (a<=b) { ll=a; uu=b; ll_size=a_size; } else { ll=b; uu=a; ll_size=b_size; } if ( (const char *) ll+ll_size<=(const char *) uu ) return(0); // no overlap else return(1); // overlap } // ovlpchk /*-------------------------------------------------------------------------- NAME raster_numbers --- number of raster configurations of an n-dimensional array SYNOPSIS long raster_numbers ( long n ); DESCRIPTION Returns the number A(n) of raster configurations of an n-dimensional array: A(n) = 2^n * (n!) For n>9 the number of configurations are out of the value range of long int. In this case the returned value is 0. ARGUMENTS long n dimension (number of coordinates) RETURN VALUE long A(n) = 2^n * (n!) (for 0max_n)) return ( 0 ); A=1; for (i=1;i<=n;i++) A*=2*i; return( A ); } /* raster_numbers */ /*-------------------------------------------------------------------------- NAME value2index --- return index of value in order SYNOPSIS long value2index( const long order[], long n, long value ); DESCRIPTION Starting with ´index=1´ at ´order[1]´ (´order[0]´ contains the length of the array) it increments ´index´ at each array element which absolute value is smaller than n until an array element with abs(´order[i]´) = ´value´ is found. The ´index´ of this array element is returned, positive if ´value´ is positive, negative otherwise. ARGUMENTS const long order[0] == N dimension (number of coordinates) long order[n+1] raster configuration array long value value to be found RETURN VALUE long index HISTORY 12-Mar-1998 Peter Boesecke --------------------------------------------------------------------------*/ long value2index( const long order[], long n, long value ) { long i; long N, index; value = labs(value); if ( (!order) || (value<1) || (nn) index=0; return(index); } /* value2index */ /*-------------------------------------------------------------------------- NAME value2order --- insert value at n-th free index SYNOPSIS void value2order( long order[], long n, long index, long value ); DESCRIPTION Starting with order[1] (order[0] contains the length of the array) it skips all non-zero array elements and decrements ´index´ at each zero array element. It replaces the ´index´ed zero array element with ´value´. ARGUMENTS long order[n+1] raster configuration array long n dimension (number of coordinates) long index index of FREE cell at which the value will be written. long value value to be written RETURN VALUE void HISTORY 11-Mar-1998 Peter Boesecke --------------------------------------------------------------------------*/ void value2order( long order[], long N, long index, long value ) { long i; if (index==0) return; for (i=1;i<=N;i++) { if (order[i]==0) if (--index==0) { order[i] = value; break; } } return; } /* value2order */ /*-------------------------------------------------------------------------- NAME raster_number2order --- returns the coordinate order array of a raster configuration SYNOPSIS long * raster_number2order ( long * buffer, size_t nelem, long n , long raster_number ); DESCRIPTION The n-dimensional configuration order array corresponding to ´raster_number´ is returned. For n>9 not all configurations can be calculated due to the limited value range of long int. The highest raster_number that is accepted is raster_numbers(MAX_RASTER_NUMBER_DIMENSION). Configuration order arrays for n>MAX_RASTER_NUMBER_DIMENSION are calculated until the highest accepted raster number. ARGUMENTS long *buffer input buffer (or NULL if not supplied) size_t nelem input buffer length (needed nelem>=n+1) long n dimension (number of coordinates) long raster_number raster configuration number If buffer is NULL an array with n+1 elements is allocated and must be free´ed by the calling program. RETURN VALUE long * raster_coordinate (allocated array with n+1 elements raster_coordinate[0] dimension of array raster_coordinate[1] coordinate corresponding to fastest index (1) ... raster_coordinate[n] coordinate corresponding to slowest index (n) In case of an error NULL is returned. HISTORY 14-Mar-1998 Peter Boesecke --------------------------------------------------------------------------*/ long * raster_number2order ( long * buffer, size_t nelem, long n , long raster_number ) { static const char * R2O_Error = "ERROR: raster_number2order:"; static const char * R2O_MisMatch = "dimension mismatch"; const long max_n = MAX_RASTER_NUMBER_DIMENSION; long AN, ANm1x2, ANm1; long D= raster_number; long N = n; int inverse=0; long * order = (long *) NULL; long * output = (long *) NULL; long * output_buffer = (long *) NULL; long * internal_buffer = (long *) NULL; long index; long value; long i, m; // Calculate inverse order array if raster_number is negative if (raster_number<0) { D = -raster_number; inverse=1; } if (buffer) { if (nelem<=N) { fprintf(stderr,"%s %s\n",R2O_Error,R2O_MisMatch); goto raster_number2order_error; } output = buffer; } else { /* allocate output buffer and clear it */ if ( !(output_buffer = (long*) calloc( (N+1), sizeof(long) )) ) goto raster_number2order_error; output = output_buffer; } if (inverse) { /* allocate temporary buffer and clear it */ if ( !(internal_buffer = (long*) calloc( (N+1), sizeof(long) )) ) goto raster_number2order_error; order = internal_buffer; } else order = output; /* clear buffer 0..N */ for (i=0l;i<=N;i++) order[i]=0l; order[0] = N; /* special case for n>max_n */ if ( (D <= raster_numbers( max_n )) && ( n>max_n ) ) { for (index=max_n+1;index<=n;index++) order[index]=index; n=max_n; } AN = raster_numbers ( n ); /* check parameters */ if ( !((0l0;--n) { ANm1 = AN/(n+n); if (AN==0) AN=1; ANm1x2 = ANm1+ANm1; m = (D-1) / ANm1x2; /* m = 0, ... ,n-1 */ D = D - m * ANm1x2; index = n - m; /* index = 1, ..., n */ if (D<=ANm1) value = n; else { value = -n; D=D-ANm1; } value2order( order, N , index, value ); AN = ANm1; } /* for */ if (inverse) order = raster_order_inversion ( output, nelem, order ); if (internal_buffer) free( internal_buffer ); return( order ); raster_number2order_error: if (internal_buffer) free( internal_buffer ); if (output_buffer) free( output_buffer ); return( NULL ); } /* raster_number2order */ /*-------------------------------------------------------------------------- NAME raster_order2number --- raster configuration number of array order SYNOPSIS long raster_order2number ( long order[] ); DESCRIPTION The raster configuration number of the order[0]-dimensional configuration array ´order´ is returned. For order[0]>]>MAX_RASTER_NUMBER_DIMENSION not all configuration numbers can be calculated due to the limited value range of long int. In this case a zero is returned. ARGUMENTS long order[0] number of dimensions (long order[order[0]+1]) long order[n] configuration order array The element ´order[0]´ must contain the dimension. At least ´order[0]+1´ elements must be allocated for ´order[]´. RETURN VALUE success long raster_number error long 0 HISTORY 12-Mar-1998 Peter Boesecke --------------------------------------------------------------------------*/ long raster_order2number ( const long order[] ) { long i, n; long ANm1, D; long index; if (!order) return(0); n = order[0]; if (MAX_RASTER_NUMBER_DIMENSION < n) { for (i=MAX_RASTER_NUMBER_DIMENSION+1; i<=n; i++) if (order[i]!=i) return(0); n = MAX_RASTER_NUMBER_DIMENSION; } D = 1; ANm1 = raster_numbers ( 0 ); for (i=1;i<=n;i++) { index = value2index( order, i, i ); if ( index == 0 ) return(0); if ( index > 0 ) D += (i-index)*2*ANm1; else D += (i+index) * 2*ANm1 + ANm1; ANm1 = ANm1 * 2 * i; /* raster_numbers ( i ); */ } return( D ); } /* raster_order2number */ /*-------------------------------------------------------------------------- NAME order2wrap --- calculates the wrap array from order and dim SYNOPSIS int order2wrap ( long wrap[], const long dim[], const long order[] ); DESCRIPTION Calculates the array ´wrap´ that contains for each index the displacement in number of array elements when it is incremented by 1. For the fastest index wrap[fast] is 1. ARGUMENTS long wrap[N+1] output array element, must be sufficiently large long dim[N+1] data array dimensions, dim[0] is N long order[N+1] input order of dimensions All three array use only index 1 to index N. The values for the n_th dimension is found in array[n], array[0] is used for the number of dimensions. array[n+1] is not accessed any more (for the total length of the data array. RETURN VALUE int status success : 0 error : -1 AUTHOR 15-Mar-1998 Peter Boesecke --------------------------------------------------------------------------*/ int order2wrap ( long wrap[], const long dim[], const long order[] ) { long N = dim[0]; long i,j; wrap[0] = dim[0]; // wrap[N+1] = dim[N+1]; // generally, element N+1 is not allocated for (i=1;i<=N;i++) { wrap[i]=1l; for (j=1;j (I[nn]-1l) 26-Nov-1999 PB cc on dec alpha: statements of the form (void *) pp + (size_t) item; are not allowed, therefore changed to (char *) pp1 + (size_t) item; pp = (void *) pp1; 19-Dec-1999 PB pps1 correctly defined as char **pps1 -----------------------------------------------------------------------------*/ void reorder_raster ( long n, void * dest, const void ** pps, size_t item, long I[], const long IS[], const long ILoop[], const long IInc[], const long IWrap[] ); void reorder_raster ( long n, void * dest, const void ** pps, size_t item, long I[], const long IS[], const long ILoop[], const long IInc[], const long IWrap[] ) { long ii, nn; long N = IWrap[0]; char *pd, **pps1; if (n>0) { for (ii=0,I[n]=IS[n]; ii (x1, x2, x3, ... , xn, xn+1) (x1, x2, x3, ... , xn, -xn+1) +2 (x1, x2, x3, ... , xn+1, xn) (x1, x2, x3, ... , -xn+1, xn) +2 ... ( xn+1, x1, x2, x3, ... , xn) (-xn+1, x1, x2, x3, ... ,-xn) +2 (n+1)*2 A(n) = 2^n * (n!) The total number of configuration for n+1 coordinates is then 2 * (n+1) * A(n) = 2^(n+1) * (n+1)! , which is equal to A(n+1). EXAMPLE n raster_number D Configuration 1 1 1 1 2 -1 2 1 1, 2 2 2 -1, 2 2 3 1,-2 2 4 -1,-2 2 5 2, 1 2 6 2,-1 2 7 -2, 1 2 8 -2,-1 3 1 1, 2, 3 3 2 -1, 2, 3 3 3 1,-2, 3 3 4 -1,-2, 3 3 5 2, 1, 3 3 6 2,-1, 3 3 7 -2, 1, 3 3 8 -2,-1, 3 3 9 1, 2,-3 3 10 -1, 2,-3 3 11 1,-2,-3 3 12 -1,-2,-3 3 13 2, 1,-3 3 14 2,-1,-3 3 15 -2, 1,-3 3 16 -2,-1,-3 3 17 1, 3, 2 ... 3 32 -2,-3,-1 3 33 3, 1, 2 ... 3 48 -3,-2,-1 The raster configuration 13 for n=3 (2, 1,-3) means that the first offset index of the array (which is the fastest) corresponds to the coordinate k_2, the second index corresponds to the coordinate k_1 and the third index to the inverted coordinate k_3. The largest D (D = A(n)) is always the conformation where the direction and order of all array indices are inverted. RETURN VALUE int status success : 0 error : -1 AUTHOR 07-Jul-2010 Peter Boesecke -----------------------------------------------------------------------------*/ int raster_normalization ( void * dest, const void * src, const long data_dim[], long raster_number, size_t item, int * perrval ) { static const char * RN_Error = "ERROR: raster_normalization:"; static const char * RN_NoDim = "no or zero dimension"; // 1 static const char * RN_NoRas = "bad raster configuration"; // 2 long * order=NULL; long n; int status=0; int errval=0; if (RN_debug) printf(" raster_normalization BEGIN\n"); if (!data_dim) { fprintf(stderr,"SEVERE %s Data dimension pointer missing!",RN_Error); exit(-1); } /* get dimension */ if (data_dim) n = data_dim[0]; else n = 0; if (n<=0) { errval=1; fprintf(stderr,"%s data_dim %s\n",RN_Error, RN_NoDim); goto raster_normalization_error; } /* get index order */ if (!(order = raster_number2order ( NULL, 0, n , raster_number )) ) { errval=2; fprintf(stderr,"%s raster_number=%ld %s\n",RN_Error, raster_number, RN_NoRas); goto raster_normalization_error; } if ( raster_order_normalization ( dest, src, data_dim, order, item, &errval ) ) goto raster_normalization_error; if (order) free ( order ); if (perrval) *perrval=errval; if (RN_debug) printf(" raster_normalization END\n"); return ( status ); raster_normalization_error: if (order) free ( order ); if (perrval) *perrval=errval; if (RN_debug) printf(" raster_normalization END (errval=%d)\n",errval); return ( -1 ); } /* raster_normalization */ /*+++-------------------------------------------------------------------------- NAME raster_order_normalization --- conversion to raster configuration 1 SYNOPSIS int raster_order_normalization ( void * dest, const void * src, const long data_dim[], const long order[], size_t item, int *perrval ); DESCRIPTION Like raster_normalization, uses directly configuration order array instead calculating it from configuration raster number. RETURN VALUE int status success : 0 error : -1 AUTHOR AUTHOR 13-Mar-1998 Peter Boesecke 17-May-1998 PB calculation of IS for positive order corrected: 07-Jul-2010 PB extracted from raster_normalization -----------------------------------------------------------------------------*/ int raster_order_normalization ( void * dest, const void * src, const long data_dim[], const long order[], size_t item, int *perrval ) { static const char * RON_Error = "ERROR: raster_order_normalization:"; static const char * RON_NoDim = "no or zero dimension"; // 1 static const char * RON_NoMem = "cannot allocate memory"; // 3 static const char * RON_Wrap = "bad wrapping"; // 4 static const char * RON_NoCpy = "cannot copy memory"; long * IS=NULL, * IInc=NULL, * ILoop=NULL, * IWrap=NULL; long * I=NULL; const void * ps; long n, n_dim; long n_element; size_t used_size; void * tmp_src=NULL; long raster_number=0l; // info only int errval=0; if (RN_debug) printf(" raster_order_normalization BEGIN\n"); if (!data_dim) { fprintf(stderr,"SEVERE %s Data dimension pointer missing!",RON_Error); exit(-1); } if (!order) { fprintf(stderr,"SEVERE %s Order array pointer missing!",RON_Error); exit(-1); } if (!dest) { fprintf(stderr,"SEVERE %s Destination pointer missing!",RON_Error); exit(-1); } if (!src) { fprintf(stderr,"SEVERE %s Source pointer missing!",RON_Error); exit(-1); } /* get dimension */ if (data_dim) n = data_dim[0]; else n = 0; if (n<=0) { errval=1; fprintf(stderr,"%s data_dim %s\n",RON_Error, RON_NoDim); goto raster_order_normalization_error; } // raster_number 1 is calculated without dimension limit if ( ( src==dest ) && ( raster_order2number( order )==1l ) ) { if (RN_debug) { printf(" raster_number = %ld\n", 1l); printf(" src and dest arrays are identical\n"); printf(" normalization not required\n"); } } else { /* use buffer if src and dest overlap */ n_element = 1l; for (n_dim=1;n_dim<=n;n_dim++) n_element *= data_dim[n_dim]; used_size = item * (size_t) n_element; if ( ovlpchk( dest, used_size, src, used_size ) ) { if (RN_debug) printf(" raster_order_normalization: creating temporory copy \n"); if ( !(tmp_src = malloc( used_size )) ) { fprintf(stderr,"%s IS %s\n",RON_Error, RON_NoMem); goto raster_order_normalization_error; } if ( !(memcpy(tmp_src, src, used_size)) ) { fprintf(stderr,"%s IS %s\n",RON_Error, RON_NoCpy); goto raster_order_normalization_error; } src = tmp_src; } /* calculate loop parameters */ if (!(IS = (long *) malloc ( sizeof(long) * (n+2) )) ) { errval=3; fprintf(stderr,"%s IS %s\n",RON_Error, RON_NoMem); goto raster_order_normalization_error; } if (!(IInc = (long *) malloc ( sizeof(long) * (n+2) )) ) { errval=3; fprintf(stderr,"%s IInc %s\n",RON_Error, RON_NoMem); goto raster_order_normalization_error; } if (!(ILoop = (long *) malloc ( sizeof(long) * (n+2) )) ) { errval=3; fprintf(stderr,"%s ILoop %s\n",RON_Error, RON_NoMem); goto raster_order_normalization_error; } if (!(IWrap = (long *) malloc ( sizeof(long) * (n+2) )) ) { errval=3; fprintf(stderr,"%s IWrap %s\n",RON_Error, RON_NoMem); goto raster_order_normalization_error; } if (!(I = (long *) malloc ( sizeof(long) * (n+2) )) ) { errval=3; fprintf(stderr,"%s I %s\n",RON_Error, RON_NoMem); goto raster_order_normalization_error; } /* calculate start, increment, loop count */ for (n_dim=1;n_dim<=n;n_dim++) if (order[n_dim]<0) { IS[n_dim] = data_dim[-order[n_dim]]; IInc[n_dim] = -1; ILoop[n_dim] = data_dim[-order[n_dim]]; } else { IS[n_dim] = 1; IInc[n_dim] = 1; ILoop[n_dim] = data_dim[order[n_dim]]; } if ( order2wrap ( IWrap, data_dim, order ) ) { fprintf(stderr,"%s %s\n",RON_Error, RON_Wrap); return(-1); } if (RN_debug) { // raster_number is only used as debug info for n<=MAX_RASTER_NUMBER_DIMENSION raster_number = raster_order2number ( order ); for (n_dim=1;n_dim<=n;n_dim++) { printf(" raster_number = %ld\n", raster_number); printf(" data_dim[%ld] = %ld\n", n_dim, data_dim[n_dim]); printf(" order[%ld] = %ld\n", n_dim, order[n_dim]); printf(" IWrap[%ld] = %ld\n", n_dim, IWrap[n_dim]); printf(" IS[%ld] = %ld\n", n_dim, IS[n_dim]); printf(" IInc[%ld] = %ld\n", n_dim, IInc[n_dim]); printf(" ILoop[%ld] = %ld\n", n_dim, ILoop[n_dim]); } } ps = src; reorder_raster ( n, dest, &ps, item, I, IS, ILoop, IInc, IWrap ); free ( I ); free ( IWrap ); free ( ILoop ); free ( IInc ); free ( IS ); if (tmp_src) free (tmp_src); } // if ( src==dest ) ... if (perrval) *perrval=errval; if (RN_debug) printf(" raster_order_normalization END\n"); return(0); raster_order_normalization_error: if (I) free ( I ); if (IWrap) free ( IWrap ); if (ILoop) free ( ILoop ); if (IInc) free ( IInc ); if (IS) free ( IS ); if (tmp_src) free (tmp_src); if (perrval) *perrval=errval; if (RN_debug) printf(" raster_order_normalization END (errval=%d)\n",errval); return(-1); } /* raster_order_normalization */ /*-------------------------------------------------------------------------- NAME raster_order_multiplication --- raster transformation of a configuration order array SYNOPSIS long * raster_order_multiplication (long *buffer, size_t nelem, const long a_order[] , const long x_order[]); DESCRIPTION ARGUMENTS long *buffer input buffer (or NULL if not supplied) size_t nelem input buffer length (needed nelem>=a_order[0]+1) const long a_order[n] raster transformation array const long x_order[n] raster configuration array The elements 'a_order[0]' and 'x_order[0]' must contain the dimensions. At least 'a_order[0]+1' and 'x_order[0]+1' elements must be allocated for each array. If buffer is NULL an array with a_order[0]+1 elements is allocated and must be free'd by the calling program. RETURN VALUE success long * x_order error long NULL If the return value is not equal to NULL a pointer to allocated memory is returned that must be free'd by the calling routine. HISTORY 2000-07-29 Peter Boesecke --------------------------------------------------------------------------*/ long * raster_order_multiplication (long *buffer, size_t nelem, const long a_order[] , const long x_order[]) { static const char * ROM_Error = "ERROR: raster_order_multiplication:"; static const char * ROM_MisMatch = "dimension mismatch"; register int i; long I; long * y_order = (long *) NULL; long N = 0l; if (!(a_order && x_order)) goto raster_order_multiplication_error; if (a_order[0]>x_order[0]) goto raster_order_multiplication_error; N = a_order[0]; if (buffer) { if (nelem<=N) { fprintf(stderr,"%s %s\n",ROM_Error,ROM_MisMatch); goto raster_order_multiplication_error; } y_order = buffer; /* clear y_order */ for ( i=0;i<=N;i++ ) y_order[i]=0l; } else { /* allocate array and clear it */ if ( !(y_order = (long*) calloc( (N+1), sizeof(long) )) ) goto raster_order_multiplication_error; } y_order[0] = N; for (i=1;i<=N;i++) { I = a_order[i]; if ( labs(I)<=x_order[0] ) { if (I>0) y_order[i] = x_order[I]; else y_order[i] = - x_order[-I]; } else y_order[i] = 0l; // not defined } // for return( y_order ); raster_order_multiplication_error: if ( (y_order)&&(!buffer) ) free( y_order ); return( NULL ); } /* raster_order_multiplication */ /*-------------------------------------------------------------------------- NAME raster_multiplication --- raster number after a raster transformation SYNOPSIS long raster_multiplication ( long a, long x ); DESCRIPTION The resulting raster configuration number of the transformations a*x is returned. x is the input raster configuration number, a is the raster transformation which is applied to x. ARGUMENTS long a raster transformation long x input raster configuration number a and x must be smaller or equal to A(n) = 2^n * (n!) RETURN VALUE success long raster_number error long 0 HISTORY 2000-07-29 Peter Boesecke --------------------------------------------------------------------------*/ long raster_multiplication ( long a, long x ) { long * a_order; long * x_order; long * y_order; long value; long n = MAX_RASTER_NUMBER_DIMENSION; a_order = raster_number2order ( NULL, 0, n , a ); x_order = raster_number2order ( NULL, 0, n , x ); y_order = raster_order_multiplication ( NULL, 0, a_order , x_order ); value = raster_order2number ( y_order ); if (a_order) free ( a_order ); if (x_order) free ( x_order ); if (y_order) free ( y_order ); return ( value ); } /* raster_multiplication */ /*-------------------------------------------------------------------------- NAME raster_order_inversion --- returns inverse raster order array SYNOPSIS long * raster_order_inversion ( long *buffer, size_t nelem, const long x_order[] ); DESCRIPTION Returns the inverted raster order array a_order = x_order^-1, with a_order[] * x_order[] = 1[]; ARGUMENTS long *buffer output buffer (or NULL if not supplied) size_t nelem output buffer length (needed nelem>=x_order[0]+1) const long x_order[n] input raster order array The element ´x_order[0]´ must contain the dimension. At least ´x_order[0]+1 elements must be allocated for the array. RETURN VALUE success long * a_order error long NULL If the return value is not equal to NULL a pointer to allocated memory is returned that must be free´d by the calling routine. HISTORY 2000-07-29 Peter Boesecke --------------------------------------------------------------------------*/ long * raster_order_inversion ( long *buffer, size_t nelem, const long x_order[] ) { static const char * ROI_Error = "ERROR: raster_order_inversion:"; static const char * ROI_MisMatch = "dimension mismatch"; register int i; long I; long * a_order = (long *) NULL; long N = 0l; if (!(x_order)) return( 0 ); N = x_order[0]; if (buffer) { if (nelem<=N) { fprintf(stderr,"%s %s\n",ROI_Error,ROI_MisMatch); goto raster_order_inversion_error; } a_order = buffer; /* clear a_order */ for ( i=0;i<=N;i++ ) a_order[i]=0l; } else { /* allocate array and clear it */ if ( !(a_order = (long*) calloc( (N+1), sizeof(long) )) ) goto raster_order_inversion_error; } a_order[0] = N; for ( i=1;i<=N;i++ ) { I = x_order[i]; if ( labs(I)<=x_order[0] ) { if (I>0) a_order[I] = i; else a_order[-I] = -i; } else a_order[i] = 0l; // not defined } // for return( a_order ); raster_order_inversion_error: if ( (a_order)&&(!buffer) ) free( a_order ); return( NULL ); } /* raster_order_inversion */ /*-------------------------------------------------------------------------- NAME raster_order_determinante --- returns determinante SYNOPSIS long raster_order_determinante ( const long order[] ); DESCRIPTION Returns the determinante of raster order array order[]. ARGUMENTS const long order[] input raster order array The element order[0] must contain the dimension. At least order[0]+1 elements must be allocated for the array. RETURN VALUE success long determinante error long 0 HISTORY 2011-02-25 Peter Boesecke --------------------------------------------------------------------------*/ long raster_order_determinante ( const long order[] ) { long N; long l, m, n, sign; long o, osign; long *order_copy=NULL; long Aln, determinante=0l; N=order[0]; // duplicate order array if ( !(order_copy=malloc(sizeof(long)*(N+1))) ) goto order_determinante_error; for (l=0;l<=N;l++) order_copy[l]=order[l]; determinante=1; // development after Laplace using first column of each adjunct matrix for (l=1;l<=N;l++) { // l-th column, n-th row n = order_copy[l]; if (n<0) { sign=-1l;n=-n; } else sign=1l; Aln = (n%2)?1l:-1l; // it is always the first column determinante*=Aln*sign; // calculate adjunct matrix for (m=l+1;m<=N;m++) { o=order_copy[m]; if (o<0l) { osign=-1l; o=-o; } else osign=1l; if (o>n) order_copy[m]=(o-1l)*osign; } } free(order_copy); return(determinante); order_determinante_error: if (order_copy) free(order_copy); return(0l); } // raster_order_determinante /*-------------------------------------------------------------------------- NAME raster_inversion --- returns raster number of the inverse transformation SYNOPSIS long raster_inversion ( long x ); DESCRIPTION The raster number of the transformation a = x^-1 is returned that transforms configuration x to 1: a * x = 1 ARGUMENTS long x input raster configuration number RETURN VALUE success long inverse raster configuration number error long 0 HISTORY 2000-07-29 Peter Boesecke --------------------------------------------------------------------------*/ long raster_inversion ( long x ) { long * a_order; long * x_order; long value; long n = MAX_RASTER_NUMBER_DIMENSION; x_order = raster_number2order ( NULL, 0, n , x ); a_order = raster_order_inversion ( NULL, 0, x_order ); value = raster_order2number ( a_order ); if (a_order) free ( a_order ); if (x_order) free ( x_order ); return ( value ); } /* raster_inversion */ /*--------------------------------------------------------------------------- NAME raster_str2order --- read an order array from a string SYNOPSIS long * raster_str2order( long * buffer, size_t nelem, long n, const char *str, const char **tail, int *perrval ) ARGUMENTS long * buffer (NULL to allocate new output buffer) If buffer is NULL an output order array with n+1 long elements is allocated and must be released explicitely. If buffer is not NULL n+1 long elements will be used for the outut order array. long n number of axes const char *str input character string const char **tail (NULL to ignore) outputs remaining string int *perrval (NULL to ignore) output error codes *perrval : 0 OK 1 memory allocation error (output array) 2 memory allocation error (internal) 3 explicit duplication 4 outside range 5 implicit duplication 6 not enough parameters 7 conversion OK, but too many parameters 8 conversion from raster number failed 9 buffer size too small (nelem1: positive and negative (inverse) raster numbers or comma separated indices are accepted. If 2 or more numbers are given, they are used as indices in an order array, if only 1 number is given it is interpreted as raster number and is converted to an order array. Single negative numbers are interpreted as inverse raster number. allowed input: ,[,] (maximum n indices) or (everything that follows is ignored) Whenever the conversion was successful a pointer different from NULL is returned. To check that the rest of the string is clean, check the length of **tail or *perrval. RETURN VALUE Returns the pointer to the order array or NULL in case of a conversion error. In case of NULL **tail returns the original pointer to the string. HISTORY 2010-07-06 Peter Boesecke ---------------------------------------------------------------------------*/ long * raster_str2order( long * buffer, size_t nelem, long n, const char *str, const char **tail, int *perrval ) { // static const char * RSO_Error = "ERROR: raster_str2order:"; long *order=NULL, *index=NULL; long tmp, raster_number=0l; const char *ps=""; int errval=0; int i, cnt=0; int no_more_parameters_allowed=0; if (buffer) { if (nelem<=n) { errval=9; goto raster_string2order_error; } order=buffer; } else { if ( !(order = (long*) calloc( n+1l, sizeof(long) )) ) { errval=1; // allocation error goto raster_string2order_error; } } if ( !(index = (long*) calloc( n+1l, sizeof(long) )) ) { errval=2; // allocation error goto raster_string2order_error; } if (str) ps=str; if (n>=0) order[0] = n; for (i=1;i<=n;i++) { if (*ps) { if (no_more_parameters_allowed) { errval=7; // too many parameters, but result OK break; } else { tmp = num_str2long( ps, &ps, &errval); if (errval) { errval+=1000; goto raster_string2order_error; } cnt++; if (cnt==n) no_more_parameters_allowed=1; if (i==1) { // keep in mind 1st value, it could be the raster number // for n>=2 a negative raster number is the inverse raster number if (n>1) { if (tmp) raster_number = tmp; } else if (01: positive and negative (inverse) raster numbers or comma separated indices are accepted. If 2 or more numbers are given, they are used as indices in an order array, if only 1 number is given it is interpreted as raster number and is converted to an order array. Single negative numbers are interpreted as inverse raster number. allowed input: ,[,] (maximum n indices) or (everything that follows is ignored) Whenever the conversion was successful a pointer different from NULL is returned. To check that the rest of the string is clean, check the length of **tail or *perrval. RETURN VALUE Returns a (positive) raster number. In case of a conversion error the returned value is 0 and **tail returns the original pointer to the string. HISTORY 2011-04-04 Peter Boesecke ---------------------------------------------------------------------------*/ long raster_str2number( long n, const char *str, const char **tail, int *perrval ) { long *order=NULL; long raster_number=0l; int errval=-1; order = raster_str2order( NULL, 0, n, str, tail, &errval ); if (errval) goto raster_str2number_error; raster_number = raster_order2number ( order ); free(order); if (perrval) *perrval=errval; return( raster_number ); raster_str2number_error: if (perrval) *perrval=errval; if (order) free(order); return(0l); } // raster_str2number /*-------------------------------------------------------------------------- NAME raster_order2str --- writes order into a comma separated string SYNOPSIS char * raster_order2str( char * buffer, size_t nelem, long order[], int *perrval ); DESCRIPTION The contents of the array order[] is written to a string and returned. If no buffer is NULL the required memory is allocated and must be released externally. nelem is the number of allocated char elements (ignored in case of buffer==NULL). ARGUMENTS char * buffer output buffer with nelem characters (ignored if NULL) size_t nelem number of elements in buffer (ignored if buffer is NULL) const char * str output order string (buffer or allocated string, if buffer is NULL) int * perrval output error value 0: OK 1: allocation error 2: string buffer too small RETURN VALUE NULL error string success HISTORY 2010-07-06 Peter Boesecke --------------------------------------------------------------------------*/ char * raster_order2str( char * buffer, size_t nelem, long order[], int *perrval ) { # define BUFLEN 1024 register int i; int errval=0; char * value, * ps; size_t valsiz, psiz, siz=0l; long N, log10, n; // calculate needed string length N=order[0]; log10=floor(log(N)/log(10)); n=exp(log(10)*log10); while (log10>=0) { siz+=(1l+N-n)*(log10+3l); N=n-1l; log10-=1l; n/=10l; } // while if (buffer) { value=buffer; valsiz=nelem; } else { if ( !(value = (char*) malloc((siz+1l)*sizeof(char)) ) ) { errval=1; // allocation error goto raster_order2str_error; } valsiz=siz; } if (valsiz<1) { errval=2; // string buffer too small goto raster_order2str_error; } value[0]='\0'; ps=value; psiz=valsiz; for (i=1;i<=order[0];i++) { if (i==1) snprintf(ps,valsiz,"%ld",order[i]); else snprintf(ps,valsiz,",%ld",order[i]); ps=value+strlen(value); psiz=valsiz-strlen(value); } if (perrval) *perrval=errval; return( value ); raster_order2str_error: // String could not be created if ( (order)&&(!buffer) ) free( order ); if (perrval) *perrval=errval; return( NULL ); } // raster_order2str /*-------------------------------------------------------------------------- NAME order2matrix --- representation of a configuration order array as a NxN matrix SYNOPSIS double * raster_order2matrix ( double * buffer, size_t nelem, const long order[N+1] ); DESCRIPTION Transforms a configuration order array for N dimensions into a NxN matrix that can be used for coordinate transformations. ARGUMENTS long *buffer output buffer (or NULL if not supplied) size_t nelem output buffer length (needed nelem>=(order[0]*order[0]) long order[N+1] raster configuration array The element 'order[0]' must contain the dimension N (number of coordinates) If buffer is NULL an array with N*N elements (N=order[0]) is allocated and must be released by the calling program. RETURN VALUE success double mat[N][N] error double NULL HISTORY 2011-02-23 Peter Boesecke --------------------------------------------------------------------------*/ double * raster_order2matrix ( double * buffer, size_t nelem, const long order[] ) { static const char * R2M_Error="ERROR: raster_order2matrix:"; static const char * R2M_NoOrder="order is NULL pointer:"; static const char * R2M_MisMatch="dimension mismatch"; static const char * R2M_OutOfBounds="order index out of bounds"; long l, n; long N; double *Out = (double *) NULL, *pOut; double sign; if (RN_debug) printf(" raster_order2matrix BEGIN\n"); if (!order) { fprintf(stderr,"%s %s\n",R2M_Error,R2M_NoOrder); goto raster_order2matrix_error; } N = order[0]; if (buffer) { if (nelemN) { fprintf(stderr,"%s %s\n",R2M_Error,R2M_OutOfBounds); goto raster_order2matrix_error; } n--; // first index is 0 Out[l*N+n] = sign; // Out[l][n] } if (RN_debug) printf(" raster_order2matrix END\n"); return( Out ); raster_order2matrix_error: if (Out) free( Out ); if (RN_debug) printf(" raster_order2matrix END (error)\n"); return( NULL ); } // raster_order2matrix /*+++------------------------------------------------------------------------ NAME raster_matrix_product --- product of two matrices SYNOPSIS double * raster_matrix_product ( double * buffer, size_t nelem, double A[M][N], double B[L][M], int L, int M, int N ); DESCRIPTION Out[L][N] = A[M][N]*B[L][M] | summed over M ARGUMENTS long *buffer output buffer (or NULL if not supplied) size_t nelem output buffer length (needed nelem>=L*N) double A[M][N] MxN matrix double B[L][M] LxM matrix If buffer is NULL an array with N*N elements (N=order[0]) is allocated and must be released by the calling program. RETURN VALUE success: Out[L][N] LxN matrix ( Out[l][n] += A[m][n]*B[l][m] ) otherwise: NULL ----------------------------------------------------------------------------*/ double * raster_matrix_product ( double * buffer, size_t nelem, double A[], double B[], int L, int M, int N ) { static const char * RMP_Error="ERROR: raster_matrix_product:"; static const char * RMP_MisMatch = "dimension mismatch"; double *Out = (double *) NULL; int l, m, n; if (RN_debug) printf(" raster_matrix_product BEGIN\n"); if (buffer) { if (nelem. */ /*+++*********************************************************************** NAME polarization.h SYNOPSIS #include "polarization.h" DESCRIPTION Header of the module "polarization.c" ***********************************************************************---*/ #ifndef _POLARIZATION_ # define _POLARIZATION_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include # include # include "waxs.h" # include "raster.h" /****************************************************************************** * Type Defs * ******************************************************************************/ typedef struct polarization_params { int Init; long Ori; // orientation (1..16) double P; // polarization (0<=P<=1) double PChi; // Poincaré angle chi (ellipticity) (-pi/4<=PChi<=pi/4) double PPsi; // Poincaré angle psi (polarization direction) double Factor; // Multiplication factor f*f = n/A * re*re int Invert; // Invert polarization factor // calculated values double halfOnePlusCos2ChiCos2Psi; // 0.5*(1+cos(2*Chi)*cos(2*Psi) double halfOneMinusCos2ChiCos2Psi; // 0.5*(1-cos(2*Chi)*cos(2*Psi) double Cos2ChiSin2Psi; // Cos2ChiSin2Psi WParams wparams; // Waxs parameters } PParams; /*===========================================================================*/ /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern int polarization_Init ( PParams * pParams, long ori, double k, double rot1, double rot2, double rot3, double P, double PChi, double PPsi, double Factor, int Invert ); PUBLIC extern void polarization_PrintParams ( FILE * out, PParams Params ); PUBLIC extern double polarization_factor ( PParams * pParams, WaxsCoord wc, int projection); #endif spd-1.3.0/edfpack/tilt3d.c0000644000175000017500000004125511633462461012203 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define TILT3D_VERSION "tilt3d : Peter Boesecke V1.11 2011-06-16" /*--------------------------------------------------------------------------- NAME tilt3d - Conversion between tilt1f, tilt2f, tilt3f and 3d rotation matrix. SYNOPSIS DESCRIPTION The angles tilt1f and tilt2f are defined by fit2d to calibrate the inclination of a detector with respect to an ideal orientation. The axes 1, 2 and 3 define a right-handed orthogonal system in the laboratory space. The angle tilt1f is the ccw rotation of the inclination axis around lab axis 3, starting from axis 2 (see *). Tilt2f is the angle between the detector normal and axis 3. tilt3f is a ccw rotation around axis 3. The third angle ("tilt3f") that rotates the detector in the laboratory around the primary beam is missing in the fit2d description. It is added here to define bijective transformations. *) This is equivalent to a ccw rotation of the tilting plane around axis 3, starting from axis 1. Because tilt1 is defined here as the rotation of the tilt axis starting from axis 1 there is a difference by pi/2 to the fit2d definition (rotation of the tilt "plane" starting from axis 1). The internally used angle tilt1 needs therefore to be redefined as tilt1=tilt1f+pi/2. (see A. Hammersley, High Pressure Research, 1996, Vol. 14, pp. 235-248) tilt3d_matrix calculates the rotation matrix is calculated for the angles tilt1f, tilt2f and tilt3f. tilt3d_inverse_matrix calculates the inverse rotation matrix. tilt3d_angles determines the tilt from a given rotation matrix. fit2d (rotations around detector axes, origin in detector plane) with tilt1=tilt1f+pi/2, tilt2=tilt2f, tilt3=tilt3f: rotation angle of tilt axis on detector (ccw around axis3): | cos(tilt1) -sin(tilt1) 0.0 | T1(tilt1) = | sin(tilt1) cos(tilt1) 0.0 | | 0.0 0.0 1.0 | inclination of detector plane (ccw around axis1' after Tilt1): | 1.0 0.0 0.0 | T2(tilt2) = | 0.0 cos(tilt2) -sin(tilt2) | | 0.0 sin(tilt2) cos(tilt2) | rotation angle of detector (ccw around axis 3): | cos(tilt3) -sin(tilt3) 0.0 | T3(tilt3) = | sin(tilt3) cos(tilt3) 0.0 | | 0.0 0.0 1.0 | principal (output) ranges: tilt1f=Tilt[0] ] -Pi .. +Pi ] tilt2f=Tilt[1] [ 0 .. +Pi ] tilt3f=Tilt[2] ] -Pi .. +Pi ] all rotations: T[tilt1, tilt2, tilt3] = T3(tilt3).T1(tilt1).T2(tilt2).T1(-tilt1) t11 = T[0][0] = cos(tilt1) cos(tilt1+tilt3) + sin(tilt1) cos(tilt2) sin(tilt1+tilt3) t12 = T[1][0] = sin(tilt1) cos(tilt1+tilt3) - cos(tilt1) cos(tilt2) sin(tilt1+tilt3) t13 = T[2][0] = sin(tilt2) sin(tilt1+tilt3) t21 = T[0][1] = -sin(tilt1) cos(tilt2) cos(tilt1+tilt3) + cos(tilt1) sin(tilt1+tilt3) t22 = T[1][1] = cos(tilt1) cos(tilt2) cos(tilt1+tilt3) + sin(tilt1) sin(tilt1+tilt3) t23 = T[2][1] = -sin(tilt2) cos(tilt1+tilt3) t31 = T[0][2] = -sin(tilt1) sin(tilt2) t32 = T[1][2] = cos(tilt1) sin(tilt2) t33 = T[2][2] = cos(tilt2) | T[0][0] T[1][0] T[2][0] | T(tilt1,tilt2,tilt3) = | T[0][1] T[1][1] T[2][1] | | T[0][2] T[1][2] T[2][2] | | t11 t12 t13 | = | t21 t22 t23 | | t31 t32 t33 | | c1 c13 + s1 c2 s13 s1 c13 - c1 c2 s13 s2 s13 | = | -s1 c2 c13 + c1 s13 c1 c2 c13 + s1 s13 -s2 c13 | | -s1 s2 c1 s2 c2 | (c13=cos(tilt1+tilt3), s13=sin(tilt1+tilt3), c1=cos(tilt1), s1=sin(tilt1), c2=cos(tilt2) etc.) principal ranges of the angles tilt1, tilt2, tilt3: tilt1 ] -Pi .. +Pi ] tilt2 [ 0 .. +Pi ] tilt3 ] -Pi .. +Pi ] Tilt1[R_] := If[1 - Abs[R[[3, 3]]] > Eps, ArcTan[R[[3, 2]], -R[[3, 1]]], If[Abs[1 - R[[3, 3]]] < Eps, 0, (ArcTan[R[[1, 1]], R[[1, 2]]] - tilt3 + 2 Pi)/2]] /. {tilt3 -> 0} Tilt2[R_] := If[Abs[Sin[Tilt1[R]]] > Eps, ArcTan[R[[3, 3]], -R[[3, 1]]/Sin[Tilt1[R]]], ArcTan[R[[3, 3]], R[[3, 2]]/Cos[Tilt1[R]]]] Tilt3[R_] := If[Abs[Sin[Tilt2[R]]] > Eps, ArcTan[-R[[2, 3]]/Sin[Tilt2[R]], R[[1, 3]]/Sin[Tilt2[R]]] - Tilt1[R], If[Cos[Tilt2[R]] > 0, ArcTan[R[[2, 2]], R[[2, 1]]], ArcTan[R[[1, 1]], R[[1, 2]]] - 2 Tilt1[R]]] History 2010-05-10 Peter Boesecke creation 2010-05-17 PB V1.0 2011-04-18 PB V1.0 tilt3d_version() added 2011-06-01 PB V1.01 suggested parentheses added 2011-06-15 PB V1.1 tilt1 axis -> tilt1f plane (pi/2 difference) 2011-06-15 PB V1.11 tilt1 calculation corrected ---------------------------------------------------------------------------*/ /*************************************************************************** * Include * ***************************************************************************/ # include "tilt3d.h" /*************************************************************************** * Internal * ***************************************************************************/ /**************************************************************************** * Static Variables and Numbers * ****************************************************************************/ static double tilt3d_eps=1e-8; static double tilt3d_pi=3.1415926535897932384626; /**************************************************************************** * Routines * ****************************************************************************/ /*-------------------------------------------------------------------------- NAME tilt3d_version --- returns pointer to the version string SYNOPSIS const char *tilt3d_version ( void ); DESCRPTION Returns pointer to the version string. --------------------------------------------------------------------------*/ const char *tilt3d_version ( void ) { return ( TILT3D_VERSION ); } /* tilt3d_version */ /*--------------------------------------------------------------------------- NAME tilt3d_determinante SYNOPSIS double tilt3d_determinante ( double A[3][3] ) DESCRIPTION input: double A[3][3] (3d matrix) RETURN VALUE determinante of A ---------------------------------------------------------------------------*/ double tilt3d_determinante ( double A[3][3] ) { double determinante=0.0; if (!A) { fprintf( stderr, "ERROR: tilt3d_determinante: NULL pointer\n" ); goto tilt3d_determinante_error; } determinante = A[0][0]*(A[1][1]*A[2][2]-A[2][1]*A[1][2]); determinante -= A[0][1]*(A[1][0]*A[2][2]-A[1][2]*A[2][0]); determinante += A[0][2]*(A[1][0]*A[2][1]-A[1][1]*A[2][0]); tilt3d_determinante_error: return( determinante ); } // tilt3d_determinante /*--------------------------------------------------------------------------- NAME tilt3d_mat_scale SYNOPSIS int tilt3d_mat_scale ( double A[3][3], double scale ) DESCRIPTION Multiplies each element of A with scale. input: double A[3][3] (3d matrix) double scale (scale factor) updated: A RETURN VALUE status ---------------------------------------------------------------------------*/ int tilt3d_mat_scale ( double A[3][3], double scale ) { int status=-1; int i,j; if (!A) { fprintf( stderr, "ERROR: tilt3d_mat_scale: NULL pointer\n" ); goto tilt3d_mat_scale_error; } if (scale!=1.0) for (i=0;i<3;i++) for (j=0;j<3;j++) A[i][j] *= scale; status = 0; tilt3d_mat_scale_error: return( status ); } // tilt3d_mat_scale /*+++------------------------------------------------------------------------ NAME tilt3d_mat_transpose --- transpose a 3-dimensional matrix SYNOPSIS int tilt3d_mat_transpose ( double A[3][3] ) DESCRIPTION A[3][3] = Transpose(A[3][3]) RETURN VALUE status ----------------------------------------------------------------------------*/ int tilt3d_mat_transpose ( double A[3][3] ) { int j,k; double tmp; for (j=0;j<3;j++) for (k=0;ktilt3d_eps ) is_not_tilt=1; else { is_not_tilt=0; for (i=0;i<3;i++) { len=0.0; for (j=0;j<3;j++) len+=R[i][j]*R[i][j]; if (fabs(len-1.0)>tilt3d_eps) { is_not_tilt=1; break; } } } tilt3d_isnottilt_error: return( is_not_tilt ); } // tilt3d_isnottilt /*--------------------------------------------------------------------------- NAME tilt3d_matrix SYNOPSIS int tilt3d_matrix(double TILT[3], double R[3][3]); DESCRIPTION input: double TILT[3] (angles tilt1f, tilt2f, tilt3f) updated: double R[3][3] (3d rotation matrix) RETURN VALUE status ---------------------------------------------------------------------------*/ int tilt3d_matrix(double TILT[3], double R[3][3]) { int status=-1; double c1, c2, c3, c13; double s1, s2, s3, s13; double tilt1, tilt2, tilt3; if ((!TILT)||(!R)) { fprintf( stderr, "ERROR: tilt3d_matrix: NULL pointer\n" ); goto tilt3d_matrix_error; } // tilt1 = TILT[0]+pi/2 = tilt1f+pi/2 tilt1=TILT[0]+tilt3d_pi*0.5; tilt2=TILT[1]; tilt3=TILT[2]; c1 = cos(tilt1); c2 = cos(tilt2); c3 = cos(tilt3); s1 = sin(tilt1); s2 = sin(tilt2); s3 = sin(tilt3); c13 = cos(tilt1+tilt3); s13 = sin(tilt1+tilt3); R[0][0] = c1 * c13 + s1 * c2 * s13; R[1][0] = s1 * c13 - c1 * c2 * s13; R[2][0] = s2 * s13; R[0][1] = -s1 * c2 * c13 + c1 * s13; R[1][1] = c1 * c2 * c13 + s1 * s13; R[2][1] = -s2 * c13; R[0][2] = -s1 * s2; R[1][2] = c1 * s2; R[2][2] = c2; status = 0; tilt3d_matrix_error: return( status ); } // tilt3d_matrix /*--------------------------------------------------------------------------- NAME tilt3d_inverse_matrix SYNOPSIS int tilt3d_inverse_matrix(double TILT[3], double R[3][3]); DESCRIPTION input: double TILT[3] (angles tilt1f, tilt2, tilt3) updated: double R[3][3] (inverse 3d rotation matrix) RETURN VALUE status ---------------------------------------------------------------------------*/ int tilt3d_inverse_matrix(double TILT[3], double R[3][3]) { int status=-1; if ( (status=tilt3d_matrix(TILT, R)) ) goto tilt3d_inverse_matrix_error; if ( (status=tilt3d_mat_transpose (R)) ) goto tilt3d_inverse_matrix_error; tilt3d_inverse_matrix_error: return( status ); } // tilt3d_inverse_matrix /*--------------------------------------------------------------------------- NAME tilt3d_angles SYNOPSIS int tilt3d_angles(double TILT[3], double R[3][3]); DESCRIPTION input: double R[3][3] (rotation matrix) output: double TILT[3] (angles tilt1f, tilt2f, tilt3f) Calculate Tilt[] from an arbitrary 3d rotation matrix R[][]. t11 -> R[0][0] t12 -> R[1][0] t13 -> R[2][0] t21 -> R[0][1] t22 -> R[1][1] t23 -> R[2][1] t31 -> R[0][2] t32 -> R[1][2] t33 -> R[2][2] Tilt1[R_] := If [ ( 1 - Abs[t33] ) > Eps, ArcTan[t32, -t31], If [ t33 > 0, 0, (If [ t12 >= 0, ArcTan[t11, t12], ArcTan[t11, t12] + 2 Pi ] - tilt3)/2 ] ] /. {tilt3 -> 0} Tilt2[R_] := If [ Abs[Sin[Tilt1[R]]] > Eps, ArcTan[t33, -t31/Sin[Tilt1[R]]], ArcTan[t33, t32/Cos[Tilt1[R]]] ] if (tilt2<0) tilt1+=Pi and recalculate tilt2 Tilt3[R_] := If [ Abs[Sin[Tilt2[R]]] > Eps, ArcTan[-t23/Sin[Tilt2[R]], t13/Sin[Tilt2[R]]] - Tilt1[R], If [ t33 > 0, ArcTan[t22, t21], If [ t12 > 0, ArcTan[t11, t12] - 2 Tilt1[R], ArcTan[t11, t12] - 2 Tilt1[R] + 2 Pi ] ] ] updated: double TILT[3] (angles tilt1f, tilt2, tilt3) input: double R[3][3] (3d rotation matrix) principal ranges of the output Tilt[] angles: Tilt[0] ] -Pi .. +Pi ] (Tilt[0]=tilt1-pi/2) Tilt[1] [ 0 .. +Pi ] (Tilt[1]=tilt2) Tilt[2] ] -Pi .. +Pi ] (Tilt[2]=tilt3) RETURN VALUE status ---------------------------------------------------------------------------*/ int tilt3d_angles(double TILT[3], double R[3][3]) { int status=-1; double tilt1=0.0, tilt2=0.0, tilt3=0.0; // set defaults double c1; double s1, s2; double determinante=0.0, scale=1.0; if ((!TILT)||(!R)) { fprintf( stderr, "ERROR: tilt3d_angles: NULL pointer\n" ); goto tilt3d_angle_error; } determinante = tilt3d_determinante( R ); if ( determinante < tilt3d_eps ) { fprintf( stderr, "ERROR: tilt3d_angles: Det(R) = %lg is not positive\n", determinante ); goto tilt3d_angle_error; } scale = pow( determinante, 1.0/3.0 ); // TILT[0] = tilt1f = tilt1-pi/2 TILT[0] = tilt1-tilt3d_pi*0.5; TILT[1] = tilt2; TILT[2] = tilt3; if ( (status=tilt3d_mat_scale ( R, scale )) ) { goto tilt3d_angle_error; } if ( tilt3d_isnottilt ( R ) ) { fprintf( stderr, "ERROR: tilt3d_angles: R is not a rotation matrix\n"); goto tilt3d_angle_error; } // tilt1 (default tilt3->0) if ( ( 1.0 - fabs(R[2][2]) ) > tilt3d_eps ) { tilt1 = atan2(-R[0][2],R[1][2]); } else { if ( R[2][2] > 0.0 ) { tilt1 = 0.0; } else { if ( R[1][0] >= 0.0 ) { tilt1 = (atan2(R[1][0],R[0][0]) - tilt3)*0.5; } else { tilt1 = (atan2(R[1][0],R[0][0]) + 2.0*tilt3d_pi - tilt3)*0.5 ; } } } if (fabs(tilt1+tilt3d_pi)tilt3d_pi) tilt1-=tilt3d_pi*2.0; if (tilt1<=-tilt3d_pi) tilt1+=tilt3d_pi*2.0; c1 = cos(tilt1); s1 = sin(tilt1); // tilt2 do { if ( fabs(s1) > tilt3d_eps ) { tilt2 = atan2(-R[0][2]/s1, R[2][2]); } else { tilt2 = atan2(R[1][2]/c1, R[2][2]); } if (fabs(tilt2+tilt3d_pi)tilt3d_pi ) tilt2-=tilt3d_pi*2.0; if (tilt2<=-tilt3d_pi) tilt2+=tilt3d_pi*2.0; if ( tilt2<0.0 ) { if (tilt2<=-tilt3d_eps) { tilt1 += tilt3d_pi; if (tilt1>tilt3d_pi) tilt1-=tilt3d_pi*2.0; } else tilt2=0.0; } } while ( tilt2<0.0 ); s2 = sin(tilt2); // tilt3 if ( fabs(s2) > tilt3d_eps ) { tilt3 = atan2(R[2][0]/s2,-R[2][1]/s2) - tilt1; } else { if ( R[2][2] > 0.0 ) { tilt3 = atan2(R[0][1],R[1][1]); } else { tilt3 = atan2(R[1][0],R[0][0]) - 2.0*tilt1; } } if (fabs(tilt3+tilt3d_pi)tilt3d_pi) tilt3-=tilt3d_pi*2.0; if (tilt3<=-tilt3d_pi) tilt3+=tilt3d_pi*2.0; // TILT[0] = tilt1f = tilt1-pi/2 TILT[0] = tilt1-tilt3d_pi*0.5; TILT[1] = tilt2; TILT[2] = tilt3; if ( (TILT[0]) > tilt3d_pi ) TILT[0]-=tilt3d_pi*2.0; else if ( (TILT[0]) <= -tilt3d_pi ) TILT[0]+=tilt3d_pi*2.0; status = 0; tilt3d_angle_error: return( status ); } // tilt3d_angles spd-1.3.0/edfpack/strlib.h0000644000175000017500000000776711655560076012323 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME strlib.h SYNOPSIS #include "strlib.h" DESCRIPTION Header of the module "strlib.c" ***********************************************************************---*/ #ifndef _STRLIB_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include # include /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern int // returns 1 if c is white space strlib_is_white ( char c ), // returns 1 if s is not a skip pattern: "." | "..." | "-" strlib_is_no_skip( const char * s ), // returns 1 if s either NULL, has length 0 or contains only white spaces strlib_is_empty( const char *s ), // splits s at each white space and write pointers to sv[] strlib_split ( char *sv[], int sc, char * s ), // non case sensitive comparison (compatible to strncasecmp) strlib_ncasecmp(const char *s1, const char *s2, size_t n); PUBLIC extern char // concatenate strings a and b *strlib_concat( char * buffer, size_t buflen, const char * a, const char * b ), // terminates string at comment char '#' *strlib_uncomment ( char * s ), // removes leading and trailing white spaces *strlib_trim ( char * s ), // collapses multiple white spaces in s to a single space *strlib_collapse ( char * s ), // converts s to uppercase *strlib_toupper ( char * s ), // converts s to lowercase *strlib_tolower ( char * s ), // copies parameter parno to buffer and returns pointer *strlib_param ( char * buffer, size_t buflen, const char *s, char separator, int parno ), // split a string into tokens *strlib_tok(char *s, const char *sep), // split a string into tokens (thread safe) *strlib_tok_r(char *s, const char *sep, char **lasts), // copy input string into new allocated memory *strlib_newstr( const char *string ); PUBLIC extern const char // return version string *strlib_version ( void ); # define _STRLIB_ #endif /* _STRLIB_ */ /**************************************************************************** * * ****************************************************************************/ spd-1.3.0/edfpack/r2t.h0000644000175000017500000000635711633462462011521 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME r2t.h SYNOPSIS #include "r2t.h" DESCRIPTION Header of the module "r2t.c" Routines to convert beam distance and beam center to sample distance and center and vice versa. ***********************************************************************---*/ #ifndef _r2t_ # define _r2t_ /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include /*************************************************************************** * Definitions * ***************************************************************************/ /**************************************************************************** * Enums and Structures * ****************************************************************************/ /**************************************************************************** * Functions * ****************************************************************************/ const char *r2t_version ( void ); int r2t_bcen1( double *bcen1, double pix1, double cen1, double dis, double R[3][3] ); int r2t_bcen2( double *bcen2, double pix2, double cen2, double dis, double R[3][3] ); int r2t_bdis ( double *bdis, double dis, double R[3][3] ); int r2t_cen1 ( double *cen1, double pix1, double bcen1, double bdis, double R[3][3] ); int r2t_cen2 ( double *cen2, double pix2, double bcen2, double bdis, double R[3][3] ); int r2t_dis ( double *dis, double bdis, double R[3][3] ); /***************************************************************************/ #endif spd-1.3.0/edfpack/tilt3d.h0000644000175000017500000000627711635105403012205 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME tilt3d.h SYNOPSIS #include "tilt3d.h" DESCRIPTION Header of the module "tilt3d.c" Calculate a 3d rotation matrix for tilt1, tilt2, tilt3 or its inverse. Calculate tilt1, tilt2 and tilt3 from a 3d rotation matrix. ***********************************************************************---*/ #ifndef _tilt3d_ # define _tilt3d_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include /**************************************************************************** * Enums and Structures * ****************************************************************************/ /**************************************************************************** * Functions * ****************************************************************************/ PUBLIC extern const char *tilt3d_version ( void ); PUBLIC extern double tilt3d_determinante ( double A[3][3] ); PUBLIC extern int tilt3d_angles(double TILT[3], double R[3][3]); PUBLIC extern int tilt3d_matrix(double TILT[3], double R[3][3]); PUBLIC extern int tilt3d_inverse_matrix(double TILT[3], double R[3][3]); /***************************************************************************/ #endif spd-1.3.0/edfpack/poisson.c0000644000175000017500000001516211633462462012471 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define POISSON_VERSION "poisson : V1.1 Peter Boesecke 2007-02-21" /*+++------------------------------------------------------------------------ NAME gauss --- routines for poissonian distributions SYNOPSIS # include poisson.h HISTORY 2000-11-17 V0.0 Peter Boesecke creation, problem in SumPoisson20 All routines to approximate SumPoisson taken from http://www.io.com/~ritter/JAVASCRP/BINOMPOI.HTM 2000-11-18 V0.1 PB InvSumPoisson loop improved 2000-11-18 V0.2 SumPoisson works now correctly 2000-11-22 V1.0 Generates now correct mean and sigma 2007-02-21 V1.1 POISSON_VERSION updated and pi defined as constant. SaxsDefinition.h is not needed any more ----------------------------------------------------------------------------*/ # include "poisson.h" #ifndef ROUND # define ROUND( x ) floor( ( x ) + 0.5 ) #endif #ifndef MAX2 # define MAX2( x, y ) (( x ) < ( y ))?( y ):( x ) #endif long fac( long x ) // x! { long t = 1l; while (x > 1l) t *= x--; return( t ); } /* fac */ double logfac( long x ) // log(x!) { // by Stirling's formula Knuth I: 111 const double pi = 3.1415926535897932384626; double invx, invx2, invx3, invx5, invx7; double sum; if (x <= 1l) x = 1l; if (x < 12l) return log( fac( x ) ); else { invx = (double) 1.0 / (double) x; invx2 = invx * invx; invx3 = invx2 * invx; invx5 = invx3 * invx2; invx7 = invx5 * invx2; sum = ((x + 0.5) * log(x)) - x; sum += log(2*pi) * 0.5; sum += (invx / 12.0) - (invx3 / 360.0); sum += (invx5 / 1260.0) - (invx7 / 1680.0); return ( sum ); } } /* logfac */ double g( double x ) { // Peizer & Pratt 1968, JASA 63: 1416-1456 const double eps = 1e-10; const double switchlev = 0.1; double z, d, di; long i; if (x == 0) z = 1; else if (fabs(x-1.0) switchlev) z = (1.0 - (x * x) + (2.0 * x * log(x))) / (d * d); else { z = d / 3.0; // first term di = d; // d**1 for (i = 2l; i <= 7l; i++) { di *= d; // d**i z += (2.0 * di) / ((i+1) * (i+2)); } } } return ( z ); } /* g */ double IntGauss1( double x ) { // Abramowitz & Stegun 26.2.19 double d1 = 0.0498673470, d2 = 0.0211410061, d3 = 0.0032776263, d4 = 0.0000380036, d5 = 0.0000488906, d6 = 0.0000053830; double a,t; a = fabs(x), t = 1.0 + a*(d1+a*(d2+a*(d3+a*(d4+a*(d5+a*d6))))); // to 16th power t *= t; t *= t; t *= t; t *= t; t = 1.0 / (t+t); // the MINUS 16th if (x >= 0) t = 1-t; return( t ); } /* IntGauss1 */ double SumPoisson20( long k, double u ) // Integral(0,k,Poisson(k,u)) for k>20 { // Peizer & Pratt 1968, JASA 63: 1416-1456 double s; double d1, d2; double z; s = (double) k + (double) (1.0/2.0); d1 = (double) k - u + (double) (2.0/3.0); d2 = d1 + (double) 0.02/(double) (k+1l); z = (1.0 + g(s/u)) / u; z = d2 * sqrt(z); z = IntGauss1( z ); return( z ); } /* SumPoisson20 */ double Poisson( long k, double ny ) // poisson distribution { double value = 1.0; long i; double logsum = 0.0; for (i=1;i<=k;i++) { logsum += log(ny/i); } value *= exp(-ny+logsum); return ( value ); } /* Poisson */ double Poisson1( long k, double ny ) // poisson distribution Sterling { return ( exp(-ny+log(ny)*k-logfac(k)) ); } /* Poisson */ double SumPoisson( long k, double ny ) // Sum(0,k,Poisson(k,ny)) /* cumulative sum of the poisson distribution */ { double sum; long j; if (k >= 20) sum = SumPoisson20( k, ny ); else { sum = 0.0; j = 0; while (j <= k) if (j<12) sum += Poisson( j++, ny ); else sum += Poisson1( j++, ny ); if (sum > 1.0) sum = 1.0; } return( sum ); } /* SumPoisson */ double IntPoisson( double k, double ny ) // Integral(0,k,Poisson(k,ny)) { // interpolation of SumPoisson long k1, k2; double y1; double value; k1 = floor(k); k2 = k1+1; y1 = SumPoisson( k1 , ny ); value = y1 + Poisson( k2 , ny ) * (k-k1); return( value ); } /* IntPoisson */ long InvSumPoisson ( double y, double ny ) // Inverted SumPoisson { // Newton tangential approximation const int imax = 200; const double diffeps = 1e-14; const double amin = 1e-16; double k, kold; double yn; double a, b; double eps; int i=0; if (ny<1e-6) return( 0.0 ); if (ny>1) eps = sqrt(ny)/10.0; else eps = ny/10.0; k = ny; for (i=1;i0) && ( 1.0-yn < diffeps )) break; if ((a<0) && ( yn < diffeps )) break; b = yn-a*k; kold =k; k = (y - b)/a; if (k<0) k=0; if (fabs(k-kold). */ # define STRLIB_VERSION "strlib : V1.04 Peter Boesecke 2011-10-22" /*--------------------------------------------------------------------------- NAME strlib.c --- string functions DESCRIPTION Collection of string functions. HISTORY 2011-04-27 V1.0 Peter Boesecke 2011-05-14 V1.01 PB functions renamed from str.. to strlib_..., strlib_ncasecmp, strlib_toupper, strlib_tolower added, strlib_collapse collapses always to a single space. 2011-05-25 V1.02 PB strlib_toupper, strlib_tolower: corrected 2011-06-30 V1.03 PB strlib_concat added 2011-10-22 V1.04 PB strlib_tok and strlib_tok_r added ---------------------------------------------------------------------------*/ /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include "strlib.h" /*************************************************************************** * Defines * ***************************************************************************/ # define BUFLEN EdfMaxLinLen+1 # ifndef MIN # define MIN( n1, n2) ( ( n1)<( n2) ? ( n1) : ( n2) ) # endif # ifndef ABS # define ABS( n1) ( ( n1)<0 ? -( n1) : ( n1) ) # endif /**************************************************************************** * Static Variables * ****************************************************************************/ PRIVATE char white_spaces[7] = { ' ', '\t', '\r', '\n', '\f', '\v', '\0' }; /**************************************************************************** * Functions * ****************************************************************************/ /*-------------------------------------------------------------------------- NAME strlib_version --- returns pointer to the version string SYNOPSIS const char *strlib_version ( void ); DESCRPTION Returns pointer to the version string. --------------------------------------------------------------------------*/ PUBLIC const char *strlib_version ( void ) { return ( STRLIB_VERSION ); } /* strlib_version */ /*--------------------------------------------------------------------------- NAME strlib_is_white SYNOPSIS int strlib_is_white ( char c ); DESCRIPTION Returns 1 if c is a white space, 0, if not. HISTORY 18-Jan-1998 Peter Boesecke ---------------------------------------------------------------------------*/ PUBLIC int strlib_is_white ( char c ) { if (!c) return(0); // no white space if ( strchr( white_spaces, (int) c ) ) return(1); // white space else return(0); // no white space } /* strlib_is_white */ /*--------------------------------------------------------------------------- NAME strlib_is_no_skip --- returns 0 when the input string is a skip pattern. SYNOPSIS int strlib_is_no_skip( const char * s ); DESCRIPTION Checks, if the input string is a skip sign: "...", "-", ".". RETURN VALUE Returns only 0, when the input string is a skip sign. ---------------------------------------------------------------------------*/ PUBLIC int strlib_is_no_skip( const char * s ) { int value=0; value = strcmp ( s, "..." ); if (value) value = strcmp ( s, "-" ); if (value) value = strcmp ( s, "." ); return ( value ); } // strlib_is_no_skip /*--------------------------------------------------------------------------- NAME strlib_is_empty --- returns 1 if the input string is empty or not allocated SYNOPSIS int strlib_is_empty( const char *s ); DESCRIPTION Rreturns 1 if the input string s contains only white space, if it has the length 0, or is the NULL pointer, otherwise 0. RETURN VALUE 1: if string is empty, 0: otherwise ---------------------------------------------------------------------------*/ PUBLIC int strlib_is_empty( const char *s ) { const char *ps; int empty=1; if (s) { ps = s; while (*ps) { empty = empty&&strlib_is_white(*ps); ps++; } } return( empty ); } // strlib_is_empty /*--------------------------------------------------------------------------- NAME strlib_uncomment --- removes comments SYNOPSIS char * strlib_uncomment ( char * s ); DESCRIPTION Truncates the string at the comment char ('#'). RETURN VALUE Pointer to the modified input string. ---------------------------------------------------------------------------*/ PUBLIC char * strlib_uncomment ( char * s ) { char *ps; if (!s) return(""); ps=s; // copy ps2 to ps1 until end of string or comment char while ( *ps ) { if (*ps == '#') break; ps++; } // terminate string *ps='\0'; return( s ); } // strlib_uncomment /*--------------------------------------------------------------------------- NAME strlib_trim --- removes leading and trailing white spaces SYNOPSIS char * strlib_trim ( char * s ); DESCRIPTION Removes leading and trailing white spaces from the input string. RETURN VALUE Pointer to the modified input string. ---------------------------------------------------------------------------*/ PUBLIC char * strlib_trim ( char * s ) { char *ps1, *ps2; if (!s) return(""); ps1=ps2=s; // search first non-white character (nul is not a white space) while ( strlib_is_white( *ps2 ) ) ps2++; // copy ps2 to ps1 until end of string while ( *ps2 ) { *ps1++=*ps2++; } // terminate string *ps1='\0'; // remove trailing white spaces while ( --ps1>=s ) { if ( !strlib_is_white(*ps1) ) break; *ps1='\0'; } return( s ); } // strlib_trim /*--------------------------------------------------------------------------- NAME strlib_collapse --- collapses to single white spaces SYNOPSIS char * strlib_collapse ( char * s ); DESCRIPTION Collapses multiple white spaces to a single space ' '. RETURN VALUE Pointer to the modified input string. ---------------------------------------------------------------------------*/ PUBLIC char * strlib_collapse ( char * s ) { char *ps1, *ps2; if (!s) return(""); ps1=ps2=s; while (*ps2) { // copy ps2 to ps1 until next white space while ( (*ps2) && (!strlib_is_white( *ps2 )) ) { *ps1++=*ps2++; } // write a single white space if (*ps2) { *ps1++ = ' '; ps2++; } // search first non-white character while ( strlib_is_white( *ps2 ) ) ps2++; } // terminate string *ps1='\0'; return( s ); } // strlib_strcollapse /*--------------------------------------------------------------------------- NAME strlib_split --- splits string at white spaces SYNOPSIS int strlib_split ( char *sv[], int sc, char * s ); DESCRIPTION Splits s white spaces into substrings and writes the pointers to the first sc-1 substrings into subsequent cells of sv[]. All white spaces in s are replaced with character '\0' as terminator. The length of sv is sc. The pointers in sv are valid as long as the string s exists. RETURN VALUE Number of substring pointers in sv[]. ---------------------------------------------------------------------------*/ PUBLIC int strlib_split ( char *sv[], int sc, char * s ) { char *nul = (char *) NULL; int cnt=0; char *ps; if ((!s)||(!sv)||(!sc)) return(0); ps=s; cnt=0; // skip leading white spaces while (strlib_is_white( *ps )) ps++; while (*ps) { if (cnt+1 = "<1><2><3>..." RETURN VALUE Pointer to the filled output buffer or NULL if parameter string is not available. A parameter between two separators that immediately follow each other is returned as an empty string. ----------------------------------------------------------------------------*/ PUBLIC char * strlib_param ( char * buffer, size_t buflen, const char *s, char separator, int parno ) { size_t len; char *tmp=NULL; const char *str1, *str2, *strend; int cnt; if (!s) goto strlib_param_error; // missing input string if (parno<0) goto strlib_param_error; // parameter is not available len = strlen(s); if ( !( tmp = (char*) malloc( sizeof(char)*(len+1) )) ) goto strlib_param_error; // copy s into temporary buffer strcpy (tmp, s); strend = tmp+len; cnt = 0; str1 = tmp; str2 = str1-1; while ( cnt++ < parno ) { // start numbering before the first separator // set str1 to start of parameter if ( str2 < strend ) { str1 = ++str2; // skip separator } else { goto strlib_param_error; // no more parameter available } // search end of parameter if ( (str2 = strchr (str1, separator)) == (char *) NULL) { str2 = strend; } } // copy parameter len = MIN(buflen,(size_t) (str2-str1+1))-1; strncpy (buffer, str1, len); buffer[len] = '\0'; if (tmp) free( tmp ); return( buffer ); strlib_param_error: if (tmp) free( tmp ); return( (char *) NULL ); } // strlib_parameter /*--------------------------------------------------------------------------- NAME strlib_toupper --- converts all characters to upper case SYNOPSIS char * strlib_toupper ( char * s ); DESCRIPTION Converts all characters to upper case and returns pointer to input string. RETURN VALUE Pointer to input string ---------------------------------------------------------------------------*/ PUBLIC char * strlib_toupper ( char * s ) { char * ps; if(s) { ps=s; while ( *ps ) { *ps=(char)toupper(*ps); ps++; } } return(s); } // strlib_toupper /*--------------------------------------------------------------------------- NAME strlib_tolower --- converts all characters to lower case SYNOPSIS char * strlib_tolower ( char * s ); DESCRIPTION Converts all characters to lower case and returns pointer to input string. RETURN VALUE Pointer to input string ---------------------------------------------------------------------------*/ PUBLIC char * strlib_tolower ( char * s ) { char * ps; if (s) { ps=s; while ( *ps ) { *ps=(char)tolower(*ps); ps++; } } return(s); } // strlib_tolower /*--------------------------------------------------------------------------- NAME strlib_ncasecmp --- strncasecmp SYNOPSIS int strlib_ncasecmp(const char *s1, const char *s2, size_t n); DESCRIPTION The function compares the first n characters ot the two strings s1 and s2, ignoring the case of the characters. It returns an integer less than, equal to, or greater than zero if s1 is less than, matches, or is greater than s2. It can be used instead of the function strncasecmp if this function is not available. NULL pointers are treated as empty strings. RETURN VALUE The function returns an integer less than, equal to, or greater than zero. ---------------------------------------------------------------------------*/ PUBLIC int strlib_ncasecmp(const char *s1, const char *s2, size_t n) { int value; size_t s1len, s2len; char *_s1, *_s2; register unsigned int i; if (!s1) s1=""; if (!s2) s2=""; s1len = strlen(s1); s1len = (s1len. */ # define ARC_VERSION "arc : V1.9 Peter Boesecke 2011-06-28" /*+++------------------------------------------------------------------------ NAME arc --- routines for arc and ang averaging SYNOPSIS # include arc.h HISTORY 2005-10-28 V1.0 Peter Boesecke 2007-04-19 V1.2 PB -Wall compiler warnings resolved 2009-10-02 V1.3 PB arc_lfactor moved to SaxsRoutines, Success -> 0, SaxsArc -> arc include only ipol.h and reference.h 2010-03-05 V1.4 PB Problems averaging in a single step: ang_sum, arc_sum: limits, steps etc. improved, angular range limited to 360 degrees, ang_sum: averaging in a single step possible 2010-03-19 V1.5 PB ang_limits parameter changed to use waxs_Range. ang_range, waxs included 2010-03-20 V1.6 PB ang_limits: condition for min_angle corrected 2010-05-31 V1.7 PB update for waxs.c V1.10 2010-06-02 V1.8 PB maximum regrouping range 360_deg, splitted in 3 ranges 2011-06-28 V1.9 PB waxs_get_transform and waxs_Transform updated ----------------------------------------------------------------------------*/ /****************************************************************************** * Include Files * ******************************************************************************/ # include "arc.h" /****************************************************************************** * Private Constants * ******************************************************************************/ static const double arc_rad2deg = 180.0/NUM_PI; static const double arc_radius_eps = 1e-32; static const double arc_angle_eps = 1e-32; static const float arc_twopi = 2.0*NUM_PI; /****************************************************************************** * Private Definitions * ******************************************************************************/ # define CALC_DIST(A) sqrt((A[0])*(A[0])+(A[1])*(A[1])) /****************************************************************************** * Routines * ******************************************************************************/ /*+++------------------------------------------------------------------------ NAME ang_range SYNOPSIS int ang_range( int rsys, int proin, int proout, long dim_1, long dim_2, float off_1, float pix_1, float cen_1, float off_2, float pix_2, float cen_2, float dis, float wvl, float detrot1, float detrot2, float detrot3, WaxsCoord *Wmin, WaxsCoord *Wmax, int * pstatus); DESCRIPTION Returns the maximum and minimum world coordinates of the cartesian input image in referecne system rsys. A transformation from Saxs to Waxs or vice versa is only done if the reference system rsys is IO_Saxs. In all other cases proin and proout are ignored. Wmin.s_1 : Wmin_1 Wmin.s_2 : Wmin_2 Wmax.s_1 : Wmax_1 Wmax.s_2 : Wmax_2 RETURN VALUE -1: inverse projection transformation (WAXS->SAXS) 0: no transformation 1: normal projection transformation (SAXS->WAXS) -------------------------------------------------------------------------+*/ int ang_range( int rsys, int proin, int proout, long dim_1, long dim_2, float off_1, float pix_1, float cen_1, float off_2, float pix_2, float cen_2, float dis, float wvl, float detrot1, float detrot2, float detrot3, WaxsCoord *Wmin, WaxsCoord *Wmax, int * pstatus) { float Off_11, Off_21; float Ps_11, Ps_21; float f10, f20, f11, f21; double K=1.0, rot1=0.0, rot2=0.0, rot3=0.0; WParams I1params, I0params; int transform=0; // no transformation int status=0; if (pstatus) *pstatus = status; /* Use waxs_Transform only if reference system is Saxs and if either the input or the output image is in Saxs projection, but not if both images are in Saxs projection and the rotations are Zero. */ if ( (rsys==IO_Saxs)&&((proin==IO_ProSaxs)||(proout==IO_ProSaxs)) &&(!((proin==proout)&&(detrot1==0.0)&&(detrot2==0.0)&&(detrot3==0.0))) ) { K = (double) WAVENUMBER(wvl); rot1 = (double) detrot1; rot2 = (double) detrot2; rot3 = (double) detrot3; waxs_Init ( &I1params, K, rot1, rot2, rot3 ); waxs_Init ( &I0params, K, 0.0, 0.0, 0.0 ); /* Get coordinate range */ transform=waxs_Range( &I1params, &I0params, proin, proout, dim_1, dim_2, off_1, pix_1, cen_1, off_2, pix_2, cen_2, dis, wvl, Wmin, Wmax, &status); if (status) goto ang_range_error; } else { /* Get world coordinate range of input image */ switch (rsys) { case IO_Saxs: // SAXSREF(Off,Ps,O,P,C,S,W) SAXSREF(Off_11,Ps_11,off_1,pix_1,cen_1,dis,wvl); SAXSREF(Off_21,Ps_21,off_2,pix_2,cen_2,dis,wvl); break; case IO_Normal: NORMALREF(Off_11,Ps_11,off_1,pix_1,cen_1); NORMALREF(Off_21,Ps_21,off_2,pix_2,cen_2); break; default: status=-1; goto ang_range_error; } f10 = f20 = A2INDEX(ARRAYSTART+LOWERBORDER); f11 = A2INDEX(ARRAYSTART+LOWERBORDER+dim_1); f21 = A2INDEX(ARRAYSTART+LOWERBORDER+dim_2); if (Wmin) { Wmin->s_1 = WORLD(f10,Off_11,Ps_11); // W1min_1 Wmin->s_2 = WORLD(f20,Off_21,Ps_21); // W1min_2 } if (Wmax) { Wmax->s_1 = WORLD(f11,Off_11,Ps_11); // W1max_1 Wmax->s_2 = WORLD(f21,Off_21,Ps_21); // W1max_2 } } return ( transform ); ang_range_error: if (pstatus) *pstatus = status; return ( transform ); } // ang_range /*+++------------------------------------------------------------------------ NAME ang_limits SYNOPSIS void ang_limits( WaxsCoord Wmin, WaxsCoord Wmax, WaxsCoord *Amin, WaxsCoord *Amax, int * pstatus); DESCRIPTION Returns the maximum and minimum distances of the output image. The returned distances are absolute values in world distances, the angles are returned in radian. Amin.s_1 : minimum radius Amax.s_1 : maximum radius Amin.s_2 : minimum angle Amax.s_2 : maximum angle | | | | G | H | I | | _________|_________|_________ edge4| |edge3 | | D | E | F | | _________|_________|_________ edge1| |edge2 | | A | B | C | | | | RETURN VALUE void -------------------------------------------------------------------------+*/ void ang_limits( WaxsCoord Wmin, WaxsCoord Wmax, WaxsCoord *Amin, WaxsCoord *Amax, int * pstatus) { float edge1[2], edge2[2], edge3[2], edge4[2]; float dist1, dist2, dist3, dist4; float min_radius, max_radius, min_angle, max_angle; if (*pstatus) pstatus=0; edge1[0] = Wmin.s_1; // WORLD(i10,Off_11,Ps_11); edge1[1] = Wmin.s_2; // WORLD(i20,Off_21,Ps_21); edge2[0] = Wmax.s_1; // WORLD(i11,Off_11,Ps_11); edge2[1] = Wmin.s_2; // edge1[1]; edge3[0] = Wmax.s_1; // edge2[0]; edge3[1] = Wmax.s_2; // WORLD(i21,Off_21,Ps_21); edge4[0] = Wmin.s_1; // edge1[0]; edge4[1] = Wmax.s_2; // edge3[1]; dist1 = CALC_DIST(edge1); dist2 = CALC_DIST(edge2); dist3 = CALC_DIST(edge3); dist4 = CALC_DIST(edge4); if ( 0.0 < edge1[0] ) { // A, D, G if ( 0.0 < edge1[1] ) { // A min_radius = dist1; max_radius = dist3; min_angle = atan2(edge2[1],edge2[0]); max_angle = atan2(edge4[1],edge4[0]); } else { if ( 0.0 < edge4[1] ) { // D min_radius = edge1[0]; max_radius = MAX2(dist2,dist3); min_angle = atan2(edge1[1],edge1[0]); max_angle = atan2(edge4[1],edge4[0]); } else { // G min_radius = dist4; max_radius = dist2; min_angle = atan2(edge1[1],edge1[0]); max_angle = atan2(edge3[1],edge3[0]); } } } else { if ( 0.0 < edge2[0] ) { // B, E, H if ( 0.0 < edge2[1] ) { // B min_radius = edge1[1]; max_radius = MAX2(dist4,dist3); min_angle = atan2(edge2[1],edge2[0]); max_angle = atan2(edge1[1],edge1[0]); } else { if ( 0.0 < edge3[1] ) { // E min_radius = 0.0; max_radius = MAX4(dist1, dist2, dist3, dist4); min_angle = 0.0; max_angle = arc_twopi; } else { // H min_radius = -edge3[1]; max_radius = MAX2(dist1,dist2); min_angle = atan2(edge4[1],edge4[0]); max_angle = atan2(edge3[1],edge3[0]); } } } else { // C, F, I if ( 0.0 < edge2[1] ) { // C min_radius = dist2; max_radius = dist4; min_angle = atan2(edge3[1],edge3[0]); max_angle = atan2(edge1[1],edge1[0]); } else { if ( 0.0 < edge3[1] ) { // F min_radius = -edge2[0]; max_radius = MAX2(dist1,dist4); min_angle = atan2(edge3[1],edge3[0]); max_angle = atan2(edge2[1],edge2[0]); } else { // I min_radius = dist3; max_radius = dist1; min_angle = atan2(edge4[1],edge4[0]); max_angle = atan2(edge2[1],edge2[0]); } } } } // output range of angles is [0..2*pi] if ( max_angles_1 = min_radius; // minimum radius Amin->s_2 = min_angle; // minimum angle } if (Amax) { Amax->s_1 = max_radius; // maximum radius Amax->s_2 = max_angle; // maximum angle } return; } // ang_limits /*--------------------------------------------------------------------------- NAME arc_sum --- Regrouping of an image from cartesian to radius/arc SYNOPSIS void arc_sum ( int rsys, float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float I0Offset_1, float I0PSize_1, float I0Center_1, float I0Offset_2, float I0PSize_2, float I0Center_2, float I0SampleDistance, float I0WaveLength, int I0Pro, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float I1Offset_1, float I1PSize_1, float I1Center_1, float I1Offset_2, float I1PSize_2, float I1Center_2, float I1SampleDistance, float I1WaveLength, float I1DetRot1, float I1DetRot2, float I1DetRot3, int I1Pro, float I1Dummy, float I1DDummy, float AngleMin, float AngleMax, float Shift_1, float Shift_2, int vsum, int ave, int testbit, int * pstatus ); PURPOSE Regrouping of an image radius/arc DESCRIPTION The routine regroupes an input image with cartesian coordinates w_1 and w_2 to an image with coordinates radius and arc. The input image is described with Normal (Offset, Center, PSize) or Saxs coordinates (Offset, Center, PSize, SampleDistance, WaveLength). Axis 1 of the regrouped image is the radius, axis 2 the arc. The reference system of output axis 2 is always Normal. The regrouping is done in the sector between AngleMin and AngleMax. If AngleMin >= AngleMax nothing is done. AngleMax is limited to AngleMin+2*pi. The part of the output image outside this range is left unchanged. (w_1, w_2) -> (radius,arc) with radius = sqrt(w_1^2+w_2^2), arc = radius*Angle and cos(Angle)=w_1/radius, sin(Angle)=w_2/radius. ARGUMENTS int rsys (i) : reference system float * I0Data (o) : output image data float * E0Data (o) : output variance data (ignored if NULL) int I0Dim_1, (i) : I0Dim_2 (i) : dimensions of output data arrays float I0Offset_1, I0PSize_1, I0Center_1, I0Offset_2, I0Center_2, I0PSize_2 (i) : output image parameters I0SampleDistance (i) : I0WaveLength (i) : I0Pro () : projection type of input image float I0Dummy, I0DDummy (i) : output image dummy definition float * I1Data (i) : input image data float * E1Data (i) : input variance data (ignored if NULL) int I1Dim_1, I1Dim_2 (i) : dimensions of input data arrays float I1Offset_1, I1PSize_1, I1Center_1, I1Offset_2, I1PSize_2, I1Center_2 (i) : input image parameters I1SampleDistance (i) : I1WaveLength (i) : I1DetRot1, I1DetRot1, I1DetRot1 (i) : detector rotations (in radian) I1Pro () : projection type of output image float AngleMin, AngleMax (i) : angular range (in rad) float Shift_1, Shift_2 (i) : shift of the output image along axis 1 and 2. The shift is usually 0. int vsum (i) : if 1, integrate output values int ave (i) : if 1, average input values int testbit (i) : if 1, write debug info int *pstatus (o) : returned status value ---------------------------------------------------------------------------*/ void arc_sum ( int rsys, float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float I0Offset_1, float I0PSize_1, float I0Center_1, float I0Offset_2, float I0PSize_2, float I0Center_2, float I0SampleDistance, float I0WaveLength, int I0Pro, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float I1Offset_1, float I1PSize_1, float I1Center_1, float I1Offset_2, float I1PSize_2, float I1Center_2, float I1SampleDistance, float I1WaveLength, float I1DetRot1, float I1DetRot2, float I1DetRot3, int I1Pro, float I1Dummy, float I1DDummy, float AngleMin, float AngleMax, float Shift_1, float Shift_2, int vsum, int ave, int testbit, int * pstatus ) { float *pI0Data, *pE0Data; float Off_10, Ps_10, Off_20, Ps_20; float Off_11, Ps_11, Off_21, Ps_21; float I1Value, I1Sum, I1Weight, I1ArcSum, I1ArcSumWeight; float E1Value, E1Sum, E1Weight, E1ArcSum, E1ArcSumWeight; double K=1.0, rot1=0.0, rot2=0.0, rot3=0.0; WParams I1params, I0params; float Angle, DAngle, AngleLower, AngleUpper; float MinArc, MaxArc; float AngleFst, AngleLst; float MinRadius, MaxRadius, MinAngle, MaxAngle; float W0_2Fst, W0_2Lst; float W0_2Min, W0_2Max; WaxsCoord W1min, W1max, A1min, A1max; WaxsCoord W0, W1; int transform=0; int i_1, i_2; int i_20, i_22; float f_11, f_21; float DDArc, DArc, Arc, Radius; int NArc, iarc; float VarDDummy=DDSET(VarDummy); float factor; int cnt, varcnt; int status=0; if (testbit) printf("arc_sum: AngleMin=% g_deg, AngleMax=% g_deg\n", AngleMin*arc_rad2deg,AngleMax*arc_rad2deg); /* Calculate pixel transformations */ switch (rsys) { case IO_Normal: if (testbit) printf("arc_sum: The refrence system is NORMAL\n"); NORMALREF(Off_11,Ps_11,I1Offset_1,I1PSize_1,I1Center_1); NORMALREF(Off_21,Ps_21,I1Offset_2,I1PSize_2,I1Center_2); NORMALREF(Off_10,Ps_10,I0Offset_1,I0PSize_1,I0Center_1); NORMALREF(Off_20,Ps_20,I0Offset_2,I0PSize_2,I0Center_2); break; case IO_Saxs: if (testbit) printf("arc_sum: The refrence system is SAXS\n"); SAXSREF(Off_11,Ps_11,I1Offset_1,I1PSize_1,I1Center_1,I1SampleDistance,I1WaveLength); SAXSREF(Off_21,Ps_21,I1Offset_2,I1PSize_2,I1Center_2,I1SampleDistance,I1WaveLength); SAXSREF(Off_10,Ps_10,I0Offset_1,I0PSize_1,I0Center_1,I0SampleDistance,I0WaveLength); SAXSREF(Off_20,Ps_20,I0Offset_2,I0PSize_2,I0Center_2,I0SampleDistance,I0WaveLength); break; default: fprintf(stderr,"ERROR: The refrence system is neither NORMAL nor SAXS (%d)\n",rsys); status=-1; goto arc_sum_error; } /* Subtract output shift for calculation */ Off_10 = Off_10-Shift_1; Off_20 = Off_20-Shift_2; if (testbit) { printf("arc_sum: Off_10 = % f, Ps_10 = % f\n", Off_10,Ps_10); printf("arc_sum: Off_20 = % f, Ps_20 = % f\n", Off_20,Ps_20); } /* loop over I0Data */ /* * Calculate the number of input image pixels that will have to be averaged * over for one output image pixel. * * Ps_11 and Ps_21 are the input image pixel sizes in x and y direction; * Ps_10 is the output image pixel size in radial direction, it is set to * be the smaller one of the input image sizes in x and y direction; * Ps_20 is the output image pixel size in angular direction, this is an * input parameter of the routine. * * The size of an "unit" pixel is therefore Ps_11 * Ps_21 (= dx * dy) in * the input image and Ps_10 * Ps_20 (= dr * da) in the output image. * * However, dx * dy is the same area over the whole image, whereas dr * da is * smaller for small values of r and bigger for big values of r. * * The area corresponding to dr * da at a given value of r is F = r * dr * * da. * Therefore, the number of input image pixels that will fit into an "unit" * output pixel is * N = F / (dx * dy), or because of the definition of dr * N = r * da / MAX(dx,dy) * * This is therefore the number of input image pixels that will have to be * averaged over for one output pixel. The actual value used (variable NAngle * further below) is an overestimate of this, to make sure that all possible * input pixels are actually taken into account. * * DDArc is an intermediate variable, it corresponds to the number of input * image pixels at r = 1. It will be used to calculate NArc later. */ DDArc = Ps_20/(MIN2(Ps_11,Ps_21)); if (testbit) printf("arc_sum: DDArc = % g_deg\n", DDArc * arc_rad2deg); /* * Calculate the minimum and maximum arc values for the input image. * The dimensions of the output image should have been adjusted with * ang_limits */ transform = ang_range( rsys, I1Pro, I0Pro, I1Dim_1, I1Dim_2, I1Offset_1,I1PSize_1,I1Center_1, I1Offset_2,I1PSize_2,I1Center_2, I1SampleDistance, I1WaveLength, I1DetRot1, I1DetRot2, I1DetRot3, &W1min, &W1max, &status); if (status) goto arc_sum_error; if (testbit) { printf("arc_sum: W1min_1=%g, W1max_1=%g\n", W1min.s_1,W1max.s_1); printf("arc_sum: W1min_2=%g, W1max_2=%g\n", W1min.s_2,W1max.s_2); printf("arc_sum: transform=%d\n",transform); } ang_limits( W1min, W1max, &A1min, &A1max, &status); if (status) goto arc_sum_error; if (testbit) { printf("arc_sum: A1min.s_1=%lg , A1max.s_1=%lg\n", A1min.s_1,A1max.s_1); printf("arc_sum: A1min.s_2=%lg_deg, A1max.s_2=%lg_deg\n", A1min.s_2*arc_rad2deg,A1max.s_2*arc_rad2deg); } MinRadius = A1min.s_1; MaxRadius = A1max.s_1; MinAngle = A1min.s_2 + floor(AngleMin/arc_twopi)*arc_twopi; MaxAngle = A1max.s_2 + floor(AngleMin/arc_twopi)*arc_twopi; // Calculate coordinate range of Arc in output image W0_2Fst = WORLD(INDEXSTART+LOWERBORDER,Off_20,Ps_20); W0_2Lst = WORLD(INDEXSTART+LOWERBORDER+I0Dim_2,Off_20,Ps_20); if (W0_2Fst <= W0_2Lst) { W0_2Min = W0_2Fst; W0_2Max = W0_2Lst; } else { W0_2Min = W0_2Lst; W0_2Max = W0_2Fst; } /* maximum range is AngleMin+2_pi*/ AngleFst = MAX2(AngleMin,MinAngle); AngleLst = MIN2(AngleMax,MaxAngle); if (testbit) { printf("arc_sum: W0_2Min=%g_deg, W0_2Max=%g_deg\n",W0_2Min*arc_rad2deg,W0_2Max*arc_rad2deg); printf("arc_sum: MinRadius=%g, MaxRadius=%g, MinAngle=%g_deg, MaxAngle=%g_deg\n", MinRadius, MaxRadius, MinAngle*arc_rad2deg, MaxAngle*arc_rad2deg ); printf("AngleFst=%g_deg, AngleLst=%g_deg\n", AngleFst*arc_rad2deg, AngleLst*arc_rad2deg ); } K = (double) WAVENUMBER(I1WaveLength); rot1 = (double) I1DetRot1; rot2 = (double) I1DetRot2; rot3 = (double) I1DetRot3; waxs_Init ( &I1params, K, rot1, rot2, rot3 ); waxs_Init ( &I0params, K, 0.0, 0.0, 0.0 ); if (testbit) { printf("I0params\n"); waxs_PrintParams ( stdout, I0params ); printf("I1params\n"); waxs_PrintParams ( stdout, I1params ); } if (AngleFst < AngleLst) { /* MinArc and MaxArc depend on the actual radius, i.e. on i_1 */ for (i_1=0;i_1 MaxRadius || Radius < MinRadius ) continue; if (testbit) printf("arc_sum: AngleFst=%g_deg, AngleLst=%g_deg\n", AngleFst*arc_rad2deg, AngleLst*arc_rad2deg ); if (Radius >= 0 ) { MinArc = MAX2(Radius*AngleFst,W0_2Min); MaxArc = MIN2(Radius*AngleLst,W0_2Max); } else { MinArc = MAX2(Radius*AngleFst,W0_2Min); MaxArc = MIN2(Radius*AngleLst,W0_2Max); } i_20=MAX2(0,floor(INDEX(MinArc,Off_20,Ps_20)-LOWERBORDER)); // first pixel in range i_22=MIN2(I0Dim_2,ceil(INDEX(MaxArc,Off_20,Ps_20)-LOWERBORDER)); // first pixel after range if (testbit>1) { printf("arc_sum: MinArc=%g, MaxArc=%g\n",MinArc*arc_rad2deg,MaxArc*arc_rad2deg); printf("arc_sum: i_20=%d, i_22=%d\n",i_20,i_22); } /* number of intervals on the arc for averaging */ NArc = MAX2(1,(int) DDArc + 1 ); DArc = Ps_20/(float) NArc; if (testbit>1) printf("arc_sum: %d: Radius=%g, NArc=%d, DArc=%g\n", i_1,Radius,NArc,DArc * arc_rad2deg); for (i_2=i_20;i_2= arc_radius_eps ) { DAngle = DArc/Radius; AngleLower = WORLD(((float)i_2+LOWERBORDER),Off_20,Ps_20)/Radius; // lower limit AngleUpper = WORLD(((float)i_2+1+LOWERBORDER),Off_20,Ps_20)/Radius; // upper limit // restrict integration range to [AngleFst..AngleLst]; AngleLower = MAX2(AngleFst,AngleLower); AngleUpper = MIN2(AngleLst,AngleUpper); } else { DAngle = 0.0; AngleLower = AngleFst; AngleUpper = AngleLst; } if (testbit>2) { printf("arc_sum: %d,%d: Arc=%g, MinArc=%g_deg, MaxArc=%g_deg\n", i_1,i_2,Arc * arc_rad2deg,MinArc * arc_rad2deg,MaxArc * arc_rad2deg); printf("arc_sum: %d,%d: AngleLower=%g_deg, AngleUpper=%g_deg\n", i_1,i_2,AngleLower*arc_rad2deg,AngleUpper*arc_rad2deg); } cnt = 0; varcnt = 0; I1ArcSum = 0.0; I1ArcSumWeight = 0.0; E1ArcSum = 0.0; E1ArcSumWeight = 0.0; for (iarc = 0; iarc= arc_radius_eps ) { Angle = Arc/Radius; W0.s_1 = Radius * cos( Angle ); // W_1 W0.s_2 = Radius * sin( Angle ); // W_2 } else { Angle = 0.0; W0.s_1 = 0.0; // W_1 W0.s_2 = 0.0; // W_2 } /* transform saxs-coordinate of unrotated detector (I0params) or Waxs- projection to saxs-coordinate of rotated detector (I1params) */ //++++++++ W1 = waxs_Transform( &I1params, &I0params, transform, W0 ); W1 = waxs_Transform( &I0params, &I1params, transform, W0 ); if (!W1.status) { /* averaging range is [AngleFst..AngleLst] */ if ( ( Angle < AngleLower ) || ( AngleUpper < Angle ) ) { if (testbit>3) printf("arc_sum: iarc=%d: Angle=%g_deg not in [%g_deg..%g_deg] => continue\n", iarc,Angle*arc_rad2deg,AngleLower*arc_rad2deg,AngleUpper*arc_rad2deg); Arc += DArc; continue; } f_11 = INDEX(W1.s_1,Off_11,Ps_11); f_21 = INDEX(W1.s_2,Off_21,Ps_21); if ( E0Data ) { // V0 = V1 if ( Isum2ldwE(I1Data,E1Data,I1Dim_1,I1Dim_2,I1Dummy,I1DDummy, f_11-0.5, f_21-0.5, f_11+0.5, f_21+0.5, &I1Sum, &I1Weight, &E1Sum, &E1Weight) ) { /* then do something with the data */ I1ArcSum += I1Sum; I1ArcSumWeight += I1Weight; if ( E1Sum >= 0.0 ) { E1ArcSum += E1Sum; E1ArcSumWeight += E1Weight; varcnt++; } cnt++; } /* if Isum2ldwE ... */ } else { if ( Isum2ldw(I1Data,I1Dim_1,I1Dim_2,I1Dummy,I1DDummy, f_11-0.5, f_21-0.5, f_11+0.5, f_21+0.5, &I1Sum, &I1Weight) ) { /* then do something with the data */ I1ArcSum += I1Sum; I1ArcSumWeight += I1Weight; cnt++; } /* if Isum2ldw ... */ } } // if (!W1.status) Arc += DArc; } /* for iarc */ if (cnt>0) { pI0Data = ABSPTR(I0Data,I0Dim_1,I0Dim_2,i_1,i_2); pE0Data = E0Data-I0Data+pI0Data; /* The following factor adjusts the size of a rectangular pixel with the size Ps_11*Ps_21 to a circular pixel with height Ps_10 and width DArc */ factor = (DArc*Ps_10)/(Ps_11*Ps_21); I1ArcSum *= factor; I1ArcSumWeight *= factor; E1ArcSum *= factor; E1ArcSumWeight *= factor; I1Value = I1ArcSum; if (ave) I1Value /= I1ArcSumWeight; if ( E0Data && ( varcnt==cnt ) ) { E1Value = E1ArcSum; if (ave) E1Value /= E1ArcSumWeight*E1ArcSumWeight; /* Take into account that the data was averaged in a sector */ } else E1Value = -1.0; if (vsum) { /* Multiply with number of covered pixels */ factor = I1ArcSumWeight; I1Value *= I1ArcSumWeight; if ( E1Value>=0 ) E1Value *= I1ArcSumWeight*I1ArcSumWeight; } UPDATE( *pI0Data, I1Value, I0Dummy, I0DDummy ); if ( E0Data && ( E1Value>=0.0 ) ) { UPDATE( *pE0Data, E1Value, VarDummy, VarDDummy ); } } /* end angular averaging */ } /* for i_2 ... */ } /* for i_1 ... */ } /* if (AngleFst < AngleLst) */ if (pstatus) *pstatus = status; return; arc_sum_error: if (pstatus) *pstatus = status; return; } /* arc_sum */ /*--------------------------------------------------------------------------- NAME ang_sum --- Regrouping of an image from cartesian to polar coordinates PURPOSE Regrouping of an image radius/arc DESCRIPTION The routine regroupes an input image with cartesian coordinates w_1 and w_2 to an image with polar coordinates. The input image is described with Normal coordinates (Offset, Center, PSize) or Saxs coordinates (Offset, Center, PSize, SampleDistance, WaveLength). Axis 1 of the regrouped image is the radius, axis 2 the angle. The reference system of output axis 2 is always Normal. The regrouping is done in the sector between AngleMin and AngleMax. If AngleMin >= AngleMax nothing is done. AngleMax is limited to AngleMin+2*pi. The part of the output image outside this range is left unchanged. (w_1, w_2) -> (radius,angle) with radius = sqrt(w_1^2+w_2^2) and cos(Angle)=w_1/radius, sin(Angle)=w_2/radius. SYNOPSIS void ang_sum ( int rsys, float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float I0Offset_1, float I0PSize_1, float I0Center_1, float I0Offset_2, float I0PSize_2, float I0Center_2, float I0SampleDistance, float I0WaveLength, int I0Pro, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float I1Offset_1, float I1PSize_1, float I1Center_1, float I1Offset_2, float I1PSize_2, float I1Center_2, float I1SampleDistance, float I1WaveLength, float I1DetRot1, float I1DetRot2, float I1DetRot3, int I1Pro, float I1Dummy, float I1DDummy, float AngleMin, float AngleMax, float Shift_1, float Shift_2, int vsum, int ave, int testbit, int * pstatus ) ARGUMENTS int rsys (i) : reference system float * I0Data (o) : output image data float * E0Data (o) : output variance data (ignored if NULL) int I0Dim_1, (i) : I0Dim_2 (i) : dimensions of output data arrays float I0Offset_1, I0PSize_1, I0Center_1, I0Offset_2, I0Center_2, I0PSize_2 (i) : output image parameters I0SampleDistance (i) : I0WaveLength (i) : I0Pro () : projection type of input image float I0Dummy, I0DDummy (i) : output image dummy definition float * I1Data (i) : input image data float * E1Data (i) : input variance data (ignored if NULL) int I1Dim_1, I1Dim_2 (i) : dimensions of input data arrays float I1Offset_1, I1PSize_1, I1Center_1, I1Offset_2, I1PSize_2, I1Center_2 (i) : input image parameters I1SampleDistance (i) : I1WaveLength (i) : I1DetRot1, I1DetRot1, I1DetRot1 (i) : detector rotations (in radian) I1Pro () : projection type of output image float AngleMin, AngleMax (i) : angular range (in rad) float Shift_1, Shift_2 (i) : shift of the output image along axis 1 and 2. The shift is usually 0. int vsum (i) : if 1, integrate output values int ave (i) : if 1, average input values int testbit (i) : if 1, write debug info int *pstatus (o) : returned status value ---------------------------------------------------------------------------*/ void ang_sum ( int rsys, float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float I0Offset_1, float I0PSize_1, float I0Center_1, float I0Offset_2, float I0PSize_2, float I0Center_2, float I0SampleDistance, float I0WaveLength, int I0Pro, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float I1Offset_1, float I1PSize_1, float I1Center_1, float I1Offset_2, float I1PSize_2, float I1Center_2, float I1SampleDistance, float I1WaveLength, float I1DetRot1, float I1DetRot2, float I1DetRot3, int I1Pro, float I1Dummy, float I1DDummy, float AngleMin, float AngleMax, float Shift_1, float Shift_2, int vsum, int ave, int testbit, int * pstatus ) { float *pI0Data, *pE0Data; float Off_10, Ps_10, Off_20, Ps_20; float Off_11, Ps_11, Off_21, Ps_21; float I1Value, I1Sum, I1Weight, I1CircleSum, I1CircleSumWeight; float E1Value, E1Sum, E1Weight, E1CircleSum, E1CircleSumWeight; double K=1.0, rot1=0.0, rot2=0.0, rot3=0.0; WParams I1params, I0params; int i_1, i_2; int i_10, i_11, i_20, i_22; float f_11, f_21; float DDAngle, DAngle, Angle, Radius; float AngleLower, AngleUpper; float angle, AngleFst, AngleLst; int NAngle, iangle, ianglefst, ianglelst; # define N_RANGES 3 float Fst[N_RANGES], Lst[N_RANGES]; int range; float MinRadius, MaxRadius, MinAngle, MaxAngle; WaxsCoord W1min, W1max, A1min, A1max; WaxsCoord W0, W1; int transform=0; float VarDDummy=DDSET(VarDummy); float factor; int cnt, varcnt; int status=0; /* restrict range to 2 pi */ AngleMax = MIN2(AngleMax,AngleMin+arc_twopi); if (testbit) { printf("ang_sum: AngleMin=% g_deg, AngleMax=% g_deg\n", AngleMin*arc_rad2deg,AngleMax*arc_rad2deg); } /* Calculate pixel transformations */ switch (rsys) { case IO_Normal: if (testbit) printf("ang_sum: The refrence system is NORMAL\n"); NORMALREF(Off_11,Ps_11,I1Offset_1,I1PSize_1,I1Center_1); NORMALREF(Off_21,Ps_21,I1Offset_2,I1PSize_2,I1Center_2); NORMALREF(Off_10,Ps_10,I0Offset_1,I0PSize_1,I0Center_1); NORMALREF(Off_20,Ps_20,I0Offset_2,I0PSize_2,I0Center_2); break; case IO_Saxs: if (testbit) printf("ang_sum: The radial refrence system is SAXS, the angular NORMAL\n"); SAXSREF(Off_11,Ps_11,I1Offset_1,I1PSize_1,I1Center_1,I1SampleDistance,I1WaveLength); SAXSREF(Off_21,Ps_21,I1Offset_2,I1PSize_2,I1Center_2,I1SampleDistance,I1WaveLength); SAXSREF(Off_10,Ps_10,I0Offset_1,I0PSize_1,I0Center_1,I0SampleDistance,I0WaveLength); NORMALREF(Off_20,Ps_20,I0Offset_2,I0PSize_2,I0Center_2); // Angle reference is NORMAL break; default: fprintf(stderr,"ERROR: The refrence system is neither NORMAL nor SAXS (%d)\n",rsys); status=-1; goto ang_sum_error; } /* Subtract output shift for calculation */ Off_10 = Off_10-Shift_1; Off_20 = Off_20-Shift_2; if (testbit) { printf("ang_sum: Off_10 = % f, Ps_10 = % f\n", Off_10,Ps_10); printf("ang_sum: Off_20 = % f, Ps_20 = % f\n", Off_20,Ps_20); } /* * Calculate the minimum and maximum arc values for the input image. * The dimensions of the output image should have been adjusted with * ang_limits */ transform = ang_range( rsys, I1Pro, I0Pro, I1Dim_1, I1Dim_2, I1Offset_1,I1PSize_1,I1Center_1, I1Offset_2,I1PSize_2,I1Center_2, I1SampleDistance, I1WaveLength, I1DetRot1, I1DetRot2, I1DetRot3, &W1min, &W1max, &status); if (status) goto ang_sum_error; if (testbit) { printf("ang_sum: W1min_1=%g, W1max_1=%g\n", W1min.s_1,W1max.s_1); printf("ang_sum: W1min_2=%g, W1max_2=%g\n", W1min.s_2,W1max.s_2); printf("ang_sum: transform=%d\n",transform); } ang_limits( W1min, W1max, &A1min, &A1max, &status); if (status) goto ang_sum_error; if (testbit) { printf("ang_sum: A1min.s_1=%lg , A1max.s_1=%lg\n", A1min.s_1,A1max.s_1); printf("ang_sum: A1min.s_2=%lg_deg, A1max.s_2=%lg_deg\n", A1min.s_2*arc_rad2deg,A1max.s_2*arc_rad2deg); } MinRadius = A1min.s_1; MaxRadius = A1max.s_1; MinAngle = A1min.s_2 + floor(AngleMin/arc_twopi)*arc_twopi; MaxAngle = A1max.s_2 + floor(AngleMin/arc_twopi)*arc_twopi; if (testbit) { printf("ang_sum: MinRadius=%g, MaxRadius=%g, MinAngle=%g_deg, MaxAngle=%g_deg\n", MinRadius, MaxRadius, MinAngle*arc_rad2deg, MaxAngle*arc_rad2deg ); } /* loop over I0Data */ DDAngle = Ps_20/(MIN2(Ps_11,Ps_21)); if (testbit) printf("ang_sum: DDAngle = % g_deg/m\n", DDAngle * arc_rad2deg); K = (double) WAVENUMBER(I1WaveLength); rot1 = (double) I1DetRot1; rot2 = (double) I1DetRot2; rot3 = (double) I1DetRot3; waxs_Init ( &I1params, K, rot1, rot2, rot3 ); waxs_Init ( &I0params, K, 0.0, 0.0, 0.0 ); if (testbit) { waxs_PrintParams ( stdout, I1params ); } // REGROUPING BEGIN { /* Parameters Ranges: Output: AngleMin, AngleMax=MIN2(AngleMin+2_pi,AngleMax) [AngleMin..AngleMax] Range1: [AngleFst1=AngleMin..AngleLst1=MIN2(AngleMax,MaxAngle-2_pi) Range2: [AngleFst2=MAX2(AngleMin,MinAngle)..AngleLst2=MIN2(AngleMax,MaxAngle)] */ /* maximum range is AngleMin .. AngleMax */ Fst[0] = MAX2(AngleMin,MinAngle); Lst[0] = MIN2(AngleMax,MaxAngle); /* 2nd range, if MaxAngle > AngleMax */ Fst[1] = AngleMin; Lst[1] = MIN2(Fst[0],MaxAngle-arc_twopi); /* 3rd range, if MaxAngle > AngleMax */ Fst[2] = MAX2(Lst[0],MinAngle+arc_twopi); Lst[2] = AngleMax; for (range=0;range1) { printf("ang_sum: i_10=%d, i_11=%d\n",i_10,i_11); printf("ang_sum: i_20=%d, i_22=%d\n",i_20,i_22); } for (i_1=i_10;i_1 MaxRadius || Radius < MinRadius ) continue; /* number of angular intervals for averaging */ NAngle = MAX2(1,(int) (DDAngle * Radius) + 1 ); DAngle = Ps_20/(float) NAngle; if (testbit>1) printf("ang_sum: %d: Radius=%g, NAngle=%d, DAngle=%g_deg\n", i_1,Radius,NAngle,DAngle*arc_rad2deg); // the integration range is from [AngleFst..AngleLst]; for (i_2=i_20;i_22) printf("ang_sum: %d,%d: Angle=%g_deg, AngleLower=%g_deg, AngleUpper=%g_deg\n", i_1,i_2,Angle*arc_rad2deg,AngleLower*arc_rad2deg,AngleUpper*arc_rad2deg); /* angular averaging */ cnt = 0; varcnt = 0; I1CircleSum = 0.0; I1CircleSumWeight = 0.0; E1CircleSum = 0.0; E1CircleSumWeight = 0.0; // Angle .. Angle+NAngle*DAngle ianglefst = 0; ianglelst = floor( (AngleUpper - AngleLower) / DAngle + 0.5); // the reduced angular range is [AngleLower..AngleUpper] angle = AngleLower + DAngle*0.5; if (testbit>2) printf("ang_sum: %d,%d: angle=%g_deg, ianglefst=%d, ianglelst=%d\n", i_1,i_2,angle*arc_rad2deg,ianglefst,ianglelst); // average only in range with valid pixels for (iangle = ianglefst; iangle3) printf("ang_sum: iangle=%d: angle=%g_deg not in [%g_deg..%g_deg] => continue\n", iangle,angle*arc_rad2deg,AngleLower*arc_rad2deg,AngleUpper*arc_rad2deg); angle += DAngle; continue; } W0.s_1 = Radius * cos( angle ); W0.s_2 = Radius * sin( angle ); /* transform saxs-coordinate of unrotated detector (I0params) or Waxs- projection to saxs-coordinate of rotated detector (I1params) */ W1 = waxs_Transform( &I0params, &I1params, transform, W0 ); if (!W1.status) { f_11 = INDEX(W1.s_1,Off_11,Ps_11); f_21 = INDEX(W1.s_2,Off_21,Ps_21); if ( E0Data ) { // V0 = V1 if ( Isum2ldwE(I1Data,E1Data,I1Dim_1,I1Dim_2,I1Dummy,I1DDummy, f_11-0.5, f_21-0.5, f_11+0.5, f_21+0.5, &I1Sum, &I1Weight, &E1Sum, &E1Weight) ) { /* then do something with the data */ I1CircleSum += I1Sum; I1CircleSumWeight += I1Weight; if ( E1Sum >= 0.0 ) { E1CircleSum += E1Sum; E1CircleSumWeight += E1Weight; varcnt++; } cnt++; } /* if Isum2ldwE ... */ } else { if ( Isum2ldw(I1Data,I1Dim_1,I1Dim_2,I1Dummy,I1DDummy, f_11-0.5, f_21-0.5, f_11+0.5, f_21+0.5, &I1Sum, &I1Weight) ) { /* then do something with the data */ I1CircleSum += I1Sum; I1CircleSumWeight += I1Weight; cnt++; } /* if Isum2ldw ... */ } } // if (!W1.status) angle += DAngle; } /* for iangle ... */ if (cnt>0) { pI0Data = ABSPTR(I0Data,I0Dim_1,I0Dim_2,i_1,i_2); pE0Data = E0Data-I0Data+pI0Data; /* The following factor adjusts the size of a rectangular pixel with the size Ps_11*Ps_21 to a circular pixel with height Ps_10 and width Radius*DAngle */ factor = (Radius*DAngle*Ps_10)/(Ps_11*Ps_21); I1CircleSum *= factor; I1CircleSumWeight *= factor; E1CircleSum *= factor; E1CircleSumWeight *= factor; I1Value = I1CircleSum; if (ave) I1Value /= I1CircleSumWeight; if ( E0Data && ( varcnt==cnt ) ) { E1Value = E1CircleSum; if (ave) E1Value /= E1CircleSumWeight*E1CircleSumWeight; /* Take into account that the data were averaged in a sector */ } else E1Value = -1.0; if (vsum) { /* Multiply with number of covered pixels */ factor = I1CircleSumWeight; I1Value *= I1CircleSumWeight; if ( E1Value>=0 ) E1Value *= I1CircleSumWeight*I1CircleSumWeight; } UPDATE( *pI0Data, I1Value, I0Dummy, I0DDummy ); if ( E0Data && ( E1Value>=0.0 ) ) { UPDATE( *pE0Data, E1Value, VarDummy, VarDDummy ); } } /* end angular averaging */ } /* for i_2 ... */ } /* for i_1 ... */ } /* if ( AngleFst < AngleLst ) */ } /* for range ... */ // REGROUPING END } if (pstatus) *pstatus = status; return; ang_sum_error: if (pstatus) *pstatus = status; return; } /* ang_sum */ spd-1.3.0/edfpack/waxs.h0000644000175000017500000001376711635105403011766 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME waxs.h SYNOPSIS #include "waxs.h" DESCRIPTION Header of the module "waxs.c" ***********************************************************************---*/ #ifndef _WAXS_ # define _WAXS_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include # include # include "reference.h" /****************************************************************************** * Public Type Defs * ******************************************************************************/ typedef struct waxs_vector { int status; double s_1; // saxs vector 1 double s_2; // saxs vector 2 double s_3; // saxs vector 3 } WaxsVector; typedef struct waxs_coordinate { int status; double s_1; // saxs coordinate 1 double s_2; // saxs coordinate 2 } WaxsCoord; typedef struct waxs_dir { int status; double sinTwoTheta; double cosTwoTheta; double sinAlpha; double cosAlpha; } WaxsDir; typedef struct waxs_params { int Init; double Rot[3][3]; // rotation matrix double InvRot[3][3]; // inverse rotation matrix double k; // absolute value of k-vector double halfdk2; // 0.5/k^2 int SymType; // symmetry type: 0: isotropic, // 1: cylindrical symmetry around x_1 // 2: cylindrical symmetry around x_2 double SymRot[3][3]; // symmetry rotation matrix double InvSymRot[3][3]; // inverse symmetry rotation matrix } WParams; /*===========================================================================*/ /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern int waxs_Init ( WParams * pParams, double k, double rot_1, double rot_2, double rot_3 ), waxs_SymInit ( WParams * pParams, int symtype, double symrot_1, double symrot_2, double symrot_3 ), waxs_not_init ( WParams *pParams ), waxs_get_transform( int proin, int proout ); PUBLIC extern void waxs_PrintParams ( FILE * out, WParams Params ), waxs_PrintCoord ( FILE * out, WaxsCoord sp ), waxs_PrintVector ( FILE * out, WaxsVector svec ), waxs_PrintDir ( FILE * out, WaxsDir Beam ); PUBLIC extern int // calculate projection range waxs_Range( WParams * pParamsIn, WParams * pParamsOut, int proin, int proout, long dim_1, long dim_2, float off_1, float pix_1, float cen_1, float off_2, float pix_2, float cen_2, float dis, float wvl, WaxsCoord *Wmin, WaxsCoord *Wmax, int * pstatus); PUBLIC extern WaxsCoord // waxs_Saxs2Saxs waxs_S2S ( WParams * pParamsIn, WParams * pParamsOut, WaxsCoord s ), // SAXS coordinate from SAXS coordinate // waxs_Waxs2Saxs waxs_Sp2S ( WParams * pParamsIn, WParams * pParamsOut, WaxsCoord sp ), // SAXS coordinate from WAXS projection // waxs_Saxs2Waxs waxs_S2Sp ( WParams * pParamsIn, WParams * pParamsOut, WaxsCoord s ), // WAXS projection from SAXS coordinate waxs_Uni2Iso ( WParams * pParamsIn, WParams * pParamsOut, WaxsCoord ssym ), // uniaxial WAXS to isotropic WAXS waxs_Iso2Uni ( WParams * pParamsIn, WParams * pParamsOut, WaxsCoord sp ); // isotropic WAXS to uniaxial WAXS PUBLIC extern WaxsCoord waxs_Transform( WParams * pParamsIn, WParams *pParamsOut, int transform, WaxsCoord W ); PUBLIC extern WaxsVector waxs_Saxs2Vector ( WParams * pParams, WaxsCoord s ); // Vector from SAXS coordinate PUBLIC extern WaxsDir waxs_ssym2kdir ( WParams * pParams, WaxsCoord ssym ), waxs_sp2kdir ( WParams * pParams, WaxsCoord sp ), waxs_s2kdir ( WParams * pParams, WaxsCoord s ); PUBLIC extern WaxsCoord waxs_kdir2ssym ( WParams * pParams, WaxsDir kdir ), waxs_kdir2sp ( WParams * pParams, WaxsDir kdir ), waxs_kdir2s ( WParams * pParams, WaxsDir kdir ); PUBLIC extern WaxsVector waxs_kdir2svec ( WParams * pParams, WaxsDir kdir ); #endif spd-1.3.0/edfpack/edfio.c0000644000175000017500000204340611635105403012060 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define EDFIO_VERSION "edfio : V2.38 Peter Boesecke 2011-09-01" /*+++------------------------------------------------------------------------ NAME edfio --- EDF data format specific file access routines SYNOPSIS # include edfio.h INCLUDE FILES edfio.h bslio.h raster.h numio.h TO LINK WITH bslio.c RESTRICTIONS The file size is limited by the long integer format. On machines with 4 byte long integers additional blocks after 2^31 bytes = 2Gbytes cannot be accessed. Therefore, if a file contains several data blocks the absolute size of a single data file should not exceed 2GBytes. DESCRIPTION EDF data format specific file access routines (read and write routines) The file format is described in ´SaxsKeywords.pdf´. The data files can contain several data blocks that can be accessed by data numbers and chain numbers. Chain numbers are positive integer numbers. A data block consists of a text block ("ASCII header") followed by a binary block ("binary data"). The block type is written at the top of the text block after the keyword "EDF_DataBlockID". The value "1.Image.Psd" marks data block number 1 of DataChain 1. Data chain 1 contains always primary (scientific) data, therefore the extension ".Psd". The value "1.Image.2" marks data block number 1 of DataChain 2 with additional image data. As a convention the associated variance data is stored with a negative chain number: data chain -m contains variance data of data chain +m (m>=1). The following convention should be followed: primary image data : chain number 1; error image data : chain number -1; Internally, a general chain is defined. It has chain number 0 and data number 0. Data blocks with different chain numbers but the same data numbers belong together (e.g. data array (chain number 1) and associated error array (chain number -1)). ChainNumber DataNumber chain key block key block id +1 n Image.Psd n n.Image.Psd -1 n Image.Error n n.Image.Error +m n Image.Psd.m n n.Image.Psd.m -m n Image.Error.m n n.Image.Error.m The input routines can also read bsl files. Bsl frame numbers (franum) and memory numbers (memnum) are in the following way internally converted to edf data numbers and chain numbers: memnum franum ChainNumber DataNumber chain key block key block id 1 n 1 n Image.Psd n n.Image.Psd m n m n Image.Psd.m n n.Image.Psd.m HISTORY 02-Jan-1996 Peter Boesecke 17-Mar-1998 Peter Boesecke V1.00 19-Mar-1998 Peter Boesecke locate_blocks 20-Mar-1998 Peter Boesecke search_general 21-Mar-1998 file->Buffer = (char *) NULL; in init_file 22-Mar-1998 28-Mar-1998 block->BinaryFilePos only used together with BinaryFileName 17-May-1998 PB V1.002 indexing error in reorder_raster and raster_normalization corrected 17-May-1998 PB V1.003 open of old files read-only with mode="read" 18-May-1998 PB V1.004 open_data_file and open_as_bsl_file: opening mode must be either Old or Read 01-Jun-1998 PB V1.01 set_bsl_input_byteorder 20-Jun-1998 PB V1.011 locate_blocks (corrected): if in V1x V1_IMAGE_KEY is missing, the header id number is used as image number. 22-Jul-1998 PB V1.012 read_header_string: debug info added (keyword, value) 30-Aug-1998 PB V1.013 numbers string: closing '\0' added (was missing) 18-Apr-1999 PB V1.02 all public routines start with edf_ or edfio_ 18-Apr-1999 PB V1.021 Return value of edf_read_data_2d_dimension is only FALSE if open_read_block terminated with the error value: CouldNotFindHeader. 30-Apr-1999 PB V1.022 edf_read_data_2d_raw 16-Jun-1999 PB V1.023 write_header_string debug info added 23-Jun-1999 PB V1.024 Restrictions split into PUBLIC and PRIVATE 24-Jun-1999 PB V1.03 Module history added, restrictions again only PRIVATE 26-Jun-1999 PB V1.04 History_Line renamed to Header_Line, now public edf_read_header, edf_write_header 17-Jul-1999 PB V1.05 edf_history_argv: strlen(argument)+3 (instead +2) 17-Jul-1999 PB V1.06 MaxLinLen increased from 127 to 255 in SaxsInput.h: InputLineLength increased to 256 23-Jul-1999 PB V1.07 DataValueOffset (EDF_DataFormatVersion = 2.20) "DataKey_" changed to "DataKey-" 26-Jul-1999 PB V1.08 Block boundary warning only given if binary lenght is different from zero, warning on BlockBoundaryKey missing removed, use internal default (512 bytes) without notice 08-Nov-1999 PB V1.09 raster_normalization added 08-Nov-1999 PB V1.10 in HSymb: shortlen and required added, new functions: edf_history_skip(), edf_history_take() 26-Nov-1999 PB V1.11 for cc on dec alpha: - some length values were not defined as constant and were changed to const. - all statements of the type *ps++=tolower(*ps); changed to { *ps=tolower(*ps); ps++; } 19-Dec-1999 PB V1.12 reorder_raster corrected, Data2FloatIEEE32 bad size check also for output data 07-Jan-2000 PB V1.13 for cc on dec alpha: all calls of the form "c=(char)ic=fgetc(channel);" changed to {ic=fgetc(channel); c=(char)ic;} otherwise ic == c and EOF cannot be checked; 16-Mar-2000 PB V1.14 Comments revised 17-Mar-2000 PB V1.15 ChainKey generally defined as "Image." 18-Mar-2000 PB V1.16 DEFAULT_CHAIN_KEY changed to CLASS_KEY DBClass and DBInstance 19-Mar-2000 PB V1.17 locate_block: using SequenceNumber, if IDs are missing 06-Apr-2000 PB V1.18 new breakval, val2str adapted, MAX_LINE_WIDTH 07-Apr-2000 PB V1.19 new function: edf_set_max_line_width 30-Apr-2000 PB V1.20 new in edfio.h: -> enum MType, -> edf_data2machine, -> edf_showdatatypes, bswap -> edf_bswap raster_normalization -> edf_rasternormalization dim_product -> edf_dim_product in DTypeStrings: Unsigned64 and Signed64 renamed to UnsignedLong and SignedLong (unchanged in DTypeStringsAliases), in DSize: Size of DoubleValue (DoubleIEEE64) corrected from 4 to 8 bytes 01-May-2000 PB V1.21 new in edfio.h: -> edf_showmachinetypes 22-May-2000 PB V1.22 in open_as_bsl_file If bsl-file is read-only, opening as read-write can cause a segmentation error (linux). Therefore, bsl file is now opened read-only ("read"). 28-Jul-2000 PB V1.23 all arrays declared with constants 30-Jul-2000 PB V1.24 new functions: raster_multiplication, raster_inversion 10-Nov-2000 PB V1.30 RasterOrientation -> DataRasterConfiguration, Dim_0 is not written any more, calculation of DataLen from all dimensions, write keywords of all dimensions edf_write_data_2d_raw -> edf_write_data_raw edf_write_data_2d_float -> edf_write_data_float 11-Nov-2000 PB V1.31 ExternalDimAlloc, ExternalDataAlloc disk_write_block and free_data_block_list release only internally allocated DataDim and Data arrays, externally allocated arrays are not released 12-Nov-2000 PB V1.32 edf_write_data_float -> edf_write_data(...,MFloat,...) V1.33 long * pDataArraySize -> size_t * pDataArraySize newdim() in edf_write_data_raw V1.34 edf_read_data_...(... , long Dim[], ...) --> edf_read_data_...(... , long **pDim, ...) edf_read_data_2d_... -> edf_read_data_... edf_read_data_float -> edf_read_data(...,MFloat,...) 13-Nov-2000 PB V1.35 read_data_array( block, ... ) 29-Dec-2000 PB V1.36 new in data block: DataByteOrder, DataRasterConfiguration, DataCompression renorm_data_array block->DataBufferLen: number of allocated data bytes 2000-01-01 PB V1.37 all i/o to Dim[Dim[0]+1] removed History_Symbol_List, module header_list print_bsl_filetable DBFlags.BadBlock, sync_data_block 2000-01-12 PB V1.38 for VisualC++ compatibility: typedefs for u_char, u_short, u_int and u_long removed and unsigned char, unsigned short, unsigned int and unsigned long used instead still undefined in VCC: getcwd 2000-01-15 PB V1.39 GETCWD 2001-01-24 PB V1.40 _getcwd for ms visual c 2001-02-05 PB V1.41 remove unused variables 2001-02-05 PB V1.42 not included for WIN32 2001-03-06 PB V1.43 on DEC alpha station: two fabs corrected to labs 2001-03-30 PB V1.44 opening binary file with empty extension (adding ".") if fopen fails the first time (just for some cdroms) 2001-04-11 PB V1.45 __MSVC__ -> WIN32 2001-05-15 PB V1.46 get_data_dim: i/o to Dim[Dim[0]+1] found and removed description corrected 2001-05-18 PB V1.47 edf_dump 2001-05-21 PB V1.48 edf_free_all: variables are only freed if != NULL 2001-06-02 PB V1.49 edf_dump new arguments 2001-06-07 PB V1.50 read_header_string: *pstatus = status_error for unsuccessful search in header write_header_string: *pstatus = status_error for unsuccessful write to header 2001-06-08 PB V1.51 edf_read_data_dimension, get_binary_array: block->DataDim array is not reallocated any more, if it exists it is only updated with copydim 2001-06-13 PB V1.52 edf_dump \n -> \r\n 2001-07-06 PB V1.53 new function edf_search_data_file, check_mode 2001-07-06 PB V1.54 InvalidStream 2001-07-08 PB V1.55 EdfMaxKeyLen etc., edf_byteorder 2001-07-10 PB V1.56 open_as_edf_file: ErrorCreatingGeneralBlock; return(-1); instead of ErrorCreatingGeneralBlock; return(0); 2001-07-11 PB V1.57 accept empty files as edf-files without general header 2001-08-05 PB V1.58 mode = "temp" (temporary files) see edf_open_data_file temporary files with binary data are not fully implemented, missing: edf_read_data_raw cannot be used, no internal memory allocation, no data type conversion. 2001-09-02 PB V1.59 Data2Float -> Convert2Float, edf_set_datatype edf_data2machine -> edf_machine2machine Convert2UnsignedShort 2001-09-03 PB V1.60 Convert2UnsignedShort: round MFloat and MDouble 2001-09-04 PB V1.61 edf_write_data: error removed for data_type_out == 0 2001-09-13 PB V1.62 call of edf_history routines with history_key, currently without function 2001-09-15 PB V1.63 new_header_history -> clear_header_history 2001-09-15 PB V1.64 edf_history V1.2 2001-09-16 PB V1.65 UCharMin etc. 2001-09-17 PB V1.66 edf_write_data_raw: remove non compulsary keywords read_header_string: debug output corrected 2001-10-27 PB V1.67 DataKey- starts now with DATA_FORMAT_PREFIX 2001-11-18 PB V1.68 edf_read_header: general block is now read first 2001-11-18 PB V1.69 HEFlags, KeyOrderNo 2001-11-25 PB V1.70 SEFlags, KeyOrderNo, KeyOrderNextSymbol module keyorder, module header_list 2001-11-25 PB V1.71 print_data_block_list corrected 2001-11-28 PB V1.72 keyorder_DefaultTable updated 2001-11-28 PB V1.73 edf_dump str2val added 2001-11-29 PB V1.74 keyorder_DefaultTable updated 2001-12-08 PB V1.75 edf_add_header_element, edf_delete_header_element 2002-01-08 PB V1.76 edf_search_header_element, CouldNotFindHeaderKey 2002-01-09 PB V1.77 edf_print_header for single header 2002-01-21 PB V1.78 read_header_list, write_header_list: value-string-conversion added 2002-02-12 PB V1.79 edf_datatype2machinetype, edf_machine_sizeof 2002-04-25 PB V1.80 edf_history_read_header, edf_history_write_header, edf_history_copy 2002-06-01 PB V1.81 write only non-empty history lines 2002-11-27 PB V1.82 keyorder_DefaultTable updated (info keys added) 2003-04-06 PB V1.83 keyorder_DefaultTable updated (info keys added) 2003-04-06 PB V1.84 get_binary_array: BinaryFileName printed as string 2003-08-13 PB edf_read_header_...: Explicitely specified, that Value is not changed when return value is 0 2003-11-29 PB V1.85 keyorder_DefaultTable changed: BSize*, Psic* 2004-02-19 PB V1.86 To avoid problems when variables are copied to itself: tmp created before a variable is deleted ( in replace_string, insert_symbol, insert_symbol_root, insert_header_element ), additional check in copy_history_block 2004-03-16 PB V1.87 includes numio.h, must be linked with numio.c edf_read_header_float: s2float replaced by num_str2double, edf_read_header_long, get_data_dim, get_data_value_offset, get_raster_configuration: s2long replaced by num_str2long 2004-03-24 PB V1.88 EdfNDigitsFloat: number of significant float digits edf_write_header_unit: new function edf_write_header_float: float2s replaced by num_double2str 2004-04-02 PB V1.89 num_str2double, num_str2long have new parameter tail 2004-04-05 PB V1.90 removing memory leaks in history_line_new: allocated memory of newhline is now released in case of an error, get_binary_array: allocated memory of data_dim is now released if it was copied to block or in case of an error 2004-04-05 PB V1.90a insert_symbol: allocated memory of newsymbol is now released in case of an error 2004-04-06 PB V1.91 Previously temporarily allocated memory released in case that newstr fails ( free(tmp...); return ): insert_symbol_root (3 changes), insert_data_block (1 change), insert_data_chain (1 change), insert_history_block (1 change), history_line_new (1 change) 2004-04-08 PB V1.92 To prevent memory leaks: history_free: free(hline->key) added remove_history_block: free(hblock->key) added PB V1.92a remove_history_block: if (hblock->key) added 2004-04-12 PB V1.93 write header size into header 2004-06-19 PB V1.94 edfio_debug: numio_debug added 2004-07-17 PB V1.95 edf_set_minimumheadersize, sync_data_block updated 2004-07-17 PB V1.96 default of minimum_headersize_out increased to 4096 2004-09-27 PB V1.97 keyorder_DefaultTable: RasterOrientation -> Raster*, Projection*, needquotes: quotes required for empty strings 2004-10-04 PB V1.98 keyorder_DefaultTable: Rotation_* -> DetectorRotation_* 2005-02-23 PB V1.99 Size of DataType UnsignedLong and SignedLong changed to 4 bytes to be in agreement with the Daly routines. UnsignedLong and SignedLong are now synonyms for UnsignedInteger and SignedInteger. 2005-02-23 PB V2.00 Start of implementation of continuation keys: Continuation character defined compare_keys: the base key of a continuation key is sorted according to sort_mode, different keys with the same base key are sorted according to their continuation depth number. Continuation keys are sorted immediately after their base key. It is not necessary to search for continuation keys. str2val: pointer to rest of the string returned continuation_key, continuation_depth created is_prefix was accessing 1 bytes after end of buffer with keybuf[MaxKeyLen+1]='\0', but keybuf and prebuf are defined as keybuf[MaxKeyLen+1] -> corrected to keybuf[MaxKeyLen]='\0'. The same applies to prebuf. 2005-02-24 PB V2.01 byteorder() function 2005-02-25 PB V2.02 continuation_key: a continuation key for depth > 0 is only created if the basekey does not contain a continuation marker. SElement: new element String new: insert_string, search_string, remove_string remove_symbol: argument Next added delete_symbol OK, insert_string OK, search_string OK, remove_string OK, search_general OK, read_header_list OK, write_header_list OK. All output keywords are written with insert_string get_symbol_list uses insert_symbol All data format specific keywords are still written and read with insert_symbol(_root) and search_symbol. str2val: also encapsulation when first or last character is a quote read_header_value renamed to read_header_string write_header_value renamed to write_header_string read_header_string: The returned constant character string must not be released any more. new: edf_write_header_string, edf_read_header_string 2005-03-03 PB V2.03 MaxConLen defined as MaxLinLen, insert_string: written continuation line length is limited to MaxConLen. MaxConLen should be smaller or equal to MaxValLen because longer values cannot be read. 2005-04-11 PB V2.04 default of minimum_headersize_out increased to 8192 2005-07-18 PB V2.05 for gcc 3.4.4.: all statements of the type c = (char) ic = (int) ' '; splitted into ic = (int) ' '; c = (char) ic; all statements of the form *px++ = y splitted into *px = y; px++; where possible, except in while of keyorder_wildcmp, flush_data_block: psymbol=psymbol++ -> psymbol++ 2005-08-04 PB V2.06 get_binary_array: data_read_len, do not read more bytes than can be read from the binary block. newstrn: all keys are truncated after MaxKeyLen characters all error messages written to stderr, only exits for SEVERE ERROR (=programming errors) 2005-08-05 PB V2.07 edf_free_header: debug info corrected 2005-10-13 PB V2.08 get_binary_array: unnecessary memset statement removed (for cc) 2005-10-19 PB V2.09 compare_keys: replaced by compare_keys of version V2.04, the modified version had errors in the if statement. It should also work with gcc 3.4.4, because it does not contain redundant statements of the kind a=a++. 2006-03-15 PB V2.10 val2str, str2val: statements without effect removed edf_dim_product: 0.0l changed to 0l lcc warning: inconsistent linkage of ByteOrder2String, edf_compression2string, byteorder could not be solved 2006-12-01 PB V2.11 str2val: missing incrementation (pb++) added. Before, a new line (\n) was converted to l instead to \l. 2007-02-01 PB V2.12 strtrm added continuation_depth: strncpy replaced with strtrm continuation_key: strtrm added for depth>1 update_string: incrementation of next corrected 2007-02-02 PB V2.13 update_string: 2nd while loop corrected for the case that the string buffer is too small for the values of all continuation keys (should be impossible as long as val2str does not increase the length of the input string). 2007-02-11 PB V2.14 Andor EDF files: Keywords cannot contain carriage returns or line feeds. Only the last portion containing '=' is used as keyword. Empty lines between quotes without separator '=' are ignored. Modifications: DTypeStringsAliases1: FloatValue => Float DCompressionStringsAliases1: None => NoSpecificValue edf_string2compression: DCompressionStringsAliases1 added get_key: Keywords that are not followed by an equal sign are skipped. get_key continues until a valid keyword is found (or EOF etc). newstring: allocates 1 byte for '\0' when stringlen is zero (originally nothing was allocated and the return value NULL). 2007-03-07 PB V2.15 edfio_version returns EVERSION if defined 2007-03-08 PB V2.16 prototypes updated for __LCC__ (to reduce warnings) 2007-03-14 PB V2.17 open_as_edf_file: update and increment sequence number of general block only if it will be physically written or if it was read (NoGeneralHeader not set), otherwise the first HeaderID number can be wrong. 2007-04-20 PB V2.18 code corrected to avoid compiler warnings with -Wall most %zu formats complemented with %lu, except in edf_show* (%z is not recognized, neither by sun, nor by cygwin on pc), Flag formats %u changed to %hu 2007-06-15 PB V2.19 locate_block: reads FIT2D specific edf format (KLORA) 2007-06-17 PB V2.20 edf_dump: format 10000, 10001 2007-09-07 PB V2.21 prototype for get_data_type 2007-11-23 PB V2.22 DATA_FORMAT_VERSION increased to 2.4 The output files are now written without starting newline. The starting newline has been removed from the variable header_begin. Originally, the start byte of an EDF file was a newline (0x0A) followed by an opening curly brace (0x7B). The use of the newline was not imposed. In recent versions of some software packages (SPEC, FIT2D) the newline is omitted and the files start directly with an opening curly brace. Because one of the software packages does not even want to read the original file format it has now been changed here. Hopefully, it will not do too much trouble to users. As before, all files with and without newline are read. 2007-12-05 PB V2.23 keyorder_DefaultTable: AxisType_ included Unsigned64, Signed64 public raster_order2raster Convert2Float: bug corrected (double incrementation in ushort and uint caused segmentation fault) 2008-04-23 PB V2.24 keyorder_DefaultTable: Msensi, Pslits, Sample* 2008-05-27 PB V2.25 edf_dump: print file name for format=10000, 10001 2010-07-07 PB V2.26 raster functions extracted to raster.c/raster.h xxx_order2raster -> xxx_order2number edf_raster2number -> edf_raster_order2number raster_normalization calls updated. 2010-07-08 PB V2.27 Convert2Double added 2010-07-09 PB V2.28 pErrorValue and pstatus can be NULL in edf_open_data_file, edf_close_data_file, edf_search_stream, edf_read_data_dimension, edf_search_minmax_number, edf_test_header, edf_write_data_raw, edf_write_data, edf_read_data_raw, edf_read_data, 2010-09-08 PB V2.29 exit -> exit(-1) 2010-09-09 PB V2.30 edf_delete_key added 2010-09-09 PB V2.31 range of input variable stream checked (to avoid memory fault error if outside range) 2010-12-18 PB V2.32 GzipCompression added: binary block output compression can be chosen with edf_set_datacompression( DCompression ). DBlock->Raw, RawBufferLen, RawLen disk_write_block: put_compressed_block added sync_data_block, flush_data_block updated, edf_set_datacompression added. get_binary_array: updated, data_read_len changed to bytes_to_read, bytes_read added 2011-01-05 PB V2.33 new public routines: edf_string2compression, edf_compression2string. some updates and cleanup in internal block routines: *pstatus parameter replaced by return value: disk_write_block get_data_header (disk_read_header removed), open_read_block, close_read_block, open_write_block, close_write_block updated: edf_write_data_raw, edf_write_data, edf_read_header, edf_write_header, locate_block, put_data_block, get_data_header, update_general, rewrite_symbol, update_symbol 2011-01-31 PB V2.34 history_line_add: strncat (non-ansic) replaced with strncpy 2011-05-25 PB V2.35 newdim -> newcopydim, newdim allocates only dimension array, get_data_dim: use newdim historically, data_dim is allocated with n+2 elements but only n+1 elements are used. 2011-06-01 PB V2.36 read_header_string: status used 2011-06-16 PB V2.37 edf_dump_format: line feed corrected 2011-09-01 PB V2.38 Convert2Long, Convert2Integer, Convert2Short --------------------------------------------------------------------------*/ /*************************************************************************** * Private part * ***************************************************************************/ /*************************************************************************** * Defines * ***************************************************************************/ #ifdef sun # include # define GETCWD(x,y) getwd (x) #else # ifdef WIN32 # include # define GETCWD(x,y) _getcwd(x, y) # else # define GETCWD(x,y) getcwd (x, y) # endif #endif /*************************************************************************** * Include files * ***************************************************************************/ #include #include #include #ifndef WIN32 # include #endif #include #ifdef sun /* sun specific stuff */ # include # include #else # include #endif # include "edfio.h" # include "bslio.h" # include "raster.h" # include "numio.h" # include "cmpr.h" /*************************************************************************** * Macros * ***************************************************************************/ #ifdef sun /* sun specific stuff */ # define ATOF(s) (float) atof (s) /* Sun/gcc doesn't work with strtod */ #else # define ATOF(s) (float) strtod (s, (char **) NULL) #endif # define STRLEN(s) (s == (char *) NULL ? 0 : strlen ( (char *) s)) # define STRCMP(s1,s2) strcmp ( (char *) s1, (char *) s2 ) # define STRCPY(s1,s2) strcpy ( (char *) s1, (char *) s2 ) # define ATOI(s) (int) strtol (s, (char **) NULL, 10) # define BLANK(c) (c == ' ' || c == '\t' ? True : False) # define NEWLINE(c) (c == '\n' || c == '\r' ? True : False) /* CEILMOD: Round N up to the next full multiple of DIV */ # define CEILMOD(N,DIV) (((N)%(DIV))?((DIV)+(N)-(N)%(DIV)):(N)) # define MAX(A,B) ((A)>(B))?(A):(B) # define MIN(A,B) ((A)<(B))?(A):(B) /*************************************************************************** * History Line Structure Definition * ***************************************************************************/ typedef struct History_Symbol_List { char * key; /* pointer to the history key string */ char * line;/*Pointer to the allocated character string with size_t bytes*/ size_t size; /* Allocated number of bytes, including terminating zero */ int required;/*if set, the next argument sets shortlen to strlen(line)*/ size_t shortlen; /* short length, excluding not required parameters */ struct History_Symbol_List *Previous,*Next;/*the previous and next symbols*/ } HSymb; typedef struct History_Block { char * key; /* pointer to the history block key string */ HSymb * history_line_root; /* previously created history lines */ HSymb * history_argv_root; /* actually created history line */ char * current_history_line_key; struct History_Block *Previous, *Next; /* the previous and next block */ } HBlock; /*************************************************************************** * Header List Structure Definition * ***************************************************************************/ typedef struct Header_Element_Flags { unsigned short Read; /* header element was already read */ } HEFlags; typedef struct Header_Element { char * Key; /* pointer to the header key string */ char * Value; /* Pointer to the allocated character string */ HEFlags Flags; struct Header_Element *Previous,*Next; /* the previous and next elements */ } HElement; typedef struct Header_List { char * Key; /* pointer to the header key string */ HElement * ElementRoot; /* pointer to the allocated character string */ short KeyOrderNo; /* currently used order key */ struct Header_List *Previous,*Next; /* the previous and next elements */ } HList; /*************************************************************************** * Internal Data Representation * ***************************************************************************/ /*------------------------------------------------------------------------ Internal Data Representation Data_Block : ´BlockKey´ is the unique name of this data block (usually a number). ´BlockKeyLen´ is the length of the BlockKey (without stop character '\0') ´TextPos´ is the displacement of the header section relative to the begin of the file. ´BinaryPos´ is the displacement of the binary section relative to the begin of the file. ´TextLen´ is the actual length of the header section, including padded white spaces. It must be a multiple of ´BlockBoundary´. ´BinaryLen´ is the length of the binary data section of the data block on disk. It must be a multiple of ´BlockBoundary´. ´Flags´ are reserved for future use. ´PadLen´ are the number of white-spaces that must be added to adjust the header section to a multiple of ´BlockBoundary´. ´SymbolList´ is the list of all keywords and values that are listed in the header. ´KeyOrderNo´ is a temporary variable ´DataLen´ is the number of meaningful bytes that should be written to the file out of the data buffer or that have been read from a file into the data buffer. It cannot be larger than ´BinaryLen´. ´Data´ is a typeless pointer to the data buffer. After writing, the data buffer is automatically discarded, before reading, a sufficiently large data buffer is allocated, if the NULL pointer is supplied. ---------------------------------------------------------------------------*/ typedef struct Data_Format_Version { unsigned short Major, /* major version number */ Minor; /* minor version number */ } DFVersion; typedef struct Data_File_Flags { unsigned short ExistingFile, /* The file exists and was not opened with ´new´ or ´temp´ */ ReadOnlyFile, /* This file is read-only */ TemporaryFile, /* The file was opened with ´temp´*/ NoGeneralHeader; /* The file has no general header */ } DFFlags; typedef struct Data_Block_Flags { unsigned short InternalHeader, /* Keep header, but do not write it to disk */ InternalData, /* Keep data internally, never write to disk */ DiskBlockUsed, /* Disk block is used */ DiskBlockFixed, /* Position and length of disk block is fixed */ HeaderExternal, /* The header contents must be read from disk */ HeaderChanged, /* The header contents must be written to disk */ DataExternal, /* The data must be read from disk */ DataChanged, /* The data needs to be written to disk */ ExternalDimAlloc, /* DataDim buffer is externally allocated */ ExternalDataAlloc, /* Data buffer is externally allocated */ BadBlock; /* Do not write this block */ } DBFlags; typedef struct Symbol_Element_Flags { unsigned short Read; /* header element was already read */ } SEFlags; typedef struct Symbol_Element { char *Key, /* the keyword itself */ *Value; /* it's value */ unsigned long KeyPos, /* position of keyword in file */ ValPos; /* position of value in file */ unsigned short KeyLen, /* length of keyword */ ValLen; /* length of value */ char *String; /* string of all continuation keys, if base key */ unsigned short StringLen; /* length of string buffer */ SEFlags Flags; /* various flags */ struct Symbol_Element *Previous, *Next; /* the previous and next symbols */ struct Data_Block *Block; /* the owning block */ } SElement; typedef struct Data_Block { char *BlockKey; /* the block key value of this data block */ unsigned short BlockKeyLen; /* the length of the block key */ unsigned long TextPos, /* start position of this header in the file */ BinaryPos, /* start position of binary section in the file */ TextLen, /* actual length of the ASCII header in bytes */ BinaryLen, /* actual length of the binary section */ PadLen; /* the number of white-spaces for padding */ char *BinaryFileName; /* name of the file with the binary data, NULL means this file */ unsigned long BinaryFilePos, /* position of binary data in BinaryFileName */ BinaryFileLen; /* actual length of the binary file section */ /* specification of the actually read and converted data in memory */ void *Data; /* pointer to the typeless data buffer */ size_t DataBufferLen; /* allocated length of data buffer in bytes */ size_t DataLen; /* meaningful length of data buffer in bytes */ long DataByteOrder; /* actual byte order of the data */ long DataRasterConfiguration; /* data raster configuration type */ long DataCompression; /* the actual data compression type */ long DataType; /* the actual data type */ long DataValueOffset; /* offset must be added to each data item */ long *DataDim; /* the actual dimensions */ void *Raw; /* pointer to the typeless raw buffer */ size_t RawBufferLen; /* allocated length of raw buffer in bytes */ size_t RawLen; /* meaningful length of raw buffer in bytes */ DBFlags Flags; /* various flags */ unsigned long SequenceNumber; /* the sequential number of the block */ SElement *SymbolList; /* the symbol list of this data block */ short KeyOrderNo; /* currently used order key */ SElement *KeyOrderNextSymbol; /* points to next symbol to ordered */ struct Data_Block *Previous, *Next; /* previous and next data block */ struct Data_Chain *Chain; /* the owning chain */ } DBlock; typedef struct Data_Chain { char *ChainKey; /* the key string of this chain */ unsigned short ChainKeyLen; /* the length of the chain key */ unsigned short Flags; /* various flags */ DBlock *BlockList; /* the block list of this chain */ struct Data_Chain *Previous, *Next; /* previous and next data block */ struct Data_File *File; /* the owning file */ } DChain; typedef struct Data_File { /* Definition of a file table */ int Used; /* 1 if in use, 0 if not */ char *Name; /* file name */ FILE *Channel; /* i/o channel */ char *Buffer; /* pointer to IO Buffer */ DFVersion Version; /* data format version */ unsigned long BlockBoundary; /* BlockBoundary of this file */ DFFlags Flags; /* various flags */ DBlock *GeneralBlock; /* pointer to the general block of this file */ DBlock *ActiveBlock; /* pointer to the current active block */ unsigned long NextSequenceNumber; /* sequence number of next written data block */ DBlock *LastBlockInFile; /* pointer to the last block in the file */ DChain *ChainList; /* the list of data chains in this file */ } DFile; /*************************************************************************** * Restrictions * ***************************************************************************/ #define MaxFiles EdfMaxFiles /* maximum number of files streams */ #define MaxKeyLen EdfMaxKeyLen /* maximum length of keywords */ #define MaxValLen EdfMaxValLen /* maximum length of values */ #define MaxLinLen EdfMaxLinLen /* maximum line length */ #define MaxConLen MaxLinLen /* maximum continuation line length,*/ /* must be smaller than MaxValLen */ #define MaxDataChains EdfMaxDataChains /* max. number of user data chains */ #define BufferSize EdfBufferSize /* size of input buffer */ #define MaxDimensions EdfMaxDimensions /* limiting number of dimensions */ #define StartHeader '{' /* used to mark the start of a header */ #define EndHeader '}' /* used to mark the end of a header */ #define Separator '=' /* used to separate keyword from value */ #define Terminator ';' /* marker for end of statement */ #define FirstHeader 1 /* Header Numbers start at this value, Header Numbers are incremented by one each time a data block is written. */ #define Comment '#' /* comment if first character in line */ #define Continuation '~' /* separator between key and continuation number*/ /*************************************************************************** * General strings * ***************************************************************************/ # define NONE "None" # define UNDETERMINED "Undetermined" # define INVALID "Invalid" /*************************************************************************** * Version and general setup values * ***************************************************************************/ # define DATA_FORMAT_NAME "EDF" # define DATA_FORMAT_VERSION "2.40" # define DATA_BLOCKS_DEFAULT UNDETERMINED /* undetermined value */ # define BLOCK_BOUNDARY 512 /* bytes */ # define PAD_WIDTH 78 /* width of padded text +2-0 chars */ # define MAX_LINE_WIDTH 0ul /* maximum width of text lines */ /*************************************************************************** * Header Keywords * * All keywords that are relevant for the physical data structure start * * with DATA_FORMAT_PREFIX * ***************************************************************************/ # define DATA_FORMAT_PREFIX DATA_FORMAT_NAME"_" # define DATA_FORMAT_VERSION_KEY DATA_FORMAT_PREFIX"DataFormatVersion" # define DATA_BLOCKS_KEY DATA_FORMAT_PREFIX"DataBlocks" # define BLOCK_BOUNDARY_KEY DATA_FORMAT_PREFIX"BlockBoundary" # define BLOCK_ID_KEY DATA_FORMAT_PREFIX"DataBlockID" # define BINARY_SIZE_KEY DATA_FORMAT_PREFIX"BinarySize" # define HEADER_SIZE_KEY DATA_FORMAT_PREFIX"HeaderSize" # define BINARY_FILE_NAME_KEY DATA_FORMAT_PREFIX"BinaryFileName" # define BINARY_FILE_POSITION_KEY DATA_FORMAT_PREFIX"BinaryFilePosition" # define BINARY_FILE_SIZE_KEY DATA_FORMAT_PREFIX"BinaryFileSize" /* Version 1.xx keywords relevant for the physical data structure */ # define V1_HEADER_ID_KEY "HeaderID" # define V1_SIZE_KEY "Size" # define V1_IMAGE_KEY "Image" # define V1_SUPPRESS ".Psd" /* Version 2.xx keywords relevant for the data ordering */ # define GENERAL_CHAIN_KEY "General" # define GENERAL_BLOCK_KEY "All" //+++++++++++++ # define DEFAULT_BLOCK_KEY "Default" # define CHAIN_KEY_DEFINITION DATA_FORMAT_PREFIX"DataKey-" //+++++++++++++ # define CLASS_KEY "Image" /* keywords describing the binary data */ # define DIMENSION_KEY_PREFIX "Dim_" /* key prefix for array dimension */ # define BYTE_ORDER_KEY "ByteOrder" /* byte order of a single item */ # define LOW_BYTE_FIRST "LowByteFirst" /* byte order value */ # define HIGH_BYTE_FIRST "HighByteFirst" /* byte order value */ # define FIXED_BYTE_ORDER "FixedByteOrder" /* byte order is fixed */ # define RASTER_CONFIGURATION_KEY "DataRasterConfiguration" # define COMPRESSION_KEY "Compression" # define DATA_TYPE_KEY "DataType" /* data type of a single item */ # define DATA_VALUE_OFFSET_KEY "DataValueOffset" # define FLOAT_IEEE32 "FloatValue" /* data type value */ /* optional keywords */ # define HISTORY_KEY_PREFIX "History-" /* Version 1.xx keywords */ # define V1_HEADER_ID_KEY "HeaderID" # define V1_SIZE_KEY "Size" # define V1_IMAGE_KEY "Image" /*************************************************************************** * The following translation tables correspond to public enumerated * * constants. The enums start with 1. 0 to specify an invalid value. * * The string tables start with INVALID and end with (char *) NULL. * ***************************************************************************/ /*************************************************************************** * Data Type Translation Tables * * The indices of the tables correspond to ´enum DType´. * ***************************************************************************/ PRIVATE const char * DTypeStringsAliases[18] = { INVALID, "Unsigned8", "Signed8", "Unsigned16", "Signed16", "Unsigned32", "Signed32", "Unsigned64", "Signed64", "FloatIEEE32", "DoubleIEEE64", "UnAssigned", "UnAssigned", "FloatVAX32", "DoubleVAX64", "FloatConvex32", "DoubleConvex64", (const char *) NULL }; PRIVATE const char * DTypeStringsAliases1[18] = { INVALID, "UnsignedByte", "SignedByte", "UnsignedShort", "SignedShort", "UnsignedLong", "SignedLong", "Unsigned64", "Signed64", "Float", "DoubleValue", "UnAssigned", "UnAssigned", "FloatVAX32", "DoubleVAX64", "FloatConvex32", "DoubleConvex64", (const char *) NULL }; PRIVATE const char * DTypeStrings[18] = { INVALID, "UnsignedByte", "SignedByte", "UnsignedShort", "SignedShort", "UnsignedInteger", "SignedInteger", "Unsigned64", "Signed64", "FloatValue", "DoubleValue", "UnAssigned", "UnAssigned", "FloatVAX32", "DoubleVAX64", "FloatConvex32", "DoubleConvex64", (const char *) NULL }; PRIVATE const size_t DSize[17] = { 0lu, 1lu, 1lu, 2lu, 2lu, 4lu, 4lu, 8lu, 8lu, 4lu, 8lu, 0lu, 0lu, 4lu, 8lu, 4lu, 8lu }; /*************************************************************************** * Byte Order Translation Tables * * The constants correspond to ´enum BOrder´. * ***************************************************************************/ PRIVATE const char * BOrderStrings[5] = { INVALID, LOW_BYTE_FIRST, HIGH_BYTE_FIRST, FIXED_BYTE_ORDER, (const char *) NULL }; /*************************************************************************** * Data Compression Translation Tables * * The constants correspond to ´enum DCompression´. * ***************************************************************************/ PRIVATE const char * DCompressionStrings[] = { INVALID, NONE, "GzipCompression", "ZCompression", (const char *) NULL }; PRIVATE const char * DCompressionStringsAliases[] = { INVALID, "UnCompressed" , "GzipCompression", "ZCompression", (const char *) NULL }; PRIVATE const char * DCompressionStringsAliases1[] = { INVALID, "NoSpecificValue" , "Gzip", "Z", (const char *) NULL }; /*************************************************************************** * Data block classes and instances * * The constants correspond to ´enum DBClass´ and ´enum DBInstance´. * ***************************************************************************/ PRIVATE const char * DBClassStrings[4] = { INVALID, "General", "Image", (const char *) NULL }; PRIVATE const char * DBInstanceStrings[4] = { INVALID, "Psd" , "Error", (const char *) NULL }; /*************************************************************************** * Private constants and variables * ***************************************************************************/ PRIVATE char *DataFormatVersion = DATA_FORMAT_VERSION; PRIVATE char *New = "new", *Old = "old", *Any = "any", *Read = "read"; PRIVATE char *Temp = "temp"; PRIVATE char white_spaces[7] = { ' ', '\t', '\r', '\n', '\f', '\v', '\0' }; PRIVATE char quote_chars[2] = { '\"', '\0' }; PRIVATE char numbers[11] = { '0','1','2','3','4','5','6','7','8','9', '\0' }; PRIVATE char tobequoted[8] = { '(', ')', '[', ']', '{', '}', '*' , '\0' }; // PRIVATE char header_begin[5] = { '\n', StartHeader, '\r', '\n', '\0' }; PRIVATE char header_begin[4] = { StartHeader, '\r', '\n', '\0' }; PRIVATE char header_end[5] = { '\r', '\n', EndHeader, '\n', '\0' }; PRIVATE char symbol_separator[4] = { ' ', Separator, ' ', '\0' }; PRIVATE char symbol_terminator[5] = { ' ', Terminator, '\r', '\n', '\0' }; PRIVATE char line_feed[3] = { '\n', '\0', '\0' }; /* DOS { '\r', '\n', '\0' }*/ PRIVATE int InitTable = 0; PRIVATE DFile FileTable[MaxFiles]; PRIVATE char IDBuffer[3*MaxKeyLen+1]; PRIVATE int EDFIO_debug = 0; PRIVATE int write_general_block = 0; /* default without general header */ PRIVATE int write_headersize = 1; /* default: with header size */ PRIVATE unsigned long minimum_headersize_out = 8192l; /* minimum header size */ PRIVATE int data_type_out = InValidDType;/* no specific data type */ PRIVATE int data_compression_out= InValidDCompression; /* unspcfc cmpr */ PRIVATE long data_value_offset_out = 0l; /* default is no offset */ PRIVATE int bsl_input_byteorder = InValidBOrder; /* default: not spec. */ PRIVATE unsigned long max_line_width = MAX_LINE_WIDTH; /* default line width */ enum DFType { InValidDFType, EdfType, BslType }; /* data format types */ enum SMode { CaseSensitiveSort, UpperCaseSort, NumberSort }; /*************************************************************************** * Prototypes * ***************************************************************************/ PRIVATE const char * ByteOrder2String( int byte_order ); PRIVATE SElement ** keyorder_ordersymbols( DBlock * block ); PRIVATE int byteorder ( void ); PRIVATE int history_line_new ( HSymb ** proot, const char * history_line_key, size_t history_size, HSymb ** phline ); PRIVATE int keyorder_compare( const char *key, const char *criterion ); PRIVATE long *get_data_dim ( DBlock * block ); PRIVATE int get_data_type ( DBlock * block ); /*************************************************************************** * Routines that return internal parameters * ***************************************************************************/ unsigned long edf_maxfiles( void ) { return ( MaxFiles ); } unsigned long edf_maxkeylen ( void ) { return ( MaxKeyLen ); } unsigned long edf_maxvallen ( void ) { return ( MaxValLen ); } unsigned long edf_maxlinlen ( void ) { return ( MaxLinLen ); } unsigned long edf_maxdatachains ( void ) { return ( MaxDataChains ); } unsigned long edf_buffersize ( void ) { return ( BufferSize ); } unsigned long edf_maxdimensions ( void ) { return ( MaxDimensions ); } int edf_byteorder ( void ) { return ( byteorder ( ) ); } /*************************************************************************** * Routines * ***************************************************************************/ /*+++------------------------------------------------------------------------ NAME edfio_version SYNOPSIS char *edfio_version ( void ) DESCRIPTION Returns a pointer to the version string of the module edfio RETURN VALUE Pointer to the version string -------------------------------------------------------------------------+*/ char *edfio_version ( void ) /*---*/ { # ifdef EVERSION # define _EDFIO_VERSION EDFIO_VERSION" ("EVERSION")" # else # define _EDFIO_VERSION EDFIO_VERSION # endif return ( _EDFIO_VERSION ); } /* edfio_version */ /*+++------------------------------------------------------------------------ NAME byteorder SYNOPSIS int byteorder ( void ) DESCRIPTION Checks the byte order of the machine byteorder : HighByteFirst, big endian byte order byteorder : LowByteFirst, little endian byte order RETURN VALUE byteorder : HighByteFirst | LowByteFirst -------------------------------------------------------------------------+*/ PRIVATE int byteorder ( void ) { short int one = 1; int value; switch ((int) *(char *) &one) { case 1: value = LowByteFirst; break; case 0: value = HighByteFirst; break; default: value = InValidBOrder; } return( value ); } // byteorder /*+++------------------------------------------------------------------------ NAME edf_general_block --- write/don´t write file with general header SYNOPSIS int edf_general_block ( int writetodisk ); DESCRIPTION writetodisk : 1, write general header writetodisk : 0, do not write general header (default) RETURN VALUE SUCCESS: 0 ---------------------------------------------------------------------------*/ int edf_general_block ( int writetodisk ) /*---*/ { write_general_block = writetodisk; return(0); } /* edf_general_block */ /*+++------------------------------------------------------------------------ NAME edf_headersize --- write/don´t write header size into header SYNOPSIS int edf_headersize ( int writetodisk ); DESCRIPTION writetodisk : 1, write header size into header (default) writetodisk : 0, do not write header size RETURN VALUE SUCCESS: 0 ---------------------------------------------------------------------------*/ int edf_headersize ( int writetodisk ) /*---*/ { write_headersize = writetodisk; return(0); } /* edf_headersize */ /*+++------------------------------------------------------------------------ NAME edf_set_minimumheadersize --- sets minimum header size SYNOPSIS int edf_set_minimumheadersize( unsigned long minimumheadersize_out ) DESCRIPTION The actual output headersize is rounded to the next multiple of BLOCK_BOUNDARY that is larger or equal to the maximum of minimumheadersize_out and the minimum required size to write all header values. RETURN VALUE SUCCESS: 0 ---------------------------------------------------------------------------*/ int edf_set_minimumheadersize ( unsigned long minimumheadersize_out ) { minimum_headersize_out = minimumheadersize_out; return(0); } /* edf_set_minimumheadersize */ /*+++------------------------------------------------------------------------ NAME edf_set_datatype --- set data type of all output files SYNOPSIS int edf_set_datatype ( int datatype_out ); DESCRIPTION edf_set_datatype sets the output data type for all output data written with edf_write_data. If necessary a data type conversion will be done. If datatype_out is InValidDType (default) the machine data are written without conversion. This change is immediately active globally. It can be done before each call to edf_write_data. edf_set_datatype modifies only the action of edf_write_data. It has no effect on any other function. edf_set_datatype(InValidDType) returns to the default. RETURN VALUE SUCCESS: 0 ---------------------------------------------------------------------------*/ int edf_set_datatype ( int datatype_out ) /*---*/ { data_type_out = datatype_out; return(0); } /* edf_set_datatype */ /*+++------------------------------------------------------------------------ NAME edf_set_datacompression --- set data compression of all output files SYNOPSIS int edf_set_datacompression ( int datacompression_out ); DESCRIPTION edf_set_datacompression sets the output data compression for all data written with edf_write_data and edf_write_data_raw. If datacompression_out is InValidDCompression (default) or UnCompressed the data are written without compression. This change is immediately active globally. It can be done before each call to edf_write_data or edf_write_data_raw. edf_set_datatype influences only edf_write_data and edf_write_data_raw. It has no effect on any other function. edf_set_datacompression(InValidDCompression) returns to the default. RETURN VALUE SUCCESS: 0 ---------------------------------------------------------------------------*/ int edf_set_datacompression ( int datacompression_out ) /*---*/ { data_compression_out = datacompression_out; return(0); } /* edf_set_datacompression */ /*+++------------------------------------------------------------------------ NAME edf_set_datavalueoffset --- set data value offset of all output files SYNOPSIS int edf_set_datavalueoffset ( long int datavalueoffset_out ); DESCRIPTION RETURN VALUE SUCCESS: 0 ---------------------------------------------------------------------------*/ int edf_set_datavalueoffset ( long int datavalueoffset_out ) /*---*/ { data_value_offset_out = datavalueoffset_out; return(0); } /* edf_set_datavalueoffset */ /*+++------------------------------------------------------------------------ NAME edf_set_bsl_input_byteorder --- set the byteorder for all bsl input files SYNOPSIS int edf_set_bsl_input_byteorder ( int byteorder ) DESCRIPTION Changes the byte order of all bsl input files to byteorder byteorder : HighByteFirst, big endian byte order byteorder : LowByteFirst, little endian byte order (default byte order: INTERNAL_BYTEORDER) RETURN VALUE 0: success --------------------------------------------------------------------------+*/ int edf_set_bsl_input_byteorder ( int byteorder ) /*---*/ { bsl_input_byteorder = byteorder; return(0); } /* edf_set_bsl_input_byteorder */ /*+++------------------------------------------------------------------------ NAME edf_set_max_line_width --- set maximum line width SYNOPSIS int edf_set_max_line_width ( unsigned long width ); DESCRIPTION width = 0 : no limitation width > 0 : length of header line limited to width (text lines only) RETURN VALUE SUCCESS: 0 HISTORY 2000-04-07 : Peter Boesecke ---------------------------------------------------------------------------*/ int edf_set_max_line_width ( unsigned long width ) /*---*/ { max_line_width = width; return(0); } /* edf_set_max_line_width */ /*--------------------------------------------------------------------------- NAME getpath_edf --- extract path from filename SYNOPSIS char *getpath_edf ( char *buffer, size_t buflen, const char * filename ); DESCRIPTION Extract path from filename and copies it into buffer. If the buffer is too short or another error has occurred NULL is returned. If filename has no path the current working directory is determined with getcwd and returned. HISTORY 23-Mar-1998 Peter Boesecke ---------------------------------------------------------------------------*/ char * getpath_edf ( char * buffer, size_t buflen, const char * filename ) { size_t str_len; char *ps; str_len = strlen(filename); if (str_len>=buflen) return( (char *) NULL ); if ((ps = strrchr( filename, (int) '/' ))) { memcpy( buffer, filename, (ps-filename) ); buffer[(ps-filename)]='\0'; } else GETCWD( buffer, buflen ); str_len = strlen(buffer); if (str_lenN] are 1. ´N´ must be at least equal to dim[0], RETURN VALUE Returns the pointer to buffer or (long *) NULL in case of an error. ---------------------------------------------------------------------------*/ long * copydim( long buffer[], long N, const long dim[] ) { long idim, idim_max; if ( (!dim) || (!buffer) ) return ( (long *) NULL ); if (dim[0]pend) break; *pb++=*ps++; } *pb='\0'; return( buffer ); } /* strtrm */ /*--------------------------------------------------------------------------- NAME replace_string -- replaces *pstring with string. SYNOPSIS int replace_string( char ** pstring, const char * string ); DESCRIPTION The memory to which pstring points is released. pstring is replaced by a pointer to a new allocated memory with strlen(string)+1 bytes. ´string´ is copied into this memory. CHANGED The memory at *pstring is released, new memory is allocated and filled with ´string´, pstring is replaced by a pointer to this memory. RETURN VALUE 0: OK -1: error, probably memory could not be allocated. ---------------------------------------------------------------------------*/ int replace_string( char ** pstring, const char * string ) { const char * nix = { '\0' }; char * tmp; if (!(pstring)) return(-1); /* cannot be changed */ if (!(string)) string = nix; tmp = newstr( string ); if (!tmp ) return(-1); if (*pstring) free(*pstring); *pstring = tmp; return(0); } /* replace_string */ /*--------------------------------------------------------------------------- NAME breakval - break a value string SYNOPSIS char * breakval( char buffer[], unsigned long buflen, const char * string, unsigned long pos1, unsigned long pos2 ) DESCRIPTION Breaks a value string into several lines. A symbol break ("'\r''\n''\'") is inserted after the last space in a line before pos1. If no space appears the string is broken at pos1. After the first inserted break the position is reset to 1 and the following lines are broken at pos2. The input string must be a result of str2val. '\r' and '\n' characters are ignored. This transformation should only be applied once. If pos1 or pos2 are less or equal to 1 the line is not broken. Appends a RETURN VALUES pointer to the value HISTORY 2000-04-06 Peter Boesecke ---------------------------------------------------------------------------*/ char * breakval( char buffer[], unsigned long buflen, const char * string, unsigned long pos1, unsigned long pos2 ) { unsigned long i, is; unsigned long pos, poss; unsigned long breakpos = pos1; char *pb = buffer, *pbs; const char *ps = string, *pss; char c; /* initialize buffer */ buffer[0] = '\0'; if (!string) return( buffer ); if (pos1<=1) pos1 = 0U; // minimum length 2 characters if (pos2<=1) pos2 = 0U; // minimum length 2 characters i = 0U; pbs = pb; pss = ps; while ( (i line_feed '\''r' => '\r' '\''n' => '\n' '\''s' => ' ' '\''t' => '\t' '\''v' => '\v' '\''f' => '\f' '\''(' => '{' '\'')' => '}' '\'':' => ';' '\''\r' => skipped '\''\n' => skipped '\' => '\r' and '\n' are skipped A single '\' at the end of the string is skipped. RETURN VALUES pointer to string HISTORY 25-Jan-1998 Peter Boesecke 06-Apr-2000 PB '\''\r' => skipped and '\''\n' => skipped ---------------------------------------------------------------------------*/ char *val2str( char buffer[], unsigned long buflen, const char * value ) { unsigned long i; unsigned long last; /* points after the last non-white character */ char *pb = buffer; const char *pv = value; /* initialize buffer */ *pb = '\0'; /* return empty string if value is NULL */ if (!value) return( buffer ); /* skip everything before the first non-white character */ while ( is_white(*pv) && (*pv) ) { pv++; } /* Remove leading double quote */ if ( (*pv) == '"' ) pv++; /* Read value until end of value string or until buffer full */ last = i = 0U; while ( (i0) && ( buffer[i-1] == '"' ) ) { pb--; i--; } /* String end marker */ *pb = '\0'; pb++; i++; return(buffer); } /* val2str */ /*--------------------------------------------------------------------------- NAME str2val - transformation of a string to a value string SYNOPSIS char *str2val( char buffer[], unsigned long buflen, const char * string, const char ** pnext ); DESCRIPTION Transformation of a string to a value string which can be used in a key/value statement. The transformed string is written to buffer, which has the size buflen. The input string is converted until the buffer is filled. A pointer to the unconverted part of the input string is returned in *pnext. The syntax of the resulting string is in all cases correct and it can always be used in a key/value statement. The returned pointer does not necessarily point to the beginning of buffer. To write the rest of the string to a subsequent value pnext can be used as input string in a subsequent call of str2val. The following transformations are done: - Encapsulation of the buffer value between double quotes if the first or the last character of the buffer is a white space. - Transformation to escape sequences: '\r''\n' => '\''l' '\n' => '\''l' '{' => '\''(' '}' => '\'')' ';' => '\'':' '\' => '\''\' To reduce the length of a line '\r''\n' is added after a linefeed escape symbol '\''l'. ARGUMENTS char buffer[] calculation buffer, needs at least 3 elements unsigned long buflen length of buffer const char * string input string const char **pnext pointer to the uncoverted rest of string, unused if NULL RETURN VALUES pointer to output value (points to a position inside buffer, not necessarily to its start) HISTORY 1998-01-25 Peter Boesecke 2005-02-20 PB pnext added ---------------------------------------------------------------------------*/ char *str2val( char buffer[], unsigned long buflen, const char * string, const char ** pnext ) { unsigned long i; char *pb = buffer; char *value; const char *ps = string; /* Read string until end of string or until buffer full */ i = 0U; *pb = '"'; pb++; i++; // first character is reserved for double quote *pb = '\0'; // second character is initialized with terminating zero if (!string) return(pb); // return empty string if input pointer is NULL while ( (i := ['~'] := 1|2|...|n|n+1... (positive decimal number) (char *) NULL strings are handled like empty strings. The value 0 is returned. If the number after a continuation marker is invalid -1 is returned. RETURN VALUE continuation number ---------------------------------------------------------------------------*/ long continuation_depth ( const char *key ) { char keybuf[MaxKeyLen+1]; const char *ps; long tmp, number=0l; int numc=0; char rest; /* copy strings into buffers */ if (key ==(char*) NULL) keybuf[0]='\0'; else strtrm(keybuf,MaxKeyLen+1,key); /* search for first occurence of continuation marker */ ps=strchr(keybuf, (int) Continuation ); if (ps) { numc=sscanf(++ps,"%ld%c",&tmp,&rest); if ((numc==1)&&(tmp>0)) number=tmp; else number=-1l; } return( number ); } /* continuation_depth */ /*--------------------------------------------------------------------------- NAME compare_keys --- compares two strings (<0, 0, >0) SYNOPSIS enum SMode { CaseSensitiveSort, UpperCaseSort, NumberSort }; SMode sortmode; int compare_keys( const char *key1, const char *key2, int sortmode ); DESCRIPTION The comparison is done for printable characters only, except spaces. Other characters are suppressed. The comparison is done for a maximum of MaxKeyLen characters (including all characters, printable and non-printable). In sort mode NumberSort all characters are converted to uppercase, a leading '+' or '-' sign and multiple leading '0's are removed. The comparison is only done for the key base until the first occurrence of a continuation marker. The part after the continuation marker is converted to a continuation number. If the comparison of two key bases returns 0 the key order is determined from the continuation numbers. NULL pointers (key1 and key2) are handled like empty strings. GCC AND G++ For compatibility between g++ and gcc the variable declaration "SMode sortmode" has been changed back to "int sortmode". The g++ declaration was: int compare_keys( const char *key1, const char *key2, SMode sortmode ); It could not be compiled with gcc RETURN VALUES The routine returnes as result: input cont. number output key1 < key2 any -1 num1 < num2 -1 key1 = key2 num1 = num2 0 num1 > num2 +1 key1 > key2 any +1 In the case that a key (marked with TRUE) starts with DATA_FORMAT_PREFIX the following values are returned: TRUE = key starts with DATA_FORMAT_PREFIX FALSE = key does not start with DATA_FORMAT_PREFIX key1 key2 result FALSE FALSE normal comparison FALSE TRUE +1 TRUE TRUE normal comparison TRUE FALSE -1 HISTORY Peter Boesecke ---------------------------------------------------------------------------*/ int compare_keys( const char * key1, const char * key2, int sortmode ) { register int i,j; char buf1[MaxKeyLen+1], buf2[MaxKeyLen+1]; char *pc1, *pc1o, *pc2, *pc2o; const char *prefix = DATA_FORMAT_PREFIX; long num1, num2; char stop1='\0', stop2='\0'; int l1,l2; int vz1=1, vz2=1; int p1, p2; int comparison; /* check prefix */ p1 = is_prefix ( key1, prefix, False ); p2 = is_prefix ( key2, prefix, False ); if ((!p1) && p2) return(+1); /* key2 has prefix */ if (p1 && (!p2)) return(-1); /* key1 has prefix */ num1 = continuation_depth ( key1 ); if (num1>0) stop1=Continuation; // don't stop if depth invalid num2 = continuation_depth ( key2 ); if (num2>0) stop2=Continuation; // don't stop if depth invalid /* compare key bases before first occurence of a stop marker */ pc1 = &buf1[0]; pc2 = &buf2[0]; switch ( sortmode ) { case CaseSensitiveSort : if (key1) for (i=0;(i=0;i--,j--) buf1[i]=buf1[j]; for (;i>=0;i--) buf1[i]='0'; } else { for (i=l1,j=l2;j>=0;i--,j--) buf2[i]=buf2[j]; for (i=i;i>=0;i--) buf2[i]='0'; } } break; default : printf("ERROR: Unknown sortmode\n"); exit(-1); break; } comparison = vz1*STRCMP(buf1,buf2); /* continuation keys are placed after their base keys in the order of the continuation depth, keys with the same base keys but invalid depth are placed after all continuation keys */ if (comparison==0) { if ((num1>=0)&&(num2>=0)) { // no change if both are equal if (num1num2) comparison = 1; } else { // no change if both are negative if ((num1<0)&&(num2>=0)) comparison = 1; else if ((num1>=0)&&(num2<0)) comparison = -1; } } return( comparison ); } /* compare_keys */ /*-------------------------------------------------------------------------- NAME str2version --- convert string to version SYNOPSIS DFVersion str2version( const char * string ) DESCRIPTION The version string must have the following format: Vmajor.minor. It must not contain white spaces. V is a non-numeric character string. It is ignored and can be omitted. major and minor are numeric character strings of type "unsigned short". major and minor are separated by '.'. If '.' or minor is missing the value of minor is set to 0. In case of an error the program is terminated. RETURN VALUE DFVersion version, the converted version ---------------------------------------------------------------------------*/ DFVersion str2version( const char * string ) { const char * ConversionError = "SEVERE ERROR converting version string "; const char * vs = string; DFVersion version; unsigned long int major = 0u, minor = 0u; int npar; while ( (*vs) && (!(is_number(*vs))) ) vs++; npar = sscanf(vs, "%lu.%lu",&major, &minor); if ( npar < 1 ) { fprintf(stderr,"%s\"%s\"\n", ConversionError, string); exit(-1); } else if ( npar < 2 ) minor = 0u; version.Major = (unsigned short int) major; version.Minor = (unsigned short int) minor; return(version); } /* str2version */ /*-------------------------------------------------------------------------- NAME version2str --- write version to string SYNOPSIS char * version2str( char buffer[], unsigned long buflen, DFVersion version ); DESCRIPTION The created version string has the following format: ´version.Major´.´version.Minor´ . In case of an error -1 is returned. RETURN VALUE pointer to string ---------------------------------------------------------------------------*/ char * version2str( char buffer[], unsigned long buflen, DFVersion version ) { const unsigned long outlen = MaxValLen+1; char out[MaxValLen+1], *pi, *pd; unsigned long length; sprintf(out, "%u.%2u", version.Major, version.Minor); length = (outlenv2:1) SYNOPSIS typedef struct Data_Format_Version { unsigned short Major, Minor; } DFVersion; int compare_versions( DFVersion version1, DFVersion version2 ); DESCRIPTION The comparison is done in the following way: major1 = version1.Major, etc. major1minor2 1 major1>major2 1 RETURN VALUE -1, 0, 1 depending on the comparison ---------------------------------------------------------------------------*/ int compare_versions( DFVersion version1, DFVersion version2 ) { int result; if ( version1.Majorversion2.Major ) result = +1; else if ( version1.Minorversion2.Minor ) result = +1; else result = 0; return(result); } /* compare_versions */ /*===string_access END==================================================---*/ /*===data_structure BEGIN==================================================*/ /*--------------------------------------------------------------------------- NAME init_data_file_flags --- initialize data file flags SYNOPSIS init init_data_file_flags( DFFlags * Flags ) RETURN VALUE success: 0 error: not 0 ---------------------------------------------------------------------------*/ int init_data_file_flags( DFFlags * Flags ) { Flags->ExistingFile = (unsigned short) False; Flags->ReadOnlyFile = (unsigned short) False; Flags->TemporaryFile = (unsigned short) False; if (write_general_block) Flags->NoGeneralHeader = (unsigned short) False; else Flags->NoGeneralHeader = (unsigned short) True; return(0); } /* init_data_file_flags */ /*--------------------------------------------------------------------------- print_data_file_flags (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_data_file_flags ( FILE * out, const DFFlags * Flags ) { fprintf(out,"Flags\n"); fprintf(out," ExistingFile = %hu\n",Flags->ExistingFile); fprintf(out," ReadOnlyFile = %hu\n",Flags->ReadOnlyFile); fprintf(out," TemporaryFile = %hu\n",Flags->TemporaryFile); fprintf(out," NoGeneralHeader = %hu\n",Flags->NoGeneralHeader); return(0); } /* print_data_file_flags */ /*--------------------------------------------------------------------------- init_file ---------------------------------------------------------------------------*/ void init_file ( DFile * file ) { file->Used = False; file->Name = (char *) NULL; file->Channel = (FILE *) NULL; file->Buffer = (char *) NULL; file->Version = str2version( DataFormatVersion ); file->BlockBoundary = (unsigned long) BLOCK_BOUNDARY; init_data_file_flags( &(file->Flags) ); file->GeneralBlock = (DBlock *) NULL; file->ActiveBlock = (DBlock *) NULL; file->NextSequenceNumber = (unsigned long) FirstHeader; file->LastBlockInFile = (DBlock *) NULL; file->ChainList = (DChain *) NULL; } /* init_file */ /*--------------------------------------------------------------------------- init_file_table ---------------------------------------------------------------------------*/ void init_file_table( DFile ftb[] ) /* Init file table, set InitTable to 1 */ { register int i; for (i=0;iRead = (unsigned short) 0; return(0); } /* init_symbol_element_flags */ /*--------------------------------------------------------------------------- print_symbol_element_flags (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_symbol_element_flags ( FILE * out, const SEFlags * Flags ) { fprintf(out," Flags\n"); fprintf(out," Read = %hu\n",Flags->Read); return(0); } /* print_symbol_element_flags */ /*--------------------------------------------------------------------------- NAME insert_symbol -- insert/update ´key´ in symbol-list of ´block´ SYNOPSIS int insert_symbol( DBlock * block, const char * Key, const char * Value, SElement ** symbol ); DESCRIPTION If 'Key' already exists (success), its 'Value' is updated and the 'symbol' pointer is returned in *symbol if symbol is not the NULL pointer. Data format keys are inserted before all others. 'String' is not updated. RETURN VALUE ´Key´ successfully updated, symbol pointer to symbol returned in *symbol, return value 0 ´Key´ updated failed: -1, *symbol set to NULL pointer ---------------------------------------------------------------------------*/ int insert_symbol( DBlock * block, const char * Key, const char * Value, SElement ** symbol ) { SElement * newsymbol, * next, * previous; char * tmp; int notfound = -1; /* initialize *symbol */ if (symbol) *symbol = (SElement *) NULL; /* check Key */ if ( Key == (const char *) NULL ) return(-1); // Key required /* check Value */ if ( Value == (const char *) NULL ) return(-1); // Value required /* check block */ if ( block == (DBlock *) NULL ) return(-1); // block cannot be NULL /* warning, if Key too long */ if ( strlen(Key)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING: The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING: The length %zu | %lu of %10s... exceeds %d\n", strlen(Key), strlen(Key), Key, MaxKeyLen ); } previous = (SElement *) NULL; next = block->SymbolList; /* search insertion point (insertion before next) */ while( ( next!=(SElement *) NULL ) && (notfound<0) ) { notfound = compare_keys(next->Key,Key,UpperCaseSort); if (notfound<0) {previous = next; next = next->Next;} } /* create new symbol, if (notfound) */ if ( notfound ) { /* create new symbol */ if (!(newsymbol = (SElement *) malloc( sizeof(SElement) ) )) return(-1); newsymbol->Key = newstrn( Key, MaxKeyLen ); if (!newsymbol->Key) { free(newsymbol); return(-1); } newsymbol->Value = (char *) NULL; newsymbol->KeyPos = (unsigned long) 0; newsymbol->ValPos = (unsigned long) 0; newsymbol->KeyLen = (unsigned short) STRLEN(Key); newsymbol->ValLen = (unsigned short) 0; newsymbol->String = (char *) NULL; newsymbol->StringLen = (unsigned short) 0; init_symbol_element_flags( &(newsymbol->Flags) ); /* insert newsymbol before next */ if (next) next->Previous = newsymbol; newsymbol->Next=next; newsymbol->Previous=previous; if (previous) previous->Next=newsymbol; else block->SymbolList = newsymbol; /* link to owning block */ newsymbol->Block = block; next = newsymbol; } /* update Value (Value and original next->Value can be identical!) */ tmp = newstr( Value ); if (!tmp) return(-1); if ( next->Value ) free ( next->Value ); next->Value = tmp; next->ValLen = (unsigned short) STRLEN(Value); if (symbol) *symbol = next; block->KeyOrderNextSymbol = block->SymbolList; block->KeyOrderNo = 0; return(0); } /* insert_symbol */ /*--------------------------------------------------------------------------- NAME search_symbol -- search for ´Key´ in symbol-list of ´block´ SYNOPSIS int search_symbol( DBlock * block, const char * Key, SElement ** symbol ); DESCRIPTION Searches for 'Key' and returns a pointer to it in *symbol, if symbol is not the NULL pointer. 'String' is not updated. RETURN VALUE ´Key´ found, symbol pointer returned in **symbol, return value 0 ´Key´ not found: -1, pointer (SElement *) NULL returned in **symbol ---------------------------------------------------------------------------*/ int search_symbol( DBlock * block, const char * Key, SElement ** symbol ) { SElement * current; /* initialize *symbol */ if (symbol) *symbol = (SElement *) NULL; /* check Key */ if ( Key == (const char *) NULL ) return(-1); // Key required /* check block */ if ( block == (DBlock *) NULL ) return(-1); // block cannot be NULL /* warning, if Key too long */ if ( strlen(Key)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING (search_symbol): The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING (search_symbol): The length %zu | %lu of %10s... exceeds %d\n", strlen(Key), strlen(Key), Key, MaxKeyLen ); } /* search symbol */ current = block->SymbolList; if ( current!=(SElement *) NULL ) while( ( current!=(SElement *) NULL ) && ( compare_keys(current->Key,Key,UpperCaseSort)!=0 ) ) { current = current->Next; } if (symbol) *symbol = current; if (current==(SElement *) NULL) return(-1); return(0); } /* search_symbol */ /*--------------------------------------------------------------------------- NAME delete_symbol -- deletes 'symbol' from symbol-list of ´block´ SYNOPSIS int delete_symbol( DBlock * block, SElement * symbol, SElement ** Next ) DESCRIPTION The routine ends with success if the symbol 'symbol' is not any more present, even if it symbol is the NULL pointer. A pointer to the element after the deleted element is returned (ignored if Next is the NULL pointer). RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int delete_symbol( DBlock * block, SElement * symbol, SElement ** Next ) { SElement *previous, *next; /* initialize *Next */ if (Next) *Next = (SElement *) NULL; /* check symbol */ if (!symbol) return(0); // nothing to delete /* check block */ if ( block == (DBlock *) NULL ) return(-1); // block cannot be NULL /* change links */ previous = symbol->Previous; next = symbol->Next; if ( next != (SElement *) NULL ) next->Previous = previous; if ( previous != (SElement *) NULL ) previous->Next = next; else block->SymbolList = next; /* remove symbol */ free(symbol->Key); free(symbol->Value); if (symbol->String) free(symbol->String); free(symbol); block->KeyOrderNextSymbol = block->SymbolList; block->KeyOrderNo = 0; if (Next) *Next = next; return(0); } // delete_symbol /*--------------------------------------------------------------------------- NAME remove_symbol -- removes ´key´ from symbol-list of ´block´ SYNOPSIS int remove_symbol( DBlock * block, const char * Key, SElement ** Next ); DESCRIPTION The routine ends with success if the symbol is not any more present, even if it does not exist before the call of this function. A pointer to the element after the removed element is returned (ignored if Next is the NULL pointer). RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int remove_symbol( DBlock * block, const char * Key, SElement ** Next ) { SElement * current; /* initialize *Next */ if (Next) *Next = (SElement *) NULL; /* check Key */ if ( Key == (const char *) NULL ) return(0); // nothing to remove any more /* check block */ if ( block == (DBlock *) NULL ) return(-1); // block cannot be NULL /* warning, if Key too long */ if ( strlen(Key)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING: The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING: The length %zu | %lu of %10s... exceeds %d\n", strlen(Key), strlen(Key), Key, MaxKeyLen ); } /* search symbol */ current = block->SymbolList; if ( current!=(SElement *) NULL ) while( ( current!=(SElement *) NULL ) && ( compare_keys(current->Key,Key,UpperCaseSort)!=0 ) ) { current = current->Next; } /* stop, if no symbol found */ if (current==(SElement *) NULL) return(0); /* remove current */ if (delete_symbol( block, current, Next )) return(-1); return(0); } /* remove_symbol */ /*--------------------------------------------------------------------------- insert_symbol_root (success:0, error:-1) The symbol is inserted directly at the root of the list. A symbol with the same name is removed before inserting. ---------------------------------------------------------------------------*/ int insert_symbol_root( DBlock * block, const char * Key, const char * Value, SElement ** symbol ) { SElement * newsymbol, * next, * previous; char * tmpKey, * tmpValue; /* warning, if Key too long */ if ( strlen(Key)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING: The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING: The length %zu | %lu of %10s... exceeds %d\n", strlen(Key), strlen(Key), Key, MaxKeyLen ); } if ( block == (DBlock *) NULL) return(-1); /* allocate memory and copy Key and Value to new variables (Value/Key and original next->Value/Key can be identical!) */ tmpKey = newstrn( Key, MaxKeyLen ); if (!tmpKey) return(-1); tmpValue = newstr( Value ); if (!tmpValue) {free(tmpKey);return(-1);} /* remove old symbol */ if ( remove_symbol(block, Key, NULL) ) {free(tmpKey);free(tmpValue);return(-1);} *symbol = (SElement *) NULL; previous = (SElement *) NULL; next = block->SymbolList; /* create new symbol */ if (!(newsymbol = (SElement *) malloc( sizeof(SElement) ) )) { free(tmpKey);free(tmpValue);return(-1); } newsymbol->Key = tmpKey; newsymbol->Value = tmpValue; newsymbol->KeyPos = (unsigned long) 0; newsymbol->ValPos = (unsigned long) 0; newsymbol->KeyLen = (unsigned short) STRLEN(tmpKey); newsymbol->ValLen = (unsigned short) STRLEN(tmpValue); newsymbol->String = (char *) NULL; newsymbol->StringLen = (unsigned short) 0; init_symbol_element_flags( &(newsymbol->Flags) ); /* insert newsymbol before next */ if (next) next->Previous = newsymbol; newsymbol->Next=next; newsymbol->Previous=previous; if (previous) previous->Next=newsymbol; else block->SymbolList=newsymbol; /* link to owning block */ newsymbol->Block = block; *symbol = newsymbol; block->KeyOrderNextSymbol = block->SymbolList; block->KeyOrderNo = 0; return(0); } /* insert_symbol_root */ /*--------------------------------------------------------------------------- free_symbol_list (success:0, error:-1) ---------------------------------------------------------------------------*/ int free_symbol_list( DBlock * block ) { SElement * symbol, * next; next = block->SymbolList; block->SymbolList = (SElement *) NULL; while(next!=(SElement*) NULL) { symbol = next; next=next->Next; free(symbol->Value); free(symbol->Key); if (symbol->String) free(symbol->String); free(symbol); } block->KeyOrderNextSymbol = block->SymbolList; block->KeyOrderNo = 0; return(0); } /* free_symbol_list */ /*--------------------------------------------------------------------------- netto_header_length (success:0, error:-1) Calculation of the netto header length (without PadLen). It includes: length(header_begin) + [ Symbol->KeyLen + length(symbol_separator) + Symbol->ValLen + length(symbol_terminator) ] (for symbols) + length(header_end) ---------------------------------------------------------------------------*/ unsigned long netto_header_length( DBlock * block ) { const unsigned long h_begin=(unsigned long) strlen(header_begin); const unsigned long s_syms =(unsigned long) (strlen(symbol_separator) + strlen(symbol_terminator)); const unsigned long h_end =(unsigned long) strlen(header_end); unsigned long h_len; SElement * symbol; symbol = block->SymbolList; h_len = h_begin; while (symbol!=(SElement*) NULL) { h_len += (unsigned long) symbol->KeyLen + (unsigned long) symbol->ValLen + s_syms; symbol=symbol->Next; } h_len += h_end; return(h_len); } /* netto_header_length */ /*--------------------------------------------------------------------------- print_symbol_list (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_symbol_list( FILE * out, DBlock * block, int level, int verbose ) { const char * SeparationLine = "- - - - - - - -"; SElement * symbol; if (level<1) return(0); symbol = block->SymbolList; while (symbol!=(SElement*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Key = %s\n",symbol->Key); fprintf(out," Value = %s\n",symbol->Value); fprintf(out," KeyPos = %lu\n",symbol->KeyPos); fprintf(out," ValPos = %lu\n",symbol->ValPos); fprintf(out," KeyLen = %u\n",symbol->KeyLen); fprintf(out," ValLen = %u\n",symbol->ValLen); fprintf(out," String = %s\n", (symbol->String)?(symbol->String):"(not set)"); fprintf(out," StringLen = %u\n",symbol->StringLen); print_symbol_element_flags ( out, &(symbol->Flags) ); fprintf(out," Previous Key = "); if ((symbol->Previous)!=(SElement*) NULL) fprintf(out,"%s\n", symbol->Previous->Key); else fprintf(out,"(no previous symbol)\n"); fprintf(out," Next Key = "); if ((symbol->Next)!=(SElement*) NULL) fprintf(out,"%s\n", symbol->Next->Key); else fprintf(out,"(no next symbol)\n"); fprintf(out," Owner Block = %s\n",symbol->Block->BlockKey); } else { fprintf(out," '%s' = '%s'\n",symbol->Key,symbol->Value); } symbol=symbol->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* print_symbol_list */ /*--------------------------------------------------------------------------- NAME init_data_block_flags --- initialize data block flags SYNOPSIS init init_data_block_flags( DBFlags * Flags ) RETURN VALUE success: 0 error: not 0 ---------------------------------------------------------------------------*/ int init_data_block_flags( DBFlags * Flags ) { Flags->InternalHeader = (unsigned short) 0; Flags->InternalData = (unsigned short) 0; Flags->DiskBlockUsed = (unsigned short) 0; Flags->DiskBlockFixed = (unsigned short) 0; Flags->HeaderExternal = (unsigned short) 0; Flags->HeaderChanged = (unsigned short) 0; Flags->DataExternal = (unsigned short) True; Flags->DataChanged = (unsigned short) 0; Flags->ExternalDimAlloc = (unsigned short) 0; Flags->ExternalDataAlloc = (unsigned short) 0; Flags->BadBlock = (unsigned short) 0; return(0); } /* init_data_block_flags */ /*--------------------------------------------------------------------------- print_data_block_flags (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_data_block_flags ( FILE * out, const DBFlags * Flags ) { fprintf(out," Flags\n"); fprintf(out," InternalHeader = %hu\n",Flags->InternalHeader); fprintf(out," InternalData = %hu\n",Flags->InternalData); fprintf(out," DiskBlockUsed = %hu\n",Flags->DiskBlockUsed); fprintf(out," DiskBlockFixed = %hu\n",Flags->DiskBlockFixed); fprintf(out," HeaderExternal = %hu\n",Flags->HeaderExternal); fprintf(out," HeaderChanged = %hu\n",Flags->HeaderChanged); fprintf(out," DataExternal = %hu\n",Flags->DataExternal); fprintf(out," DataChanged = %hu\n",Flags->DataChanged); fprintf(out," ExternalDimAlloc = %hu\n",Flags->ExternalDimAlloc); fprintf(out," ExternalDataAlloc = %hu\n",Flags->ExternalDataAlloc); fprintf(out," BadBlock = %hu\n",Flags->BadBlock); return(0); } /* print_data_block_flags */ /*--------------------------------------------------------------------------- insert_data_block (success:0, error:-1) If 'BlockKey' already exists (success), only the 'block' pointer is returned. ---------------------------------------------------------------------------*/ int insert_data_block( DChain * chain, const char * BlockKey, DBlock ** block ) { DBlock * newblock, * next, * previous; int notfound = -1; /* warning, if BlockKey too long */ if ( strlen(BlockKey)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING: The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING: The length %zu | %lu of %10s... exceeds %d\n", strlen(BlockKey), strlen(BlockKey), BlockKey, MaxKeyLen ); } if ( chain == (DChain *) NULL ) return(-1); *block = (DBlock *) NULL; previous = (DBlock *) NULL; next = chain->BlockList; /* search insertion point (insertion before *pnext) */ while( ( next!=(DBlock *) NULL ) && (notfound<0) ) { notfound = compare_keys(next->BlockKey,BlockKey,NumberSort); if (notfound<0) {previous = next; next = next->Next;} } /* create new block, if (notfound) */ if ( notfound ) { /* create new block */ if (!(newblock = (DBlock *) malloc( sizeof(DBlock) ) )) return(-1); newblock->BlockKey = newstrn( BlockKey, MaxKeyLen ); if (!newblock->BlockKey) {free(newblock);return(-1);} newblock->BlockKeyLen = (unsigned short) STRLEN(BlockKey); newblock->TextPos = (unsigned long) 0; newblock->BinaryPos = (unsigned long) 0; newblock->TextLen = (unsigned long) 0; newblock->BinaryLen = (unsigned long) 0; newblock->PadLen = (unsigned long) 0; newblock->BinaryFileName = (char *) NULL; newblock->BinaryFilePos = (unsigned long) 0; newblock->BinaryFileLen = (unsigned long) 0; newblock->Data = (void *) NULL; newblock->DataBufferLen = (size_t) 0; newblock->DataLen = (size_t) 0; newblock->DataType = (long) 0; newblock->DataByteOrder = (long) 0; newblock->DataRasterConfiguration = (long) 0; newblock->DataCompression = (long) 0; newblock->DataValueOffset = (long) 0; newblock->DataDim = (long *) NULL; newblock->Raw = (void *) NULL; newblock->RawBufferLen = (size_t) 0; newblock->RawLen = (size_t) 0; if ( init_data_block_flags( &(newblock->Flags) ) ) return(-1); newblock->SequenceNumber = (unsigned long) 0; newblock->SymbolList = (SElement *) NULL; newblock->KeyOrderNo = 0; newblock->KeyOrderNextSymbol = (SElement *) NULL; /* insert newblock before *pnext */ if (next) next->Previous = newblock; newblock->Next=next; newblock->Previous=previous; if (previous) previous->Next=newblock; else chain->BlockList=newblock; /* link to owning chain */ newblock->Chain = chain; next = newblock; } *block = next; return(0); } /* insert_data_block */ /*--------------------------------------------------------------------------- search_data_block (success:0, error:-1) ---------------------------------------------------------------------------*/ int search_data_block( DChain * chain, const char * BlockKey, DBlock ** block ) { DBlock * current; /* warning, if BlockKey too long */ if ( strlen(BlockKey)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING: The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING: The length %zu | %lu of %10s... exceeds %d\n", strlen(BlockKey), strlen(BlockKey), BlockKey, MaxKeyLen ); } /* search block */ current = chain->BlockList; if (current!=(DBlock *) NULL ) while( ( current!=(DBlock *) NULL ) && ( compare_keys(current->BlockKey,BlockKey,NumberSort)!=0 ) ) { current = current->Next; } *block = current; if (current==(DBlock *) NULL) return(-1); return(0); } /* search_data_block */ /*--------------------------------------------------------------------------- free_data_block_list (success:0, error:-1) ---------------------------------------------------------------------------*/ int free_data_block_list( DChain * chain ) { DBlock * block, * next; next = chain->BlockList; chain->BlockList = (DBlock *) NULL; while(next!=(DBlock*) NULL) { block = next; next=next->Next; if ( free_symbol_list( block ) ) return(-1); if ( block->BinaryFileName ) free( block->BinaryFileName ); if ( block->BlockKey ) free( block->BlockKey ); if ( ( block->DataDim ) && ( !block->Flags.ExternalDimAlloc ) ) free( block->DataDim ); if ( ( block->Data ) && ( !block->Flags.ExternalDataAlloc ) ) free ( block->Data ); if ( block->Raw ) free ( block->Raw ); free(block); } return(0); } /* free_data_block_list */ /*--------------------------------------------------------------------------- print_data_block_list (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_data_block_list( FILE * out, DChain * chain, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - -"; long i_dim; DBlock * block; if (level<1) return(0); block = chain->BlockList; while(block!=(DBlock*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," BlockKey = %s\n",block->BlockKey); fprintf(out," BlockKeyLen = %u\n",block->BlockKeyLen); fprintf(out," TextPos = %lu\n",block->TextPos); fprintf(out," BinaryPos = %lu\n",block->BinaryPos); fprintf(out," TextLen = %lu\n",block->TextLen); fprintf(out," BinaryLen = %lu\n",block->BinaryLen); fprintf(out," PadLen = %lu\n",block->PadLen); if ( block->BinaryFileName ) fprintf(out," BinaryFileName = %s\n",block->BinaryFileName); else fprintf(out," BinaryFileName = %s\n","(this file)"); fprintf(out," BinaryFilePos = %lu\n",block->BinaryFilePos); fprintf(out," BinaryFileLen = %lu\n",block->BinaryFileLen); fprintf(out," Data = %p\n",block->Data); // fprintf(out," DataLen (DataBufferLen) = %zu (%zu)\n", fprintf(out," DataLen (DataBufferLen) = %zu | %lu (%lu)\n", block->DataLen,block->DataLen,block->DataBufferLen); fprintf(out," DataType = %ld\n",block->DataType); fprintf(out," DataByteOrder = %s\n", ByteOrder2String(block->DataByteOrder)); fprintf(out," DataRasterConfiguration = %ld\n", block->DataRasterConfiguration); fprintf(out," DataCompression = %s\n", edf_compression2string(block->DataCompression)); fprintf(out," DataValueOffset = %ld\n",block->DataValueOffset); fprintf(out," DataDim = %p\n",block->DataDim); fprintf(out," Raw = %p\n",block->Raw); // fprintf(out," RawLen (RawBufferLen) = %zu (%zu)\n", fprintf(out," RawLen (RawBufferLen) = %zu | %lu (%lu)\n", block->RawLen,block->RawLen,block->RawBufferLen); if (block->DataDim) for (i_dim=0;i_dim<=block->DataDim[0];i_dim++) fprintf(out," DataDim[%1lu] = %ld\n", i_dim,(block->DataDim)[i_dim]); print_data_block_flags( out, &(block->Flags) ); fprintf(out," SequenceNumber = %lu\n",block->SequenceNumber); print_symbol_list( out, block, level-1, verbose ); fprintf(out," KeyOrderNo = %d\n",block->KeyOrderNo); if (block->KeyOrderNextSymbol == (SElement *) NULL ) { fprintf(out," KeyOrderNextSymbol= (no next symbol)\n"); } else { fprintf(out," KeyOrderNextSymbol= %s\n",block->KeyOrderNextSymbol->Key); } fprintf(out," Previous BlockKey = "); if ((block->Previous)!=(DBlock*) NULL) fprintf(out,"%s\n", block->Previous->BlockKey); else fprintf(out,"(no previous block)\n"); fprintf(out," Next BlockKey = "); if ((block->Next)!=(DBlock*) NULL) fprintf(out,"%s\n", block->Next->BlockKey); else fprintf(out,"(no next block)\n"); fprintf(out," Owner Chain = %s\n",block->Chain->ChainKey); } else { fprintf(out," BlockKey = '%s'\n",block->BlockKey); print_symbol_list( out, block, level-1, verbose ); } block=block->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* print_data_block_list */ /*--------------------------------------------------------------------------- insert_data_chain (success:0, error:-1) If 'ChainKey' already exists (success), only the 'chain' pointer is returned. ---------------------------------------------------------------------------*/ int insert_data_chain( DFile * file, const char * ChainKey, DChain ** chain ) { DChain * newchain, * next, * previous; int notfound = -1; /* warning, if ChainKey too long */ if ( strlen(ChainKey)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING: The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING: The length %zu | %lu of %10s... exceeds %d\n", strlen(ChainKey), strlen(ChainKey), ChainKey, MaxKeyLen ); } if ( file == (DFile *) NULL ) return(-1); *chain = (DChain *) NULL; previous = (DChain *) NULL; next = file->ChainList; /* search insertion point (insertion before *pnext) */ while( ( next!=(DChain *) NULL ) && (notfound<0) ) { notfound = compare_keys(next->ChainKey,ChainKey,UpperCaseSort); if (notfound<0) { previous = next; next = next->Next; } } /* create new chain, if (notfound) */ if ( notfound ) { /* create new chain */ if (!(newchain = (DChain *) malloc( sizeof(DChain) ) )) return(-1); newchain->ChainKey = newstrn( ChainKey, MaxKeyLen ); if (!newchain->ChainKey) {free(newchain);return(-1);} newchain->ChainKeyLen = (unsigned short) STRLEN(ChainKey); newchain->Flags = (unsigned short) 0; newchain->BlockList = (DBlock *) NULL; /* insert newchain before *pnext */ if (next) next->Previous = newchain; newchain->Next=next; newchain->Previous=previous; if (previous) previous->Next = newchain; else file->ChainList = newchain; /* link to owning file */ newchain->File = file; next = newchain; } *chain = next; return(0); } /* insert_data_chain */ /*--------------------------------------------------------------------------- search_data_chain (success:0, error:-1) ---------------------------------------------------------------------------*/ int search_data_chain( DFile * file, const char * ChainKey, DChain ** chain ) { DChain * current; /* warning, if ChainKey too long */ if ( strlen(ChainKey)>MaxKeyLen ) { // fprintf(stderr,"\nWARNING: The length %zu of %10s... exceeds %d\n", fprintf(stderr,"\nWARNING: The length %zu | %lu of %10s... exceeds %d\n", strlen(ChainKey), strlen(ChainKey), ChainKey, MaxKeyLen ); } /* search chain */ current = file->ChainList; if ( current!=(DChain *) NULL ) while( ( current!=(DChain *) NULL ) && ( compare_keys(current->ChainKey,ChainKey,UpperCaseSort)!=0 ) ) { current = current->Next; } *chain = current; if (current==(DChain *) NULL) return(-1); return(0); } /* search_data_chain */ /*--------------------------------------------------------------------------- NAME free_data_chain --- deletes a data chain and all of its contents SYNOPSIS int free_data_chain( DChain * chain ); DESCRIPTION The memory of all blocks and symbols of the data chain ´chain´ is removed. The data chain is removed from the chain list of the owning file. If ´chain´ was the only chain in ´chain->File->ChainList´ ´chain->File->ChainList is set to (DChain *) NULL. If ´chain´ is NULL, nothing is done and 0 (success) is returned. RETURN VALUES success: 0 error : -1 ---------------------------------------------------------------------------*/ int free_data_chain( DChain * chain ) { DChain **proot, *previous, *next; if (chain!=(DChain*) NULL) { proot = &(chain->File->ChainList); previous = chain->Previous; next = chain->Next; } else return(0); if (next!=(DChain*) NULL) next->Previous = previous; if (previous!=(DChain*) NULL) previous->Next = next; if (*proot==chain) { *proot = ((DChain*) NULL); } if (free_data_block_list( chain )) return(-1); free(chain->ChainKey); free(chain); return(0); } /* free_data_chain */ /*--------------------------------------------------------------------------- free_data_chain_list (success:0, error:-1) ---------------------------------------------------------------------------*/ int free_data_chain_list( DFile * file ) { DChain * chain, * next; next = file->ChainList; file->ChainList = (DChain *) NULL; while ( next!=(DChain*) NULL ) { chain = next; next=next->Next; if (free_data_block_list( chain )) return(-1); free(chain->ChainKey); free(chain); } return(0); } /* free_data_chain_list */ /*--------------------------------------------------------------------------- print_data_chain_list (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_data_chain_list( FILE * out, DFile * file, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - - - - - - - - - - - - - - - -"; DChain * chain; if (level<1) return(0); chain = file->ChainList; while(chain!=(DChain*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," ChainKey = %s\n",chain->ChainKey); fprintf(out," ChainKeyLen = %u\n",chain->ChainKeyLen); fprintf(out," Flags = %#x\n", chain->Flags); print_data_block_list( out, chain, level-1, verbose ); fprintf(out," Previous ChainKey = "); if ((chain->Previous)!=(DChain*) NULL) fprintf(out,"%s\n", chain->Previous->ChainKey); else fprintf(out,"(no previous chain)\n"); fprintf(out," Next ChainKey = "); if ((chain->Next)!=(DChain*) NULL) fprintf(out,"%s\n", chain->Next->ChainKey); else fprintf(out,"(no next chain)\n"); // fprintf(out," Owner file = %#x\n",chain->File->Channel); fprintf(out," Owner file = %p\n",chain->File->Channel); } else { fprintf(out," ChainKey = '%s'\n",chain->ChainKey); print_data_block_list( out, chain, level-1, verbose ); } chain=chain->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* print_data_chain_list */ /*+++------------------------------------------------------------------------ NAME edf_print_filetable (success:0, error:-1) SYNOPSIS int edf_print_filetable( FILE * out, int level, int verbose ) DESCRIPTION Prints the current filetable to the file ´out´ RETURN VALUE 0: success -1: failed ---------------------------------------------------------------------------*/ int edf_print_filetable( FILE * out, int level, int verbose ) /*---*/ { const int buflen = MaxValLen+1; char buffer[MaxValLen+1]; const char * SeparationLine = "========================================================="; int stream; if (level<1) return(0); if (!InitTable) return(-1); if (!out) return(-1); for (stream=0;streamBlockKey); else fprintf(out,"(no block key)\n"); } else fprintf(out,"(block not defined)\n"); fprintf(out,"ActiveBlock = "); if (FileTable[stream].ActiveBlock) { if (FileTable[stream].ActiveBlock->BlockKey) fprintf(out,"%s\n",FileTable[stream].ActiveBlock->BlockKey); else fprintf(out,"(no block key)\n"); } else fprintf(out,"(block not defined)\n"); fprintf(out,"NextSequenceNumber = %lu\n", FileTable[stream].NextSequenceNumber); fprintf(out,"LastBlockInFile = "); if (FileTable[stream].LastBlockInFile) { if (FileTable[stream].LastBlockInFile->BlockKey) fprintf(out,"%s\n",FileTable[stream].LastBlockInFile->BlockKey); else fprintf(out,"(no block key)\n"); } else fprintf(out,"(no block written)\n"); fprintf(out,"ChainList = %p\n",FileTable[stream].ChainList); print_data_chain_list(out,&FileTable[stream],level-1,verbose); } else { fprintf(out,"Stream = '%d'\n",stream); print_data_chain_list(out,&FileTable[stream],level-1,verbose); } } if (verbose) fprintf(out,"%s\n",SeparationLine); return(0); } /* edf_print_filetable */ /*--------------------------------------------------------------------------- NAME delete_continuationkeys -- delete continuation keys starting at current SYNOPSIS int delete_continuationkeys( DBlock * block, SElement *current ); DESCRIPTION The routine removes any continuation key starting at current, independent of its name and depth, until the first key with depth <1. If current is the NULL pointer nothing is done and the return value is 0. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int delete_continuationkeys( DBlock * block, SElement *current ) { while ( ( current ) && ( continuation_depth( current->Key ) > 0 ) ) if ( delete_symbol( block, current, ¤t ) ) return(-1); return(0); } // delete_continuationkeys /*--------------------------------------------------------------------------- NAME update_string --- update symbol string with continuation key values SYNOPSIS int update_string( SElement *base, SElement **next ); DESCRIPTION Updates the base string with continuation key values RETURN VALUE 0: successful update -1: failure ---------------------------------------------------------------------------*/ int update_string( SElement *base, SElement **next ) { SElement *current; long stringlen=0l, nxtlen; char *ps; unsigned long keybuflen = MaxKeyLen+1; char keybuffer[MaxKeyLen+1]; const char *fkey; int depth=1; if (next) *next = (SElement *) NULL; /* Calculate required string length from accumalated value lengths The length of a string values is at least the length of the string. */ depth = 0; current = base; stringlen = 0l; fkey = continuation_key( keybuffer, keybuflen, base->Key, depth++ ); while ( (current) && (fkey) ) { if (compare_keys(current->Key,fkey,UpperCaseSort)==0) { stringlen += STRLEN( current->Value ); fkey = continuation_key( keybuffer, keybuflen, base->Key, depth++ ); current = current->Next; } else fkey = (char *) NULL; // stop } // allocate and update base String if ( (base->StringLenString)) ) { if (base->String) free(base->String); base->String = newstring( stringlen ); base->StringLen = stringlen; } else { stringlen = base->StringLen; } (base->String)[0] = '\0'; // copy continuation key values to base string depth = 0; current = base; fkey = continuation_key( keybuffer, keybuflen, base->Key, depth++ ); // read base->string ps = base->String; while ( (current) && (fkey) ) { if (compare_keys(current->Key,fkey,UpperCaseSort)==0) { if (stringlen>0) { /* transform value to string and append it to base->String */ val2str( ps, stringlen+1, current->Value ); nxtlen=STRLEN(ps); ps=&ps[nxtlen]; stringlen-=nxtlen; } fkey = continuation_key( keybuffer, keybuflen, base->Key, depth++ ); current = current->Next; // increment only when Key==fkey } else fkey = (char *) NULL; // stop } if (next) *next = current; return(0); } // update_string /*--------------------------------------------------------------------------- NAME insert_string -- insert/update continuation ´key´s in symbol-list of ´block´ SYNOPSIS int insert_string( DBlock * block, const char * BaseKey, const char * String, SElement ** symbol ); DESCRIPTION The value of 'BaseKey' and all its continuation keys are updated with 'String'. 'String' is copied into the string-symbol of symbol. Unused continuation keys are removed. If 'BaseKey' does not exist it is created. 'String' is splitted into values that are each smaller than MaxConLen (MaxConLen+1 including terminating zero). The pointer to the created/modified base symbol (with continuation depth 0) is returned. RETURN VALUE All continuation keys of 'BaseKey' successfully inserted/updated, symbol pointer to 'BaseKey' returned in **symbol, return value 0 Insertion/update failed, *symbol set to NULL pointer, return value -1 ---------------------------------------------------------------------------*/ int insert_string( DBlock * block, const char * BaseKey, const char * String, SElement ** symbol ) { unsigned long buflen = MaxConLen+1; char buffer1[MaxConLen+1], buffer2[MaxConLen+1]; unsigned long keybuflen = MaxKeyLen+1; char keybuffer[MaxKeyLen+1]; SElement *current; const char *val, *bkval, *ps; const char *fkey; unsigned long pos1, pos2; int depth=0; size_t stringlen; if (symbol) *symbol = (SElement *) NULL; // split String ps = String; pos2 = max_line_width; do { fkey = continuation_key( keybuffer, keybuflen, BaseKey, depth ); if (fkey) { pos1 = MAX(2, max_line_width - STRLEN(symbol_separator) - STRLEN(fkey)); val = str2val( buffer1, buflen, ps, &ps ); bkval = breakval ( buffer2, buflen, val, pos1, pos2 ); // break line if ( insert_symbol( block, fkey, bkval, ¤t ) ) return( -1 ); // update base string with input string, allocate memory if necessary if (depth==0) { stringlen = STRLEN( String ); if ( ( (current->StringLen) < stringlen ) || (!(current->String)) ) { if ( current->String ) { free( current->String ); } current->String = newstr( String ); current->StringLen = stringlen; } else { strcpy(current->String, String ); } } } depth++; } while ( (*ps)&&(fkey) ); // stop if fkey could not be created if (symbol) *symbol = current; // delete unused continuation keys that follow immediately if ( delete_continuationkeys( block, current->Next ) ) return(-1); return(0); } // insert_string /*--------------------------------------------------------------------------- NAME search_string -- searches for ´BaseKey´ in symbol-list of ´block´ SYNOPSIS int search_string( DBlock *block, const char *BaseKey, SElement **symbol ); DESCRIPTION Searches for 'BaseKey' in symbol-list of ´block´. If it was found the symbol-string is created from the values of 'BaseKey' and of all its continuation keys. The pointer to 'BaseKey' is returned in symbol if it is not NULL. RETURN VALUE ´BaseKey´ found, symbol pointer returned in *symbol, return value 0 ´BaseKey´ not found, *symbol set to NULL pointer, return value -1 ---------------------------------------------------------------------------*/ int search_string( DBlock *block, const char *BaseKey, SElement **symbol ) { SElement *base; // initialize *symbol if (symbol) *symbol = (SElement *) NULL; // search BaseKey if (search_symbol( block, BaseKey, &base )) return(-1); // update *symbol if (symbol) *symbol = base; if ( update_string( base, NULL ) ) return(-1); return(0); } // search_string /*--------------------------------------------------------------------------- NAME remove_string -- removes continuation ´key´s from symbol-list of ´block´ SYNOPSIS int remove_string( DBlock * block, const char * Key ); DESCRIPTION The routine ends with success if neither 'Key' nor its continuation 'Key's are any more present, even if no key was actually removed. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int remove_string( DBlock * block, const char * Key ) { SElement *next; if ( remove_symbol( block, Key, &next ) ) return(-1); // delete unused continuation keys that follow immediately if ( delete_continuationkeys( block, next ) ) return(-1); return(0); } // remove_string /*--------------------------------------------------------------------------- NAME search_general -- search for ´key´ in ´block´ and GeneralBlock SYNOPSIS int search_general( DBlock * block, const char * Key, SElement ** symbol ); DESCRIPTION Searches for a ´key´ in the symbol list of ´block´. If ´key´ was not found and if it is a user key, it searches afterwards in the general block. A user key is a key that does not start with ´DATA_FORMAT_PREFIX´. If ´key´ was found the pointer to the ´symbol´ element is returned. RETURN VALUE ´key´ found, symbol pointer returned in **symbol, return value 0 ´key´ not found: -1, pointer (SElement *) NULL returned in **symbol ---------------------------------------------------------------------------*/ int search_general( DBlock * block, const char * Key, SElement ** symbol ) { int return_status; if ((return_status = search_string( block, Key, symbol ))) { if (!is_prefix(Key,DATA_FORMAT_PREFIX,UpperCaseSort)) { return_status = search_string( block->Chain->File->GeneralBlock, Key, symbol ); } } return( return_status ); } /* search_general */ /*===data_structure END=================================================---*/ /*===raster_conversion BEGIN=================================================*/ /* temporarily redefined, should everywhere be replaced by raster.h functions */ int edf_raster_normalization ( void * dest, const void * src, const long data_dim[], long raster_configuration, size_t item ) { return( raster_normalization ( dest, src, data_dim, raster_configuration, item, NULL ) ); } long edf_raster_multiplication ( long a, long x ) { return( raster_multiplication( a, x ) ); } // edf_raster_multiplication long edf_raster_inversion ( long x ) { return( raster_inversion ( x ) ); } // edf_raster_inversion long edf_raster_order2number ( const long order[] ) { return( raster_order2number( order ) ); } // edf_raster_order2number /*===raster_conversion END===================================================*/ /*===block_access BEGIN====================================================*/ /*--------------------------------------------------------------------------- NAME DBClass2String --- converts db_class to a string SYNOPSIS DBClass dbclass; const char * DBClass2String( int db_class ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the variable with its enumerated type has been replaced by "int". RETURN VALUE Pointer to a constant result string. AUTHOR 18-Mar-2000 PB Specification -------------------------------------------------------------------------*/ const char * DBClass2String( int db_class ) { if ((db_class<0)||(db_class>=EndDBClass)) db_class = InValidDBClass; return( DBClassStrings[db_class] ); } /* DBClass2String */ /*--------------------------------------------------------------------------- NAME String2DBClass --- converts a string to a data block class SYNOPSIS (DBClass) int String2DBClass( const char * string ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the return value with its enumerated type has been replaced by "int". RETURN VALUE 0 : error, e.g. cannot convert >0 : valid data block class value AUTHOR 18-Mar-2000 PB Specification -------------------------------------------------------------------------*/ int String2DBClass( const char * string ) { int NE=True; long i = 0; while ( (NE && DBClassStrings[i]) ) NE = compare_keys( string, DBClassStrings[i++], UpperCaseSort ); i = MAX(0,i-1); if (NE) return( InValidDBClass ); else return( i ); } /* String2DBClass */ /*--------------------------------------------------------------------------- NAME DBInstance2String --- converts db_instance to a string SYNOPSIS DBInstance db_instance; const char * DBInstance2String( int db_instance ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the variable with its enumerated type has been replaced by "int". RETURN VALUE Pointer to a constant result string. AUTHOR 18-Mar-2000 PB Specification -------------------------------------------------------------------------*/ const char * DBInstance2String( int db_instance ) { if ((db_instance<0)||(db_instance>=EndDBInstance)) db_instance = InValidDBInstance; return( DBInstanceStrings[db_instance] ); } /* DBInstance2String */ /*--------------------------------------------------------------------------- NAME String2DBInstance --- converts a string to a data block instance SYNOPSIS (DBInstance) int String2DBInstance( const char * string ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the return value with its enumerated type has been replaced by "int". RETURN VALUE 0 : error, e.g. cannot convert >0 : valid data block instance value AUTHOR 18-Mar-2000 PB Specification -------------------------------------------------------------------------*/ int String2DBInstance( const char * string ) { int NE=True; long i = 0; while ( (NE && DBInstanceStrings[i]) ) NE = compare_keys( string, DBInstanceStrings[i++], UpperCaseSort ); i = MAX(0,i-1); if (NE) return( InValidDBInstance ); else return( i ); } /* String2DBInstance */ /*--------------------------------------------------------------------------- header_id Example: HeaderID = EH:000001:000000:000000 ; ---------------------------------------------------------------------------*/ char * header_id( DBlock * block ) { char KeyVal[MaxKeyLen+1]; char *ps=KeyVal, *pd=IDBuffer; memset(IDBuffer,'0',MaxKeyLen+1); (void) sprintf(KeyVal,"EH:%6lu:%6u:%6u",block->SequenceNumber,0,0); while (*ps) { if (*ps!=' ') *pd=*ps; ps++; pd++; } *pd = *ps; return(IDBuffer); } /* header_id */ /*--------------------------------------------------------------------------- header_id_number Returns the first header id number Example: HeaderID = EH:000009:000000:000000 ; -> 9 ---------------------------------------------------------------------------*/ long header_id_number( const char * header_id ) { const char *ps; long number; ps=strchr(header_id, (int) ':'); sscanf(++ps,"%ld",&number); return( number ); } /* header_id_number */ /*--------------------------------------------------------------------------- NAME block_id SYNOPSIS char * block_id( DBlock * block ) DESCRIPTION If block exists, its block ID string is returned, otherwise NULL. The block ID is written into IDBuffer and a pointer to IDBuffer is returned. ---------------------------------------------------------------------------*/ char * block_id( DBlock * block ) { if ( block ) (void) sprintf(IDBuffer,"%s.%s", block->BlockKey, block->Chain->ChainKey ); else return ( (char *) NULL ); return(IDBuffer); } /* block_id */ /*--------------------------------------------------------------------------- NAME default_chain_key SYNOPSIS char *default_chain_key ( char buffer[], long memnum ); DESCRIPTION The default chainkey for a given memory number (memnum) is written into the buffer. The generated chainkey has the format: Image..memnum, e.g. "Image.Error.3" Positive memnum means primary data, negative memnum for variance data. Zero memnum is not allowed. In case of abs(memnum)==1 the memnum number is suppressed, e.g. "Image.Psd". Zero memnum is the general chain. RETURN VALUE Pointer to buffer in case of success, otherwise NULL. ---------------------------------------------------------------------------*/ char *default_chain_key ( char buffer[], long memnum ) { int db_class = DBImage; int db_instance; db_instance = InValidDBInstance; if (memnum<0) db_instance = DBError; else if (memnum>0) db_instance = DBPrimaryData; memnum = abs(memnum); if (memnum==0) strncpy(buffer,GENERAL_CHAIN_KEY,MaxKeyLen+1); else if (memnum!=1) sprintf(buffer,"%s.%s.%lu", DBClass2String( db_class ), DBInstance2String( db_instance ), memnum ); else sprintf(buffer,"%s.%s", DBClass2String( db_class ),DBInstance2String( db_instance )); return ( buffer ); } /* default_chain_key */ /*--------------------------------------------------------------------------- NAME print_file_warning SYNOPSIS void print_file_warning ( FILE * out, DFile * file, unsigned long position, const char * warning ); DESCRIPTION Prints a warning message to out. ---------------------------------------------------------------------------*/ void print_file_warning ( FILE * out, DFile * file, unsigned long position, const char * warning ) { fprintf(out,"\n %s FILE WARNING\n",DATA_FORMAT_NAME); if (warning) fprintf(out," %s\n",warning ); fprintf(out," File name : %s\n", file->Name); // fprintf(out," File position: %lu (0x%lx)\n", position, position ); fprintf(out," File position: %lu (%#lx)\n", position, position ); if ( block_id(file->LastBlockInFile)) fprintf(out," Last block ID: %s\n",block_id(file->LastBlockInFile)); else fprintf(out," Last block ID: (no block read)\n"); fprintf(out,"\n"); } /* print_file_warning */ /*--------------------------------------------------------------------------- NAME print_file_error SYNOPSIS void print_file_error ( FILE * out, DFile * file, unsigned long position, const char * error ); DESCRIPTION Prints a error message to out. ---------------------------------------------------------------------------*/ void print_file_error ( FILE * out, DFile * file, unsigned long position, const char * error ) { fprintf(out,"\n %s FILE ERROR\n",DATA_FORMAT_NAME); if (error) fprintf(out," %s\n",error ); fprintf(out," File name : %s\n", file->Name); // fprintf(out," File position: %lu (0x%lx)\n", position, position ); fprintf(out," File position: %lu (%#lx)\n", position, position ); if ( block_id(file->LastBlockInFile)) fprintf(out," Last block ID: %s\n",block_id(file->LastBlockInFile)); else fprintf(out," Last block ID: (no block read)\n"); fprintf(out,"\n"); } /* print_file_error */ /*--------------------------------------------------------------------------- NAME split_block_id --- split block_id into BlockKey and ChainKey SYNOPSIS int split_block_id( char buffer[], const char * block_id, char ** pBlockKey, char ** pChainKey ); DESCRIPTION ´block_id´ is copied into ´buffer´. ´buffer´ is split into ´BlockKey´ and ´ChainKey´ by replacing the first '.' in ´buffer´ with '\0'. The pointer to the leading substring is returned in ´BlockKey´, the pointer to the trailing substring is returned in ´ChainKey´. The minimum length of ´buffer´ is strlen(block_id)+1, the maximum length is MaxValLen+1. RETURN VALUE success: 0 ---------------------------------------------------------------------------*/ int split_block_id( char buffer[], int buflen, const char * block_id, char ** pBlockKey, char ** pChainKey ) { int dot = (int) '.'; char *pc; buflen = MIN((int) strlen(block_id),buflen); strncpy(buffer, block_id, buflen); buffer[buflen] = '\0'; pc = strchr(buffer, dot); if (pc) { *pc='\0';pc++;*pChainKey=pc; } else { *pChainKey=&buffer[buflen]; } *pBlockKey = buffer; return(0); } /* split_block_id */ /*--------------------------------------------------------------------------- NAME is_general_block ( block ) DESCRIPTION Returns ´1´ if block is the general block. In all other cases ´0´. ---------------------------------------------------------------------------*/ int is_general_block ( DBlock *block ) { if (block==block->Chain->File->GeneralBlock) return(1); else return(0); } /* is_general_block */ /*--------------------------------------------------------------------------- block_boundary ( block ) Returns the block_boundary of the file ---------------------------------------------------------------------------*/ unsigned long block_boundary ( DBlock * block ) { return ( block->Chain->File->BlockBoundary ); } /* block_boundary */ /*--------------------------------------------------------------------------- set_block_boundary ( block, bboundary ) Sets the block_boundary of the file ---------------------------------------------------------------------------*/ int set_block_boundary( DBlock * block, unsigned long bboundary ) { block->Chain->File->BlockBoundary = bboundary; return(0); } /* set_block_boundary */ /*--------------------------------------------------------------------------- NAME set_data_format_version ( block, version ) SYNOPSIS int set_data_format_version ( DBlock * block, DFVersion version ); DESCRIPTION Sets the datat_format_version of the file RETURN VALUE success: 0 error: -1 ---------------------------------------------------------------------------*/ int set_data_format_version ( DBlock * block, DFVersion version ) { if (!(block->Chain->File->GeneralBlock->BinaryPos)) block->Chain->File->Version = version; else return(-1); /* general block exist already on disk */ return(0); } /* set_data_format_version */ /*--------------------------------------------------------------------------- NAME set_no_general_block ( block ) SYNOPSIS int set_no_general_block ( DBlock * block ); DESCRIPTION Sets the file flag NoGeneralHeader to TRUE. RETURN VALUE success: 0 error: -1 ---------------------------------------------------------------------------*/ int set_no_general_block ( DBlock * block ) { block->Chain->File->Flags.NoGeneralHeader = True; return(0); } /* set_no_general_block */ /*--------------------------------------------------------------------------- int pad_spaces ( channel, padwidth, padlen ) (success:0, error:-1) Writes exactly padlen bytes to channel. If padwith is positive, two bytes "\r\n" are written after every padwidth number of spaces. ---------------------------------------------------------------------------*/ int pad_spaces ( FILE * channel, int padwidth, int padlen ) { int i_pad, i_col; /* pad with white spaces, next line after padwidth characters */ i_pad=0; i_col=0; if (padwidth>=0) while (i_pad0 BinaryLen is calculated from RawLen b) Updates the symbol list with the required keywords and values, for: the general block and for the normal data blocks. c) Recalculates the header length and the number of bytes that must be added to reach a multiple of block_boundary. The values are updated in block->TextLen and block->PadLen. If ( block->Flags.DiskBlockFixed ) BinaryLen and TextLen are kept constant. If this is not possible, an error is returned. If RawLen is >0 BinaryLen is calculated from RawLen RETURN VALUE Returns 0 in case of success. HISTORY 2001-01-01 PB calculation of block->BinaryLen for DiskBlockFixed is now done before keyword is written to header. 2010-12-16 PB if RawLen is >0 BinaryLen is calculated from RawLen ---------------------------------------------------------------------------*/ int sync_data_block ( DBlock * block ) { unsigned long nh_len, mh_len, dif_len=0; char keybuf[MaxKeyLen+1]; char valbuf[MaxValLen+1]; DChain * chain; DFile * file; SElement * symbol; unsigned long text_len = block->TextLen; unsigned long binary_len = block->BinaryLen; chain = block->Chain; file = chain->File; if (block == (DBlock *) NULL) return(-1); /* Round up binary length to the next full multiple of block_boundary */ if (block->RawLen) { block->BinaryLen = CEILMOD ( (unsigned long) block->RawLen, block_boundary(block)); } else { block->BinaryLen = CEILMOD ( (unsigned long) block->DataLen, block_boundary(block)); } if ( block->Flags.DiskBlockFixed ) { /* keep lengths fixed */ block->BinaryLen = MAX(block->BinaryLen,binary_len); if ( (block->BinaryLen) != binary_len ) return(-1); } /* write keywords */ if ( is_general_block ( block ) ) { /* GeneralBlock */ if (write_headersize) { /* write temporary value */ if (insert_symbol_root(block,HEADER_SIZE_KEY, UNDETERMINED,&symbol)) return(-1); } /* if block boundary defined in symbol list, use this value */ if (search_symbol( block, BLOCK_BOUNDARY_KEY, &symbol ) ) { if (insert_symbol_root(block, BLOCK_BOUNDARY_KEY, u_long2s( valbuf, block_boundary(block) ),&symbol)) return(-1); } else { if ( set_block_boundary( block, s2u_long( symbol->Value ) ) ) { fprintf(stderr,"ERROR: Cannot change block boundary\n"); return(-1); } } if (insert_symbol_root(block, DATA_BLOCKS_KEY, DATA_BLOCKS_DEFAULT, &symbol)) return(-1); if (insert_symbol_root(block, DATA_FORMAT_VERSION_KEY, DATA_FORMAT_VERSION, &symbol)) return(-1); } else { /* normal DataBlock */ if (write_headersize) { /* write temporary value */ if (insert_symbol_root(block,HEADER_SIZE_KEY, UNDETERMINED,&symbol)) return(-1); } if (insert_symbol_root(block,BINARY_SIZE_KEY, u_long2s( valbuf, block->BinaryLen),&symbol)) return(-1); if (insert_symbol_root(block, BLOCK_ID_KEY, block_id(block),&symbol)) return(-1); /* +++ compatibility to old data format, ´Image = NN´ */ if (insert_string( block, suppress_suffix(keybuf, chain->ChainKey, V1_SUPPRESS, False), block->BlockKey, &symbol)) return(-1); /* --- end old data format */ } /* END normal DataBlock */ /* +++ compatibility to old data format */ if ( !(block->Flags.DiskBlockFixed) ) block->SequenceNumber = file->NextSequenceNumber; if (insert_string(block, V1_HEADER_ID_KEY, header_id(block),&symbol)) return(-1); if (insert_string(block, V1_SIZE_KEY, u_long2s( valbuf, block->BinaryLen),&symbol)) return(-1); /* --- end old data format */ /* Round up header length to the next full multiple of block_boundary */ nh_len = netto_header_length( block ); mh_len = MAX( nh_len, minimum_headersize_out ); block->TextLen = CEILMOD ( mh_len, block_boundary(block)); if ( block->Flags.DiskBlockFixed ) { /* keep lengths fixed */ block->TextLen = MAX(block->TextLen,text_len); if ( (block->TextLen) != text_len ) return(-1); } if (write_headersize) { /* correct temporary header size value */ if (search_symbol( block, HEADER_SIZE_KEY, &symbol ) ) return(-1); dif_len = strlen(symbol->Value)-strlen(u_long2s(valbuf,block->TextLen)); if ( insert_symbol( block, HEADER_SIZE_KEY, valbuf, &symbol ) ) return(-1); } block->PadLen = block->TextLen - nh_len + dif_len; return(0); } /* sync_data_block */ /*--------------------------------------------------------------------------- NAME get_block_pos --- get start position of ´block´ in file SYNOPSIS int get_block_pos( DBlock * block, unsigned long *ptext_pos ); DESCRIPTION Calculates the start position of the text header section of ´block´ relative to the start of the file. RETURN VALUE success:0, error:-1 ---------------------------------------------------------------------------*/ int get_block_pos( DBlock * block, unsigned long *ptext_pos ) { DBlock * LastBlockInFile = block->Chain->File->LastBlockInFile; if (block->Flags.DiskBlockFixed) *ptext_pos = block->TextPos; else /* goto end of file */ if (LastBlockInFile) { *ptext_pos = LastBlockInFile->TextPos + LastBlockInFile->TextLen + LastBlockInFile->BinaryLen; } else *ptext_pos = 0ul; return(0); } /* get_block_pos */ /*--------------------------------------------------------------------------- NAME flush_data_block SYNOPSIS int flush_data_block ( block ); DESCRIPTION Writes header section and binary section, ordered, into the main EDF data file. Before calling this routine the data block must be synchronized with sync_data_block. The header section is written according to the currently defined keyorder_KeyOrderTable (defined with edf_keyorder_set_table. Nothing is written if the flag block->Flags.BadBlock is set. The flags block->Flags.HeaderChanged and DataChanged are checked. The header is only written to disk if HeaderChanged or DataChanged is set. The header is never written to disk if InternalHeader is set. The header symbol list is never released when InternalHeader is set. The data is only written to disk if DataChanged is set. The data is never written to disk if InternalData is set. The data is never released if InternalData is set. Data is only written to disk if the header could be written. When InternalHeader is set, data is never written to disk. The following parameters are updated: TextPos, BinaryPos, KeyPos, ValPos, BinaryFilePos, BinaryFileLen 2010-12-16 PB if RawLen is >0 Raw is written instead of Data ---------------------------------------------------------------------------*/ int flush_data_block ( DBlock *block ) { const unsigned long h_begin =(unsigned long) strlen(header_begin); const unsigned long s_sepa =(unsigned long) strlen(symbol_separator); const unsigned long s_term =(unsigned long) strlen(symbol_terminator); unsigned long cur_pos; DChain * chain; DFile * file; FILE * channel; SElement ** table, ** psymbol; chain = block->Chain; file = chain->File; channel = file->Channel; if (block) /* the data is only written if the header can be written */ if ( ((block->Flags.HeaderChanged)||(block->Flags.DataChanged)) && (!block->Flags.InternalHeader) ) { /* get block position */ if (get_block_pos( block, &cur_pos )) { perror("flush_data_block->get_block_pos");return(-1); } block->TextPos = cur_pos; /* search block position */ if ( fseek( channel, cur_pos, SEEK_SET) ) { perror("flush_data_block->fseek"); return(-1); } /* write header section */ if ( fputs ( header_begin , channel ) < 0 ) { perror("flush_data_block->header_begin"); return(-1); } cur_pos += h_begin; /* get ordered table of symbols */ table = keyorder_ordersymbols ( block ); if (!table) { perror("flush_data_block ordersymbols"); return(-1); } psymbol = table; while (*psymbol!=(SElement*) NULL) { (*psymbol)->KeyPos = cur_pos; if ( fputs ( (*psymbol)->Key , channel ) < 0 ) { perror("flush_data_block->Key"); free(table); return(-1); } if ( fputs ( symbol_separator, channel ) < 0 ) { perror("flush_data_block->symbol_separator"); free(table);return(-1);} cur_pos += s_sepa + (unsigned long) (*psymbol)->KeyLen; (*psymbol)->ValPos = cur_pos; if ( fputs ( (*psymbol)->Value, channel ) < 0 ) { perror("flush_data_block->Value"); free(table); return(-1); } if ( fputs ( symbol_terminator, channel) < 0 ) { perror("flush_data_block->symbol_terminator");free(table);return(-1);} cur_pos += s_term + (unsigned long) (*psymbol)->ValLen; psymbol++; } /* free table */ free(table); /* pad header block with white spaces */ if (pad_spaces ( channel, PAD_WIDTH, block->PadLen )) { perror("flush_data_block->pad_spaces"); return(-1); } if ( fputs ( header_end , channel) < 0 ) { perror("flush_data_block->header_end"); return(-1); } block->Flags.HeaderChanged = False; if ( (block->Flags.DataChanged) && (!block->Flags.InternalData) ) { /* Calculate BinaryPos */ block->BinaryPos = block->TextPos + (unsigned long) block->TextLen; /* stored in main EDF file, no BinaryFileName */ if (block->BinaryFileName) free (block->BinaryFileName); block->BinaryFilePos = block->BinaryPos; block->BinaryFileLen = block->BinaryLen; /* write binary data section and fill rest with spaces */ if (block->RawLen) { if ( fwrite(block->Raw,1,block->RawLen,channel) < block->RawLen ) { perror("flush_data_block->fwrite"); return(-1); } if ( pad_spaces( channel,-1, block->BinaryLen-(unsigned long)block->RawLen) ) { perror("flush_data_block->pad_spaces"); return(-1); } } else { if ( fwrite(block->Data,1,block->DataLen,channel) < block->DataLen ) { perror("flush_data_block->fwrite"); return(-1); } if ( pad_spaces( channel,-1, block->BinaryLen-(unsigned long)block->DataLen) ) { perror("flush_data_block->pad_spaces"); return(-1); } } if ( fflush( channel ) ) { perror("flush_data_block->fflush"); return(-1); } block->Flags.DataChanged = False; } /* data block is written, increment block number for next time */ if (block->SequenceNumber == file->NextSequenceNumber) { file->LastBlockInFile=block; file->NextSequenceNumber++; } /* update data block flags */ block->Flags.DiskBlockUsed = True; block->Flags.DiskBlockFixed = True; } return(0); } /* flush_data_block */ /*--------------------------------------------------------------------------- NAME update_symbol --- Replaces the value of ´Key´ in ´block´ with ´Value´ SYNOPSIS int update_symbol( DBlock * block, const char * Key, const char * Value, SElement ** symbol ) DESCRIPTION The key value of the symbol ´Key´ is replaced with ´Value´. The original value length is not changed. If ´Value´ is shorter than the original key value, the remaining bytes are padded with spaces. If ´Value´ is longer than the original key value (symbol->ValLen), the routine stops with an error. RETURN VALUE success: 0, *symbol != NULL error: -1, *symbol == NULL ---------------------------------------------------------------------------*/ int update_symbol( DBlock * block, const char * Key, const char * Value, SElement ** symbol ) { *symbol = (SElement *) NULL; if ( block == (DBlock *) NULL) goto update_symbol_error; if ( Value == (const char *) NULL ) goto update_symbol_error; if (search_symbol( block, Key, symbol )) { *symbol = (SElement *) NULL; goto update_symbol_error; } /* replace key value with value */ strnpad((*symbol)->Value, Value, (size_t) (*symbol)->ValLen, ' '); block->KeyOrderNextSymbol = block->SymbolList; block->KeyOrderNo = 0; /* success */ return(0); update_symbol_error: /* error */ return(-1); } /* update_symbol */ /*--------------------------------------------------------------------------- NAME rewrite_symbol - rewrite the value of a symbol in a header section SYNOPSIS int rewrite_symbol ( const SElement * symbol ); DESCRIPTION If the key value was already written to the file the value in the file is replaced. If symbol->KeyPos is zero, it is assumed that the key value was not already written and no output to the file is done. The file pointer is either repositioned at the position of the key value or remains at the original position. Before continuing writing data to the end of the file the file pointer must be repositioned with fseek(channel, 0L, SEEK_END). RETURN VALUE In case of succes the return value is 0 otherwise -1. ---------------------------------------------------------------------------*/ int rewrite_symbol ( const SElement * symbol ) { FILE * channel = symbol->Block->Chain->File->Channel; long pos; if (!symbol) goto rewrite_symbol_error; /* rewrite value in the file, if it was already written */ pos = (long) symbol->ValPos; if ( pos > 0L ) { /* seek position of Value */ if ( fseek( channel, pos, SEEK_SET) ) { perror("rewrite_symbol->fseek"); goto rewrite_symbol_error; } /* replace old value */ if ( fputs(symbol->Value, channel) < 0 ) { perror("rewrite_symbol->fputs"); goto rewrite_symbol_error; } } /* success */ return(0); rewrite_symbol_error: /* error */ return(-1); } /* rewrite_symbol */ /*--------------------------------------------------------------------------- NAME update_general - updates the general header after writing a data block SYNOPSIS int update_general ( DBlock * block ); DESCRIPTION Updates the following file informations in the general block: Number of data blocks in the file (the general block is not counted) DataBlocks = NextSequenceNumber - FirstHeader; If GeneralBlock->Flags.InternalHeader is set, the value is only updated in memory but not in the file. If the file is not a temporary file, the file pointer is repositioned at the end of the file. RETURN VALUE In case of succes the return value is 0 otherwise -1. ---------------------------------------------------------------------------*/ int update_general ( DBlock * block ) { DBlock * general = block->Chain->File->GeneralBlock; DFile * file = block->Chain->File; SElement * symbol; char KeyVal[MaxKeyLen+1]; FILE * channel = block->Chain->File->Channel; unsigned long data_blocks; if (!block) goto update_general_error; /* calculate number of data blocks without counting general block */ data_blocks = block->Chain->File->NextSequenceNumber-FirstHeader-1; if (file->Flags.NoGeneralHeader) data_blocks-= 1; /* subtract general block */ /* rewrite ´DataBlocks´ */ if (!(u_long2s(KeyVal,data_blocks))) goto update_general_error; update_symbol( general, DATA_BLOCKS_KEY, KeyVal, &symbol ); if (!(general->Flags.InternalHeader)) if ( symbol ) if ( rewrite_symbol ( symbol ) ) goto update_general_error; /* seek end of file */ if (!(file->Flags.TemporaryFile)) if ( fseek( channel, 0L, SEEK_END) ) { perror("update_general->fseek"); goto update_general_error; } block->KeyOrderNextSymbol = block->SymbolList; block->KeyOrderNo = 0; /* success */ return(0); update_general_error: /* error */ return(-1); } /* update_general */ /*--------------------------------------------------------------------------- NAME put_data_block (success:0, error:-1) SYNOPSIS int put_data_block( DBlock * block ); DESCRIPTION Writes header and binary data to the stream if they were changed (HeaderChanged, DataChanged). The format specific symbols are written into the header. ´block´ is only written physically to the file if the flag ´file->Flags.NoGeneralHeader´ is False. RETURN VALUE success: 0 otherwise: -1 ---------------------------------------------------------------------------*/ int put_data_block( DBlock * block ) { if ( block ) if ( !block->Flags.BadBlock ) if ( (block->Flags.HeaderChanged)||(block->Flags.DataChanged) ) { /* Don´t write general header if NoGeneralHeader is set */ if ( !( block->Chain->File->Flags.NoGeneralHeader ) || !( is_general_block ( block ) ) ) { /* synchronize header, binary data and data file format */ if (sync_data_block ( block )) { block->Flags.BadBlock = True; goto put_data_block_error; } /* flush data block to file */ if (flush_data_block( block )) { block->Flags.BadBlock = True; goto put_data_block_error; } /* write block number into general block */ if ( !block->Chain->File->Flags.NoGeneralHeader ) if (update_general ( block )) { block->Flags.BadBlock = True; goto put_data_block_error; } } } /* success */ return(0); put_data_block_error: /* error */ return(-1); } /* put_data_block */ /*--------------------------------------------------------------------------- NAME check_start SYNOPSIS int check_start( FILE * channel ); DESCRIPTION Checks whether the first characters in the file contain either: '\r' '\n' 'StartHeader´, '\n' 'StartHeader´ or 'StartHeader´. The file pointer is positioned at the first character after ´StartHeader´. If the patterns do not match or if EOF was read the return value is -1. The file cannot be processed further. The correct pattern should be: '\n' 'StartHeader´ immediately followed by '\r' '\n'. RETURN VALUE Success, this is a header start: 0 This is not a header start : 1 End of file : -1 Any other error, e.g. char(0) : -2 ---------------------------------------------------------------------------*/ int check_start( FILE * channel ) { char c; int ic; ic = fgetc( channel ); c = (char) ic; if (ic==EOF) return(-1); else if (!ic) return(-2); if (c=='\r') { ic = fgetc( channel ); c = (char) ic; } if (ic==EOF) return(-1); else if (!ic) return(-2); if (c=='\n') { ic = fgetc( channel ); c = (char) ic; } if (ic==EOF) return(-1); else if (!ic) return(-2); if (c!=StartHeader) return (1); return ( 0 ); } /* check_start */ /*--------------------------------------------------------------------------- NAME check_end SYNOPSIS int check_end( FILE * channel ); DESCRIPTION Checks, whether the file pointer is positioned at the end of a header section. If EOF or '\0' is read the routine stops with an error (return value is -1). The file cannot be processed further. If the first read character is not the ´EndHeader´ character the return value is 1. If one of the following characters do not match the end header marker, this character is returned to channel. The routine returns 1 if one of the following patterns were found: { 'EndHeader´, '\r', '\n } or { 'EndHeader´, '\n' } At least 1 character is read from channel. If it is not equal to EndHeader the routine stops with the return value 1. By this way the routine can be used to scan a header section for a header end marker. RETURN VALUE In case of success end of header: 0, file pointer positioned after ´\n´ not end of header: 1, wrong character is returned to channel error: negative number EOF or '\0' : -1, end of file or char NULL fatal error: -2 HISTORY 01-Mar-1997 PB error if ungetc corrected ------------------------------------------------------------------------------*/ int check_end( FILE * channel ) { char c; int ic; ic = fgetc( channel ); c = (char) ic; if ((ic==EOF)||(!ic)) return(-1); if (c!=EndHeader) return(1); else {ic=fgetc(channel);c=(char)ic; if ((ic==EOF)||(!ic)) return(-1);} if (c=='\r') {ic=fgetc(channel);c=(char)ic; if ((ic==EOF)||(!ic)) return(-1);} if (c!='\n') {if ( ic != ungetc ( ic , channel) ) return(-2); return(1);} return ( 0 ); } /* check_end */ /*--------------------------------------------------------------------------- NAME search_end - search the end of a header section SYNOPSIS int search_end( FILE * channel, unsigned long start, unsigned long block_boundary ); DESCRIPTION If block_boundary is larger or equal to the the length of the header end marker the full header end marker "\r\n}\n" is searched relative to ´start´ at the positions (n=1, 2, 3, ...) start + n * blockboundary - strlen(header_end) If the block boundary is smaller than strlen(header_end) the file is checked byte for byte with check_end starting at ´start´ for the EndHeader character. If no header end marker is found -1 is returned. If the header end marker was found the file pointer is positioned immediately after the marker (immediately after the '\n'). RETURN VALUE success: 0 no success a negative number EOF or ´\0´ -1 fatal error: -2 ---------------------------------------------------------------------------*/ int search_end( FILE * channel, unsigned long start, unsigned long block_boundary ) { unsigned long he_len = strlen(header_end); int ic, res; char *pb, buffer[MaxKeyLen+1]; long pos; unsigned long i; /* start position */ pos = (long) start; buffer[0] = '\0'; if ( block_boundary >= he_len ) { while ( strcmp(buffer, header_end ) ) { /* seek position */ pos += (long) block_boundary ; if ( fseek( channel, pos - he_len, SEEK_SET) ) { perror("search_end->fseek"); return(-2); } pb = buffer; for (i=0;ifseek"); return(-2); } res = 1; while ( res ) { res = check_end( channel ); if ( res < -1 ) return(-2); /* fatal error */ else if ( res < 0 ) return(-1); /* end of file or char NULL */ } } return ( 0 ); /* header end found */ } /* search_end */ /*--------------------------------------------------------------------------- NAME nextline SYNOPSIS int nextline( FILE * channel ) DESCRIPTION Skip all characters until end of line or end of header. In case of success (not eof or '\0') the file pointer is positioned at first character after '\n'. RETURN VALUE In case of success: 0 end of header: 1 in case of an error: a negative number ---------------------------------------------------------------------------*/ int nextline( FILE * channel ) { char c; int ic; ic = (int) ' '; c = (char) ic; /* Skip everything until EOF or line end */ while ( (ic!=EOF) && (ic) && (c!=EndHeader) && (c!='\r') && (c!='\n') ) { ic = fgetc( channel ); c = (char) ic; } /* while */ if ((ic==EOF) || (!ic)) return (-1); /* Read '\n' character, if line was terminated by '\r' */ if (c == '\r') { ic = fgetc( channel ); c = (char) ic; } /* unget last character if it is EndHeader and check end */ if (c == EndHeader) { ungetc( (int) c, channel ); if ( check_end( channel ) ) { long tmp; tmp = ftell(channel); fprintf(stderr,"\nERROR: position %ld, end marker ´%c´ not followed by eol\n", tmp, c); return(-1); } else return(1); } return(0); } /* nextline */ /*--------------------------------------------------------------------------- NAME skipcomment SYNOPSIS int skipcomment( FILE * channel ) DESCRIPTION Skip all characters until end of line, ignoring end of header marker. In case of success (not eof or '\0') the file pointer is positioned at first character after '\n'. This routine is only good for skipping comment lines which start with ´Comment´ character. RETURN VALUE In case of success: 0 in case of an error: a negative number ---------------------------------------------------------------------------*/ int skipcomment( FILE * channel ) { char c; int ic; ic = (int) ' '; c = (char) ic; /* Skip everything until EOF or line end */ while ( (ic!=EOF) && (ic) && (c!='\r') && (c!='\n') ) { ic = fgetc( channel ); c = (char) ic; } /* while */ if ((ic==EOF) || (!ic)) return (-1); /* Read '\n' character, if line was terminated by '\r' */ if (c == '\r') { ic = fgetc( channel ); c = (char) ic; } return(0); } /* skipcomment */ /*--------------------------------------------------------------------------- NAME get_key SYNOPSIS int get_key( char buffer[], unsigned long buflen, FILE * channel, unsigned long * pkey_pos, unsigned long *pkey_len); DESCRIPTION Reads ´key´ starting at the first non-white character and positions the file pointer after ´Separator´. {´white-space´} (´EndHeader´ | ({´key´} [´white-space´] (´Separator´ | '\r' | '\n') ) ) Starts at the first non-white character after the current position. ´key´ is returned in buffer with white spaces replaced by space. A white-space character immediately before ´Separator´ is not returned in ´key´. If ´Separator´ was read the read pointer is positioned immediately after ´Separator´. If the first non-white-character is the ´EndHeader´ character the routine stops and returns this character to ´channel´. If the Separator character could not be read before {'\r', '\n'} or ´\n´, EOR or '\0' the routine stops with an error and returns -1. ´key´ is returned as a string with not more than MIN(MaxKeyLen,´buflen´-1) characters (including white spaces). The string is terminated with ´\0´ (buflen). buflen is the size of ´buffer´. RETURN VALUES In case of success: 0 end of header: 1 in case of an error (´Separator´ not read, EOF or '\0'): a negative number The key is returned in buffer[]. *pkey_pos is the position of the first character of ´key´ in the file. *pkey_len is the length of key, not including '\0'. HISTORY 21-Jan-1998 Peter Boesecke ---------------------------------------------------------------------------*/ int get_key( char buffer[], unsigned long buflen, FILE * channel, unsigned long * pkey_pos, unsigned long *pkey_len) { unsigned long i; char *pb; char prev_c; int ic; /* determine minimum of MaxKeyLen+1 and buflen */ if ((MaxKeyLen+1) < buflen) buflen = MaxKeyLen+1; ic = (int) ' '; do { pb = buffer; // start again *pb = (char) ic; /* skip everything before the first non-white character, skip empty lines, skip comments */ while ((is_white(*pb)||(*pb==Terminator)) && (*pb!=EndHeader)) { prev_c = *pb; ic = fgetc( channel ); *pb = (char) ic; if ( (ic==EOF) || (!(ic)) ) return(-1); /* Skip comment line */ if ( (prev_c=='\n') && (*pb==Comment) ) { if ( skipcomment( channel ) < 0 ) return(-1); *pb = '\n'; } } /* while */ /* unget last character if it is EndHeader and check end */ if (*pb == EndHeader) { ungetc( (int) *pb, channel ); if ( check_end( channel ) ) { long tmp; tmp = ftell(channel); fprintf(stderr,"\nERROR: position %ld, end marker ´%c´ not followed by eol\n", tmp, *pb); return(-1); } else return(1); } *pkey_pos = (unsigned long) ftell( channel ) - 1; /* Read key until Separator or Terminator or until buffer full */ i = 0U; while ( (i0) && (is_white(buffer[i-1])) ) { i--; pb--; } /* Replace terminating character with end of string */ *pb = '\0'; *pkey_len = (unsigned long) i; return(0); } /* get_key */ /*--------------------------------------------------------------------------- NAME get_val SYNOPSIS int get_val( char buffer[], unsigned long buflen, FILE * channel, unsigned long * pval_pos, unsigned long *pval_len); DESCRIPTION Reads ´value´ starting at the first non-white character and positions the file read pointer after ´Terminator´. The routine ´get_key´ should be called beforehand. The first buflen-1 read characters are returned in buffer, all following until ´Terminator´ are skipped. {´white-space´} ( {´value´} [´white-space´] (´Terminator´ | '\r' | '\n') ) Starts reading at the first non-white character after the current position, which is normally after ´Separator´. ´value´ is returned in buffer. A white-space character immediately before ´Terminator´ is not returned in ´value´. If ´Terminator´ was read the read pointer is positioned at the first character after ´Terminator´. The ´EndHeader´ and '\r' or '\n' characters are passed without change. The only terminating conditions are: ´Terminator´ read (success), '\0' read (error) or EOF reached (error). The routine returns -1 on error and 0 on success. RETURN VALUES The routine returns -1 on error (EOF, '\0', Terminator not found). The routine returns 0 on success. The value is returned in buffer[]. *pval_pos is the position of the first character of ´value´ in the file. *pval_len is the length of value, not including '\0'. HISTORY 20-Jan-1998 Peter Boesecke ---------------------------------------------------------------------------*/ int get_val( char buffer[], unsigned long buflen, FILE * channel, unsigned long * pval_pos, unsigned long *pval_len) { unsigned long i; char *pb = buffer; int ic; /* skip everything before the first non-white character */ i = 0U; ic = (int) ' '; *pb = (char) ic; while ( is_white(*pb) && (ic!=EOF) && (ic) ) { ic = fgetc( channel ); *pb = (char) ic; i++; } /* while */ *pval_pos = (unsigned long) ftell ( channel ) - 1; /* Read key until Terminator or until buffer full */ i = 0U; while ( (i0) && (is_white(buffer[i-1])) ) { i--; pb--; } /* Replace terminating character with end of string */ *pb = '\0'; *pval_len = (unsigned long) i; return(0); } /* get_val */ /*--------------------------------------------------------------------------- NAME get_symbol_list --- read all symbols, starting at current file position SYNOPSIS int get_symbol_list( DBlock * block, int level ); DESCRIPTION Starting at the current file position, all key/value pairs are read and inserted into the symbol list of ´block´. According to the ´level´ argument only the data format keys (level=0) or all keys (level=1) are read. level = 0 Only keys starting with DATA_FORMAT_PREFIX are read. The read stops at the first key not starting with DATA_FORMAT_PREFIX or after ´header_end´. To read all keys the file pointer has to be repositioned after the ´header_start´ marker and then read with level=1. In case of success, the file pointer is positioned at the beginning of the first key that does not start with DATA_FORMAT_PREFIX or it is pointing to the ´EndHeader´ character. level = 1 All keys are read. The read stops at the end of the header. In case of success, the file pointer is pointing to the ´EndHeader´ character. RETURN VALUES Returns 0 in case of success and -1 if no success. HISTORY 30-Jan-1998 Peter Boesecke ---------------------------------------------------------------------------*/ int get_symbol_list( DBlock * block, int level ) { const int kblen = MaxKeyLen+1; char kbuf[MaxKeyLen+1]; const int vblen = MaxValLen+1; char vbuf[MaxValLen+1]; unsigned long key_pos, val_pos; unsigned long key_len, val_len; FILE * channel = block->Chain->File->Channel; SElement * symbol; int stop; /* read keywords */ stop = get_key(kbuf, kblen, channel, &key_pos, &key_len); if ( stop < 0 ) return(-1); /* stop on error */ if ( !stop ) while ( level ? 1 : (is_prefix ( kbuf, DATA_FORMAT_PREFIX, False )) ) { /* read value */ stop=get_val( vbuf, vblen, channel, &val_pos, &val_len ); // if (stop) if ( stop < 0 ) return(-1); else break; if (stop) { if ( stop < 0 ) return(-1); else break; } /* insert symbol */ if ( insert_symbol( block, kbuf, vbuf, &symbol ) ) return(-1); symbol->KeyPos = key_pos; symbol->KeyLen = (unsigned short) key_len; symbol->ValPos = val_pos; symbol->ValLen = (unsigned short) val_len; /* read next key */ stop=get_key( kbuf, kblen, channel, &key_pos, &key_len ); // if (stop) if ( stop < 0 ) return(-1); else break; if (stop) { if ( stop < 0 ) return(-1); else break; } /* printf("Key = %s, KeyPos = %u, KeyLen = %u\n", kbuf, key_pos, key_len); */ } /* while is_prefix */ /* go back to previous key position */ if (!stop) fseek( channel, (size_t) key_pos, SEEK_SET ); return(0); } /* get_symbol_list */ /*--------------------------------------------------------------------------- NAME new_general_block SYNOPSIS int new_general_block( DFile * file ); DESCRIPTION Creates a general block with default values and updates the file strucure. RETURN VALUES Returns 0 in case of success and -1 if no success. HISTORY 18-Jan-1998 Peter Boesecke 16-Mar-2000 PB default_chain_key ---------------------------------------------------------------------------*/ int new_general_block( DFile * file ) { char ChainKeyDefinition[MaxKeyLen+1]; char ChainKey[MaxKeyLen+1]; DChain * chain; DBlock * block; SElement * symbol; if (insert_data_chain( file, GENERAL_CHAIN_KEY, &chain) ) return(-1); if (insert_data_block( chain, GENERAL_BLOCK_KEY, &block) ) return(-1); if (!(file->GeneralBlock)) file->GeneralBlock = block; else return(-1); /* cannot create a second general block */ /* Defaults */ /* define default DataChain */ if ( sprintf(ChainKeyDefinition,"%s%u",CHAIN_KEY_DEFINITION,1)<1 ) return(-1); if (!(default_chain_key(ChainKey,1))) return(-1); if (insert_string( block, ChainKeyDefinition, ChainKey, &symbol)) return(-1); file->ActiveBlock = block; /* don´t write general block to disk, if NoGeneralHeader or TemporaryFile are set */ if ( (file->Flags.NoGeneralHeader)||(file->Flags.TemporaryFile) ) { block->Flags.InternalHeader = True; block->Flags.InternalData = True; } return(0); } /* new_general_block */ /*--------------------------------------------------------------------------- NAME read_general_block SYNOPSIS int read_general_block( DFile * file ); DESCRIPTION Reads the general block from the file. Can only be called once after ´new_general_block´. The general block must be at the start of the file and MUST begin with ´header_begin´ ´DATA_FORMAT_PREFIX´. Otherwise it is assumed that this file has no general block. If the header contains a ´BLOCK_ID_KEY´ the version number V2.0 is assumed with default block boundary. In the other case a block boudary of 1 byte is assumed. In all successful cases the file pointer is positioned at the beginning of the first data block. RETURN VALUES Returns 0 in case of success and -1 if no success. HISTORY 18-Mar-1998 Peter Boesecke 11-Jul-2001 PB accepts empty files as edf-files without genereal header ---------------------------------------------------------------------------*/ int read_general_block( DFile * file ) { static char errmsg[MaxValLen+1]; int stop=0; int check_status; const size_t buflen = MaxValLen+1; char fullname[MaxValLen+1], path[MaxValLen+1]; unsigned long text_pos, binary_pos; unsigned long binary_len; FILE * channel = file->Channel; DBlock * block; SElement * symbol; /* get block */ block = file->GeneralBlock; /* block must be created */ if (!(block)) return(-1); /* goto start of file */ rewind( channel ); /* remember start position */ text_pos = (unsigned long) ftell (channel); /* check StartHeader */ switch( check_start( channel ) ) { case 0: /* read ALL keywords with and without DATA_FORMAT_PREFIX */ if ( get_symbol_list( block, 1 ) ) { sprintf(errmsg, "Error reading header values"); print_file_error ( stderr, file, text_pos, errmsg ); return(-1); } break; // OK case -1: stop=1; break; // EOF (empty file, without keywords) default: { sprintf(errmsg, "This file is not a %s file",DATA_FORMAT_NAME); print_file_error ( stderr, file, text_pos, errmsg ); return(-1); } } // switch /* DATA_FORMAT_VERSION_KEY */ if ( search_symbol( block, DATA_FORMAT_VERSION_KEY, &symbol ) ) { /* this file has no general block */ set_no_general_block ( block ); /* BLOCK_ID_KEY */ if ( (stop)||(!search_symbol( block, BLOCK_ID_KEY, &symbol )) ) { /* this file is empty or has a BLOCK_ID_KEY. It must be version 2.xx without header */ set_data_format_version ( block, str2version( "2.00" ) ); } else { set_data_format_version ( block, str2version( "1.00" ) ); set_block_boundary ( block, 1U ); /* block boundary 1 */ } /* recreate general block, because it contains wrong symbols */ free_data_block_list( block->Chain ); /* remove general block */ file->GeneralBlock = (DBlock *) NULL; if ( new_general_block( file ) ) return(-1); rewind( channel ); return(0); } /* DATA_FORMAT_VERSION_KEY */ /* BLOCK_BOUNDARY_KEY (alt: internal default) */ if (search_symbol( block, BLOCK_BOUNDARY_KEY, &symbol ) ) { ; /* set_block_boundary( block, 1U ); +++++++++++++++*/ // fprintf(stderr,"WARNING: Key \"%s\" not found\n", BLOCK_BOUNDARY_KEY); } else { if ( set_block_boundary( block, s2u_long( symbol->Value ) )) { sprintf(errmsg,"ERROR: Cannot change block boundary."); print_file_error ( stderr, file, text_pos, errmsg ); return(-1); } } /* BINARY_SIZE_KEY (alt: 0U) */ if (search_symbol( block, BINARY_SIZE_KEY, &symbol ) ) { binary_len = 0U; } else { binary_len = s2u_long( symbol->Value ); } /* BINARY_FILE_NAME_KEY (alt: null pointer */ if ( !search_symbol( block, BINARY_FILE_NAME_KEY, &symbol ) ) { /* get full path of header file and apply to binary file */ getpath_edf( path, buflen, file->Name ); sprintf( fullname, "%s%s", path, symbol->Value ); block->BinaryFileName = newstr( fullname ); if (!block->BinaryFileName) return(-1); /* BINARY_FILE_POSITION_KEY (alt: ERROR) */ if ( !search_symbol( block, BINARY_FILE_POSITION_KEY, &symbol ) ) { block->BinaryFilePos = s2u_long( symbol->Value ); } else { fprintf(stderr,"ERROR: %s requires %s\n", BINARY_FILE_NAME_KEY,BINARY_FILE_POSITION_KEY); return(-1); } /* BINARY_FILE_SIZE_KEY (alt: 0U) */ if ( !search_symbol( block, BINARY_FILE_SIZE_KEY, &symbol ) ) { block->BinaryFileLen = s2u_long( symbol->Value ); } else block->BinaryFileLen = 0U; } /* BINARY_FILE_NAME_KEY */ /* HEADER END */ if (stop) { if ( check_end ( channel ) < 0 ) return(-1); } else { /* search end of this header section */ check_status = search_end( channel,text_pos,block_boundary( block )); if ( check_status == -1) /* search againg in 1 byte steps */ check_status = search_end( channel,text_pos,1); if ( check_status ) { sprintf(errmsg,"Header end marker not found"); print_file_error ( stderr, file, text_pos, errmsg ); return(-1); } } binary_pos = (unsigned long) ftell (channel); block->TextPos = text_pos; block->TextLen = binary_pos - text_pos; block->BinaryPos = binary_pos; block->BinaryLen = binary_len; /* check position relative to block boundary of end marker if */ if ( binary_pos % block_boundary( block ) ) { /* Warning only if binary section exist (mixed text binary file)*/ if ( binary_len ) { fprintf(stderr, "WARNING: The binary section of this block starts at position %lu.\n", binary_pos); fprintf(stderr," This is not a multiple of the block boundary %lu.\n", block_boundary( block )); } fprintf(stderr,"\nINFO: Reading the file %s with block boundary 1.\n\n", block->Chain->File->Name); set_block_boundary( block, 1U ); } /* update data block flags */ block->Flags.DiskBlockUsed = True; block->Flags.DiskBlockFixed = True; block->Flags.HeaderExternal = False; file->LastBlockInFile=block; /* search start position of next block */ if ( fseek( channel, binary_pos+binary_len, SEEK_SET) ) { perror("read_general_block->fseek"); return(-1); } return(0); } /* read_general_block */ /*--------------------------------------------------------------------------- NAME locate_block SYNOPSIS int locate_block( DFile * file, DBlock ** pblock ); DESCRIPTION Reads a block from the file, starting at the current position. The block must start with: ´header_begin´ In versions < 2.0 the full header is scanned, for version >= 2.0 only the format specific symbols are read and the end of the header is searched at multiples of BlockBoundary positions from the start of the header. The file pointer is located after the binary section of this block at the start of the next block. For V2.xx the data block id is used, for V1.xx the V1_IMAGE_KEY or alternatively, if this was not found, V1_HEADER_ID_KEY is used to get the image number. RETURN VALUES further read not possible: 2, all temporary memory is released, previously read file OK end of file: 1, all temporary memory is released. previously read file OK success: 0, all temporary memory is released fatal error: -1, temporary memory might not be released. program should be terminated. Pointer *pblock to the located block. ---------------------------------------------------------------------------*/ int locate_block( DFile * file , DBlock **pblock ) { int stop=0; int check_status; const size_t buflen = MaxValLen+1; char fullname[MaxValLen+1], path[MaxValLen+1]; unsigned long text_pos, binary_pos; unsigned long text_len, binary_len; FILE * channel; DChain * chain, *chain_tmp; DBlock * block, *block_tmp; SElement * symbol; long *data_dim; size_t data_len; DFVersion version; char BlockIDBuffer[MaxValLen+1]; char ChainKeyBuffer[MaxValLen+1]; char *BlockKey, *ChainKey; // const DFVersion V1_0 = str2version("1.00"); const DFVersion V2_0 = str2version("2.00"); if (!file) goto locate_block_fatal; if (pblock) *pblock = NULL; channel = file->Channel; version = file->Version; /* remember start position */ text_pos = (unsigned long) ftell (channel); /* CHECK HEADER START */ check_status = check_start( channel ); if ( check_status ) { if ( check_status == -1 ) goto locate_block_eof; else { print_file_warning ( stderr, file, text_pos, "Expecting EOF or header start" ); goto locate_block_trunc; } } /* create temporary structure */ if ( insert_data_chain( file, "_TEMP_", &chain_tmp ) ) goto locate_block_fatal; if ( insert_data_block( chain_tmp, "_TEMP_", &block_tmp ) ) goto locate_block_fatal; /* READ FORMAT SPECIFIC KEYWORDS (if Version<2.00 read all) */ if ( compare_versions( version, V2_0 ) < 0 ) { /* VERSION < 2.00 */ if ( get_symbol_list( block_tmp, 1 ) ) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Error reading header values V1.xx"); goto locate_block_trunc; } } else { /* VERSION >= 2.00 */ if ( get_symbol_list( block_tmp, 0 ) ) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Error reading header values"); goto locate_block_trunc; } } /* BLOCK_ID_KEY (alt: V1_IMAGE_KEY, alt2: HeaderID, alt3: SequenceNumber) */ if ( !search_symbol( block_tmp, BLOCK_ID_KEY, &symbol ) ) { if ( split_block_id( BlockIDBuffer, MaxValLen+1, symbol->Value, &BlockKey, &ChainKey ) ) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Error reading block id"); goto locate_block_trunc; } } else if ( !search_symbol( block_tmp, V1_IMAGE_KEY, &symbol ) ) { // alt1: V1_IMAGE_KEY sprintf(BlockIDBuffer,"%s.%s", symbol->Value,default_chain_key(ChainKeyBuffer,1)); if ( split_block_id( BlockIDBuffer, MaxValLen+1, BlockIDBuffer, &BlockKey, &ChainKey ) ) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Error reading block id"); goto locate_block_trunc; } } else if ( !search_symbol( block_tmp, V1_HEADER_ID_KEY, &symbol ) ) { // alt2: HeaderID sprintf(BlockIDBuffer,"%ld.%s", header_id_number(symbol->Value),default_chain_key(ChainKeyBuffer,1)); if ( split_block_id( BlockIDBuffer, MaxValLen+1, BlockIDBuffer, &BlockKey, &ChainKey ) ) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Error reading V1.xx header id"); goto locate_block_trunc; } } else { // alt3: SequenceNumber fprintf(stderr,"WARNING: Missing block ID, using sequence number\n"); sprintf(BlockIDBuffer,"%ld.%s", file->NextSequenceNumber-1, default_chain_key(ChainKeyBuffer,1)); if ( split_block_id( BlockIDBuffer, MaxValLen+1, BlockIDBuffer, &BlockKey, &ChainKey ) ) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Failed using sequence number"); goto locate_block_trunc; } } /* BINARY_SIZE_KEY (alt: V1_SIZE_KEY) */ if ( !search_symbol( block_tmp, BINARY_SIZE_KEY, &symbol ) ) binary_len = s2u_long( symbol->Value ); else if ( !search_symbol( block_tmp, V1_SIZE_KEY, &symbol ) ) binary_len = s2u_long( symbol->Value ); else if ( (data_dim = get_data_dim ( block_tmp )) ) { /* FIT2D KLORA FORMAT (V1_SIZE_KEY missing, but dimensions given) */ data_len = edf_dim_product(data_dim)*edf_data_sizeof(get_data_type(block_tmp)); if (EDFIO_debug) { printf ("FIT2D KLORA FORMAT dim[0]=%lu, dim[1]=%lu, dim[2]=%lu, data_len=%lu\n",\ data_dim[0],data_dim[1],data_dim[2],data_len); } binary_len = data_len; } else binary_len = 0U; /* BINARY_FILE_NAME_KEY (alt: null pointer */ if ( !search_symbol( block_tmp, BINARY_FILE_NAME_KEY, &symbol ) ) { /* get full path of header file and apply to binary file */ getpath_edf( path, buflen, file->Name ); sprintf( fullname, "%s%s", path, symbol->Value ); block_tmp->BinaryFileName = newstr( fullname ); if (!block_tmp->BinaryFileName) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Error reading binary file name"); goto locate_block_trunc; } /* BINARY_FILE_POSITION_KEY (alt: ERROR) */ if ( !search_symbol( block_tmp, BINARY_FILE_POSITION_KEY, &symbol ) ) { block_tmp->BinaryFilePos = s2u_long( symbol->Value ); } else { fprintf(stderr,"ERROR: The key \"%s\" requires the key \"%s\"\n", BINARY_FILE_NAME_KEY,BINARY_FILE_POSITION_KEY); if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Missing binary file position"); goto locate_block_trunc; } if ( !search_symbol( block_tmp, BINARY_FILE_SIZE_KEY, &symbol ) ) { block_tmp->BinaryFileLen = s2u_long( symbol->Value ); } else block_tmp->BinaryFileLen = 0U; } /* BINARY_FILE_NAME_KEY */ /* SEARCH HEADER END */ if (stop) { if ( check_end ( channel ) < 0 ) goto locate_block_eof; } else { /* search end of this header section */ check_status = search_end( channel, text_pos, file->BlockBoundary ); /* in case of EOF or '\0' search again */ if ( check_status == -1 ) /* search again in 1 byte steps */ check_status = search_end( channel, text_pos, 1 ); if ( check_status ) { if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; print_file_warning ( stderr, file, text_pos, "Header end marker not found"); goto locate_block_trunc; } } /* if (stop) */ binary_pos = (unsigned long) ftell (channel); text_len = binary_pos - text_pos; /* CHECK POSITION relative to block boundary of end marker */ if ( binary_pos % file->BlockBoundary ) { if (binary_len) { fprintf(stderr, "WARNING: The binary section of this block starts at position %lu.\n", binary_pos); fprintf(stderr," This is not a multiple of the block boundary %lu\n", block_boundary( block_tmp ) ); } fprintf(stderr,"\nINFO: Reading the file %s with block boundary 1.\n\n", block_tmp->Chain->File->Name); set_block_boundary( block_tmp, 1U ); } if ( insert_data_chain( file, ChainKey, &chain ) ) goto locate_block_fatal; if ( insert_data_block( chain, BlockKey, &block ) ) goto locate_block_fatal; /* data block positions */ block->TextPos = text_pos; block->TextLen = text_len; block->BinaryPos = binary_pos; block->BinaryLen = binary_len; block->BinaryFileName = newstr(block_tmp->BinaryFileName); block->BinaryFilePos = block_tmp->BinaryFilePos; block->BinaryFileLen = block_tmp->BinaryFileLen; /* data block flags */ block->Flags.DiskBlockUsed = True; block->Flags.DiskBlockFixed = True; block->Flags.HeaderExternal = True; block->Flags.HeaderChanged = False; block->Flags.DataExternal = True; block->Flags.DataChanged = False; block->Flags.ExternalDimAlloc = False; block->Flags.ExternalDataAlloc = False; block->Flags.BadBlock = False; /* remove temporary data_chain */ if ( free_data_chain( chain_tmp ) ) goto locate_block_fatal; if (pblock) *pblock = block; file->LastBlockInFile=block; /* search start position of next block */ if ( fseek( channel, binary_pos+binary_len, SEEK_SET) ) { print_file_warning ( stderr, file, binary_pos+binary_len, "Cannot find start of next block"); goto locate_block_trunc; } /* success */ return(0); locate_block_eof: /* end of file reached */ return(1); locate_block_trunc: /* further read not possible */ return(2); locate_block_fatal: /* fatal error */ return(-1); } /* locate_block */ /*--------------------------------------------------------------------------- NAME get_data_header --- read data block header from disk SYNOPSIS int get_data_header( DBlock * block ); DESCRIPTION Reads all data block symbols from the stream. RETURN VALUE success: 0; otherwise: -1; ---------------------------------------------------------------------------*/ int get_data_header( DBlock * block ) { unsigned long cur_pos; FILE * channel = block->Chain->File->Channel; if (block) if (block->Flags.HeaderExternal) { /* get block position */ cur_pos = block->TextPos; /* search block position */ if ( fseek( channel, cur_pos, SEEK_SET) ) { perror("get_data_header->fseek"); goto get_data_header_error; } /* check StartHeader */ if ( check_start( channel ) ) { perror("get_data_header->check_start"); goto get_data_header_error; } /* read symbols */ if ( get_symbol_list( block, 1 ) ) { perror("get_data_header->get_symbol_list"); goto get_data_header_error; } /* update data block flags */ block->Flags.DiskBlockUsed = True; block->Flags.DiskBlockFixed = True; block->Flags.HeaderExternal = False; block->Flags.HeaderChanged = False; } /* success */ return(0); get_data_header_error: return(-1); } /* get_data_header */ /*===block_access END===================================================---*/ /*---get_binary_array BEGIN================================================*/ /*--------------------------------------------------------------------------- NAME edf_bswap - byte swapping inside an item SYNOPSIS void edf_bswap( void * dest, const void * src, size_t item, unsigned long n ); DESCRIPTION Swaps all bytes inside an item of ´src´ consisting of ´item´ bytes and writes the result to the output buffer ´dest´. The output and input buffers can be identical. The minimum size of both buffers in bytes is ´item´ * ´n´. byte byte byte byte byte byte byte byte src : 0 | 1 | 2 | 3 | ... | item-3 | item-2 | item-1 | dest : item-1 | item-2 | item-3 | ... | 3 | 2 | 1 | 0 | ARGUMENTS void * dest ouput buffer
void * src input buffer
size_t item size of a single item in bytes
unsigned long n number of items
AUTHOR Peter Boesecke 14-Jan-1998 HISTORY 30-Apr-2000 PB renamed to edf_bswap --------------------------------------------------------------------------*/ void edf_bswap ( void * dest, const void * src, size_t item, unsigned long n ) { const unsigned char *in; const unsigned char *pi1, *pi2; unsigned char *out; unsigned char *po1, *po2, temp; unsigned long i, j; size_t step = item; unsigned long jmax = (step + 1u) / 2u; if ( (!dest)||(!src) ) { fprintf(stderr, "SEVERE: edf_bswap: NULL pointer\n"); exit(-1); } pi1 = in = (const unsigned char *) src; pi2 = in + step; po1 = out = (unsigned char *) dest; po2 = out + step; for (i=0;i=EndBOrder)) byte_order = InValidBOrder; return( BOrderStrings[byte_order] ); } /* ByteOrder2String */ /*--------------------------------------------------------------------------- NAME String2ByteOrder --- converts a string to a byte order value SYNOPSIS (BOrder) int String2ByteOrder( const char * string ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the return value with its enumerated type has been replaced by "int". RETURN VALUE BOrder == 0 : error, e.g. cannot convert BOrder > 0 : valid byte order value AUTHOR 03-Mar-1998 PB Specification -------------------------------------------------------------------------*/ int String2ByteOrder( const char * string ) { int NE=True; long i = 0; while ( (NE && BOrderStrings[i]) ) NE = compare_keys( string, BOrderStrings[i++], UpperCaseSort ); i = MAX(0,i-1); if (NE) return( InValidBOrder ); else return( i ); } /* String2ByteOrder */ /*--------------------------------------------------------------------------- NAME edf_datatype2string --- converts data type to a string SYNOPSIS DType data_type; const char * edf_datatype2string( int data_type ) DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the variable with its enumerated type has been replaced by "int". RETURN VALUE Pointer to a constant result string. AUTHOR 03-Mar-1998 PB Specification -------------------------------------------------------------------------*/ const char * edf_datatype2string( int data_type ) { if ((data_type<0)||(data_type>=EndDType)) data_type = InValidDType; return( DTypeStrings[data_type] ); } /* edf_datatype2string */ /*--------------------------------------------------------------------------- NAME edf_string2datatype --- converts a string to DType SYNOPSIS (DType) int edf_string2datatype( const char * string ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the return value with its enumerated type has been replaced by "int". RETURN VALUE DType == 0 : error, e.g. cannot convert DType > 0 : valid byte order value AUTHOR 03-Mar-1998 PB Specification --------------------------------------------------------------------------*/ int edf_string2datatype( const char * string ) { int NE=True; long i = 0; while ( (NE && DTypeStrings[i]) ) NE = compare_keys( string, DTypeStrings[i++], UpperCaseSort ); /* aliases */ if (NE) { i=0; while ( (NE && DTypeStringsAliases[i]) ) NE = compare_keys( string, DTypeStringsAliases[i++], UpperCaseSort ); } /* aliases */ if (NE) { i=0; while ( (NE && DTypeStringsAliases1[i]) ) NE = compare_keys( string, DTypeStringsAliases1[i++], UpperCaseSort ); } i = MAX(0,i-1); if (NE) return( InValidDType ); else return( i ); } /* edf_string2datatype */ /*--------------------------------------------------------------------------- NAME edf_compression2string --- converts compression to a string SYNOPSIS DCompression data_compression; const char * edf_compression2string( int data_compression ) DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the variable with its enumerated type has been replaced by "int". RETURN VALUE Pointer to a constant result string. -------------------------------------------------------------------------*/ const char * edf_compression2string( int data_compression ) { if ( (data_compression < 0) || (data_compression >= EndDCompression) ) data_compression = InValidDCompression; return( DCompressionStrings[data_compression] ); } /* edf_compression2string */ /*--------------------------------------------------------------------------- NAME edf_string2compression --- converts a string to a compression value SYNOPSIS (DCompression) int edf_string2compression( const char * string ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the return value with its enumerated type has been replaced by "int". RETURN VALUE DCompression == 0 : error, e.g. cannot convert DCompression > 0 : valid compression -------------------------------------------------------------------------*/ int edf_string2compression( const char * string ) { int NE=True; int i = 0; int value=InValidDCompression; while ( (NE && DCompressionStrings[i]) ) { NE = compare_keys( string, DCompressionStrings[i++], UpperCaseSort ); } /* aliases */ if (NE) { i=0; while ( (NE && DCompressionStringsAliases[i]) ) { NE = compare_keys(string,DCompressionStringsAliases[i++],UpperCaseSort); } } /* aliases1 */ if (NE) { i=0; while ( (NE && DCompressionStringsAliases1[i]) ) { NE = compare_keys(string,DCompressionStringsAliases1[i++],UpperCaseSort); } } i = MAX(0,i-1); if (NE) { i=(long) s2u_long( string ); if ( (0 0 : product of dim[] of all dimensions AUTHOR 03-Mar-1998 PB Specification -------------------------------------------------------------------------*/ unsigned long edf_dim_product ( const long * dim ) { unsigned long product; long i; if ( dim ) { product = (unsigned long) 1; for (i=1;i<=dim[0];i++) { if (dim[i]<=0l) return(0lu); product *= (unsigned long) dim[i]; } } else product = 0; return(product); } /* edf_dim_product */ /*+++------------------------------------------------------------------------ NAME edf_data_sizeof --- returns the size of a data type element SYNOPSIS DType data_type; size_t edf_data_sizeof ( int data_type ); DESCRIPTION The size required for a data_type element is returned. Where data_type is the enum type DType. RETURN VALUE NULL : error (e.g. for invalid data type) >NULL : size of data_type AUTHOR 03-Mar-1998 PB Specification --------------------------------------------------------------------------+*/ size_t edf_data_sizeof ( int data_type ) /*---*/ { if (!((0String ); return( data_type ); } /* get_data_type */ /*-------------------------------------------------------------------------- NAME get_data_dim --- get data dimension from the symbol list of block SYNOPSIS long *get_data_dim ( DBlock * block ); DESCRIPTION The dimension values are read successively from the symbol list of block, starting with Dim_1 and stopping when Dim_nn does not exist. Memory for an array is allocated that contains { nn, Dim_1, Dim_2, ... , Dim_nn }. An array to store the dimensions is allocated. It must be freed explicitely. Attention, the result is not written to block. Keyword Dim_0 is ignored. If Dim_1 is not found an error is returned ((long *) NULL) RETURN VALUE error : (long *) NULL DIM[0] : nn = number of dimensions DIM[1] : number of elements in first dimension ... DIM[nn] : number of elements in nn-th dimension AUTHOR 03-Mar-1998 PB Specification 15-May-2001 PB dim[n+1] is not longer used (as foreseen in edfio V1.37) -------------------------------------------------------------------------*/ PRIVATE long *get_data_dim ( DBlock * block ) { char Key[MaxKeyLen+1]; long dim, *data_dim, maxdim; long product; int errval; SElement *symbol; /* first run: determine dimension */ dim = 1l; sprintf(Key,"%s%lu",DIMENSION_KEY_PREFIX,dim); while ( !search_general( block, Key, &symbol )) { dim++; sprintf(Key,"%s%lu",DIMENSION_KEY_PREFIX,dim); } dim--; data_dim = (long *) NULL; if ( dim > 0 ) { /* second run: store data_dim */ if ( !(data_dim = newdim( dim )) ) return( (long *) NULL ); //++++++++ if ( !(data_dim = (long *) malloc( sizeof( long )*(dim+1) )) ) //++++++++ return( (long *) NULL ); product = 1l; data_dim[0] = maxdim = dim; for (dim = 1; dim<=maxdim; dim++) { sprintf(Key,"%s%lu",DIMENSION_KEY_PREFIX,dim); search_general( block, Key, &symbol ); product *= data_dim[dim] = num_str2long( symbol->String, NULL, &errval ); if (errval) { fprintf(stderr,"ERROR: Failed to read header value %s\n",Key); free( data_dim ); return((long *) NULL); } } } return( data_dim ); } /* get_data_dim */ /*--------------------------------------------------------------------------- NAME get_byte_order --- get the byte order from the symbol list of block SYNOPSIS (BOrder) int get_byte_order ( DBlock * block ); DESCRIPTION The byte order is read from the symbol list of block and converted to the enumerated type BOrder, using the table ´BOrderStrings´. If byte order is not found the default is HighByteFirst. RETURN VALUE integer error : 0 BOrder : positive number AUTHOR 03-Mar-1998 PB Specification ---------------------------------------------------------------------------*/ int get_byte_order ( DBlock * block ) { int byte_order; SElement * symbol; if ( search_general( block, BYTE_ORDER_KEY, &symbol ) ) byte_order = HighByteFirst; else byte_order = String2ByteOrder( symbol->String ); return( byte_order ); } /* get_byte_order */ /*--------------------------------------------------------------------------- NAME get_compression --- get the compression type from the symbol list of block SYNOPSIS (DCompression) int get_compression ( DBlock * block ); DESCRIPTION The compression is read from the symbol list of block and converted to the enumerated type DCompression, using the table ´DCompressionStrings´ and ´DCompressionStringsAliases´. If compresssion is not found the default is UnCompressed. RETURN VALUE integer error : 0 DCompression : positive number AUTHOR 03-Mar-1998 PB Specification --------------------------------------------------------------------------*/ int get_compression ( DBlock * block ) { int compression; SElement * symbol; if ( search_general( block, COMPRESSION_KEY, &symbol ) ) compression = UnCompressed; else compression = edf_string2compression( symbol->String ); return( compression ); } /* get_compression */ /*--------------------------------------------------------------------------- NAME get_data_value_offset--- get data_value_offset from the symbol list of block SYNOPSIS long int get_data_value_offset ( DBlock * block ); DESCRIPTION The data_value_offset is read from the symbol list of block and converted to long integer. If data_value_offset is not found the default is 0l. RETURN VALUE long integer AUTHOR 23-Jul-1999 PB Specification (EDF_DataFormatVersion 2.20) --------------------------------------------------------------------------*/ long int get_data_value_offset ( DBlock * block ) { long int data_value_offset; SElement * symbol; int errval; if ( search_general( block, DATA_VALUE_OFFSET_KEY, &symbol ) ) data_value_offset = 0l; else { data_value_offset = num_str2long( symbol->String, NULL, &errval ); if (errval) { fprintf(stderr,"WARNING: Failed to convert header value %s = %s\n", DATA_VALUE_OFFSET_KEY, symbol->String ); fprintf(stderr," Using %s = 0\n",DATA_VALUE_OFFSET_KEY); data_value_offset = 0l; } } return( data_value_offset ); } /* get_data_value_offset */ /*--------------------------------------------------------------------------- NAME get_raster_configuration --- get the raster configuration number SYNOPSIS long get_raster_configuration ( DBlock * block ); DESCRIPTION The raster_configuration is read from the symbol list of block and returned as a long integer value. If raster_configuration is not found the default is 1. RETURN VALUE long integer error : 0 DCompression : positive number AUTHOR 14-Mar-1998 PB Specification ---------------------------------------------------------------------------*/ long get_raster_configuration ( DBlock * block ) { long raster_configuration; SElement * symbol; int errval; if ( search_general( block, RASTER_CONFIGURATION_KEY, &symbol ) ) raster_configuration = 1l; else { raster_configuration = num_str2long( symbol->String, NULL, &errval ); if (errval) { fprintf(stderr,"WARNING: Failed to convert header value %s = %s\n", RASTER_CONFIGURATION_KEY, symbol->String); fprintf(stderr," Using %s = 1\n",RASTER_CONFIGURATION_KEY); raster_configuration = 1l; } } return( raster_configuration ); } /* get_raster_configuration */ /*--------------------------------------------------------------------------- NAME get_binary_array --- read data array (decompressed, with endian correction) SYNOPSIS int get_binary_array ( DBlock * block, void * buffer, size_t buflen, int must_use_buffer ); DESCRIPTION The binary data of ´block´ is read from disk. ´block´ must have been opened with ´open_read_block´ and the header must be in memory. If buffer is the NULL-pointer a memory section is internally allocated for the data. It has the size DataLen = PRODUCT(´DataDim_nn´)[nn=1,NN]*sizeof(´DataType´) bytes Otherwise, if ´buffer´ is not the NULL-pointer and ´must_use_buffer´ is set (True) the read data will be written to ´buffer´. If the buffer length (buflen) is too short to read all data the routine exits with an error (return value -1). If ´buffer´ is not the NULL-pointer and ´must_use_buffer´ is not set (False) the read data will be written to ´buffer´ only if the buffer length (buflen) is sufficiently large to read all data, otherwise a memory section is allocated like in the case where ´buffer´ is the NULL-pointer. ´DataDim_nn´ stands for the nn-th dimension and NN for the dimensionality of the array. PRODUCT indicates the product over all array dimensions Dim_nn from nn=1 to NN. The data are read like they are on stored. No transformation is applied. The following key words are read Dim_1, Dim_2, ... (default 1, 0, ...) DataType (default FloatIEEE32) ByteOrder (default HighByteFirst) Compression (default None) DataValueOffset (default 0) The following parameter are updated in ´block´: block->Data = pointer to the allocated data buffer block->DataBufferLen = length of the data buffer in bytes block->DataLen = length of the meaningful data in bytes block->DataType = DataType of a single data element in the data buffer block->DataByteOrder = ByteOrder of a single data element in the data buffer block->DataRasterConfiguration = RasterConfiguration of the data array block->DataCompression = Compression type of the data in the data array block->DataValueOffset = offset to be added to each data item *block->DataDim = pointer to the allocated dimension array with DataDim[0] = NN. block->Raw = pointer to the allocated raw data buffer block->RawBufferLen = length of the raw data buffer in bytes block->RawLen = length of the meaningful raw data in bytes DATA SOURCE According to ´block->BinaryFileName´ the binary data is read from the channel of the main file (´block->Chain->File->Channel´) or from an external file. The file pointer is in both cases positioned at ´block->BinaryFilePos´ of the data file. block->BinaryFileName input channel (char *) NULL block->Chain->File->Channel open RETURN VALUE success : 0 error : -1 AUTHOR 03-Mar-1998 PB Specification 29-Dec-2000 PB buffer, buflen, test block->Flags.DataExternal 30-Mar-2001 PB alt_binaryname ---------------------------------------------------------------------------*/ int get_binary_array ( DBlock * block, void * buffer, size_t buflen, int must_use_buffer ) { static const char * GBA_Error = "ERROR: get_binary_array:" ; int i; int intern = True; char *alt_binaryname; long *data_dim; int data_type; int byte_order; int compression; long data_value_offset; long raster_configuration; size_t data_size, data_len, data_buffer_len; size_t bytes_to_read=(size_t) -1; // set to absolute maximum size_t bytes_read; // number of read bytes unsigned long data_pos, data_number; FILE *channel; int errval; /* check whether ´block´ exists */ if (!block) return(-1); /* get binary data description */ data_dim = get_data_dim ( block ); /* is free'ed when block is free'ed */ if (!data_dim) return(-1); // MissingArrayDimensions data_type = get_data_type ( block ); byte_order = get_byte_order ( block ); compression = get_compression ( block ); data_value_offset = get_data_value_offset ( block ); raster_configuration = get_raster_configuration ( block ); /* determine maximum number of bytes of uncompressed data */ data_size = edf_data_sizeof ( data_type ); data_number = edf_dim_product ( data_dim ) ; data_len = data_size * data_number ; // uncompressed length /* determine start and restrict bytes_to_read to length of block/binaryfile */ if (block->BinaryFileName) { data_pos = block->BinaryFilePos; if (block->BinaryFileLen) // only if BinaryFileLen is set bytes_to_read = block->BinaryFileLen; } else { data_pos = block->BinaryPos; bytes_to_read = block->BinaryLen; } /* restrict length of bytes_to_read to length of uncompressed data */ if ( compression>UnCompressed ) bytes_to_read = MIN(bytes_to_read,data_len); if (EDFIO_debug) { printf(" ---- get_binary_array BEGIN\n"); printf(" block = %p\n", block); printf(" buffer = %p\n", buffer); // printf(" buflen = %zu\n", buflen); printf(" buflen = %zu | %lu\n", buflen, buflen); printf(" data_dim[0] = %ld\n", data_dim[0]); for (i=1;i<=data_dim[0];i++) printf(" data_dim[%d] = %ld\n", i, data_dim[i]); printf(" data_type = %d\n", data_type); printf(" byte_order = %d\n", byte_order); printf(" data_value_offset = %ld\n", data_value_offset); printf(" raster_configuration = %ld\n", raster_configuration); // printf(" data_size = %zu\n", data_size); printf(" data_size = %zu | %lu\n", data_size, data_size); printf(" data_number = %ld\n", data_number); // printf(" data_len = %zu\n", data_len); printf(" data_len = %zu | %lu\n", data_len, data_len); printf(" compression = %s\n", edf_compression2string(compression)); printf(" data_pos = %ld\n", data_pos); // printf(" bytes_to_read = %zu\n", bytes_to_read); printf(" bytes_to_read = %zu | %lu\n", bytes_to_read, bytes_to_read); } /* EDFIO_debug */ /* update DataDim array in block */ if ((block->DataDim)&&(block->DataDim[0]>=data_dim[0])) { // copy dimensions into existing array, release data_dim if ( !(copydim( block->DataDim, block->DataDim[0], data_dim ) ) ) { free(data_dim); fprintf(stderr,"%s copydim\n",GBA_Error); return(-1); } free(data_dim); } else block->DataDim = data_dim; // use already allocated buffer if (block->BinaryFileName) { /* open external source read only */ if (EDFIO_debug) printf(" BinaryFileName = %s\n",block->BinaryFileName); if (!(channel = fopen( block->BinaryFileName,"rb"))) { if (!has_extension ( block->BinaryFileName )) { /* add an empty extension */ if (!(alt_binaryname = catstr( block->BinaryFileName, "." ))) { fprintf(stderr,"%s fopen 1\n",GBA_Error); return(-1); } channel = fopen( alt_binaryname,"rb"); free( alt_binaryname ); if (!(channel)) { fprintf(stderr,"%s fopen 2\n",GBA_Error); return(-1);} } else { fprintf(stderr,"%s fopen\n",GBA_Error); return(-1); } } intern = False; } else channel = block->Chain->File->Channel; /* search data start position */ if ( fseek( channel, data_pos, SEEK_SET) ) { fprintf(stderr,"%s fseek\n",GBA_Error); return(-1); } /* do not use buffer if it is equal to block->Data */ if ( (block->Data == buffer) && (!must_use_buffer) ) { buffer = (void *) NULL; buflen = (size_t) 0; } /* unlink externally allocated memory or release internally allocated memory */ if (block->Flags.ExternalDataAlloc) { block->Data = (void *) NULL; block->DataBufferLen = (unsigned long) 0; block->DataLen = (unsigned long) 0; block->Flags.ExternalDataAlloc = False; } else { if ( ( (block->Data) && (block->DataBufferLenData); block->Data = (void *) NULL; block->DataBufferLen = (unsigned long) 0; block->DataLen = (unsigned long) 0; } } if ( (buffer == (void *) NULL) || ((buflenDataBufferLenData = malloc( data_len ))) { fprintf(stderr,"%s malloc\n",GBA_Error); return(-1); } data_buffer_len = data_len; block->Flags.ExternalDataAlloc = False; } else { if (EDFIO_debug) printf(" Use supplied buffer\n"); if (buflenFlags.ExternalDataAlloc = True; block->Data = buffer; data_buffer_len = buflen; } /* read data from file */ switch ( compression ) { case GzipCompression: case ZCompression: /* read and decompress data */ if ( cmpr_frinflate ( block->Data, data_buffer_len, channel, bytes_to_read, compression, &bytes_read, &errval ) ) { fprintf(stderr,"%s cmpr_frinflate errval=%d\n",GBA_Error,errval); return(-1); } break; default: // no decompression /* restrict length of bytes_to_read to length of uncompressed data */ bytes_to_read = MIN(bytes_to_read,data_len); /* read data */ if ( (bytes_read = fread(block->Data,1,bytes_to_read,channel)) < bytes_to_read ) { fprintf(stderr,"%s fread\n",GBA_Error); return(-1); } } // switch /* check length */ if (data_len-bytes_read>0) { // fprintf(stderr,"%s read bytes %zu less than array size %zu\n", fprintf(stderr,"%s read bytes %zu | %lu less than array size %zu | %lu\n", GBA_Error, bytes_read, bytes_read, data_len, data_len ); return(-1); } /* close external file */ if ( !intern ) if (fclose( channel )) { fprintf(stderr,"%s fclose\n",GBA_Error); return(-1); } /* update block */ block->DataLen = data_len; block->DataBufferLen = data_buffer_len; block->DataType = data_type; block->DataByteOrder = byte_order; block->DataRasterConfiguration = raster_configuration; block->DataValueOffset = data_value_offset; block->DataCompression = UnCompressed; block->Flags.DataExternal = False; /* data are read from file */ if (EDFIO_debug) printf(" ---- get_binary_array END\n"); return(0); } /* get_binary_array */ /*===get_binary_array END================================================---*/ /****************************************************************************/ /*--------------------------------------------------------------------------- NAME find_chainkey --- returns ChainKey for DataChain SYNOPSIS int find_chainkey ( int stream, int DataChain, char ChainKey[] ) DESCRIPTON Searches a chain key definition for DataChain and copies it to ChainKey. ChainKey must be sufficiently long (MaxKeyLen+1). First, it searches a chain key definition in the general block, then it takes the default chain key. DataChain must be zero or a positive number. RETURN VALUE 0 : success -1 : failed ---------------------------------------------------------------------------*/ int find_chainkey ( int stream, int DataChain, char ChainKey[] ) { SElement *symbol; DFile *file = NULL; char ChainKeyDefinition[MaxKeyLen+1]; if ( (stream>=0)&&(streamGeneralBlock == (DBlock *) NULL) return(-1); /* search chainkey in general block */ sprintf(ChainKeyDefinition,"%s%u",CHAIN_KEY_DEFINITION,DataChain); if (!( search_symbol( file->GeneralBlock, ChainKeyDefinition, &symbol ) ) ) { strncpy(ChainKey,symbol->Value,MaxKeyLen+1); } else { if (!(default_chain_key(ChainKey, DataChain))) return(-1); } } return(0); } else return(-1); } /* find_chainkey */ /*--------------------------------------------------------------------------- find_blockkey (found : 0, failed : -1) BlockKey must be sufficiently long (MaxKeyLen+1) ---------------------------------------------------------------------------*/ int find_blockkey ( int DataChain, int DataNumber, char BlockKey[] ) { if ( DataChain==0 ) strncpy(BlockKey,GENERAL_BLOCK_KEY,MaxKeyLen+1); else long2s(BlockKey,DataNumber); return(0); } /* find_blockkey */ /*--------------------------------------------------------------------------- NAME put_compressed_block SYNOPSIS int put_compressed_block( DBlock * block, int * pErrorValue ); DESCRIPTION Writes block->Data compressed or uncompressed, depending on DataCompression. If the flags HeaderChanged or DataChanged are set the data are compressed and written. INPUT VALUES DBlock * block; OUTPUT VALUES *pErrorValue update if not NULL MODIFIED RETURN VALUE In case of success the returned value is 0 otherwise -1. *pErrorValue is updated, if not NULL --------------------------------------------------------------------------*/ int put_compressed_block( DBlock * block, int * pErrorValue ) { int errval=RoutineFailed; static const char * PCB_Error = "ERROR: put_compressed_block" ; if (block) { // the data need only to be compressed when they will be really written if ( ((block->Flags.HeaderChanged)||(block->Flags.DataChanged)) && (!block->Flags.InternalData) ) { // write the compressed data to Raw switch ( block->DataCompression ) { case GzipCompression: case ZCompression: // assuming compressed<=uncompressed if (!(block->Raw = malloc( block->DataLen ))) { fprintf(stderr,"%s malloc\n",PCB_Error); goto put_compressed_block_error; } block->RawBufferLen = block->DataLen; if ( cmpr_deflate( block->Raw, block->RawBufferLen, block->Data, block->DataLen, block->DataCompression, &(block->RawLen), &errval ) ) { fprintf(stderr,"%s cmpr_deflate (errval=%d)\n",PCB_Error,errval); goto put_compressed_block_error; } break; default: ; // no compression here } } if ( put_data_block( block ) ) { errval = WriteDataError; goto put_compressed_block_error; } if (block->RawBufferLen) if (block->Raw) free (block->Raw); block->Raw=NULL; block->RawBufferLen = (size_t) 0; block->RawLen = (size_t) 0; } errval = RoutineSucceeded; if (pErrorValue) *pErrorValue=errval; return(0); put_compressed_block_error: if (block->RawBufferLen) if (block->Raw) free (block->Raw); block->Raw=NULL; block->RawBufferLen = (size_t) 0; block->RawLen = (size_t) 0; if (pErrorValue) *pErrorValue=errval; return(-1); } // put_compressed_block /*--------------------------------------------------------------------------- NAME disk_write_block SYNOPSIS int disk_write_block ( DBlock * block, int * pErrorValue ); DESCRIPTION If ´block´ exists header and binary data are written to disk. The symbol list and the link to the data are removed. DataLen is set to 0. The data block flags DiskBlockUsed, DiskBlockFixed, HeaderExternal and DataExternal are set to True, HeaderChanged and DataChanged are set to False. Before reusing this data block it must be read back from the file. INPUT VALUES DBlock * block; OUTPUT VALUES *pErrorValue MODIFIED Block is written to the output file and afterwards the symbol list is removed from block. The data specification is cleared and the dynamic arrays (Data and DataDim) are released if they were not externally allocated. Externally allocated arrays must be released separately. block->DataLen binary bytes of block->Data are written. RETURN VALUE In case of success the returned value is 0 otherwise -1. A more precise description of the error is returned in *pErrorValue. --------------------------------------------------------------------------*/ int disk_write_block ( DBlock * block, int * pErrorValue ) { DFile * file; int errval; if ( block ) { file = block->Chain->File; if ( put_compressed_block( block, &errval ) ) goto disk_write_block_error; /* free symbol list only if InternalHeader is not set and if block is not the general block */ if (( !block->Flags.InternalHeader ) && (block != file->GeneralBlock)) { if ( free_symbol_list( block ) ) { errval = CouldNotFreeHeaders; goto disk_write_block_error; } /* update data block flags for header*/ block->Flags.HeaderExternal = True; } /* unlink data only if InternalData is not set and if block is not the general block */ if (( !block->Flags.InternalData ) && (block != file->GeneralBlock)) { /* clear data specification and release dynamic arrays */ if ( (!block->Flags.ExternalDataAlloc) && (block->Data) ) free( block->Data ); block->Data = NULL; block->DataLen = (size_t) 0; block->DataType = InValidDType; block->DataValueOffset = 0l; block->DataByteOrder = InValidBOrder; block->DataRasterConfiguration = 0l; block->DataCompression = InValidDCompression; if ( (!block->Flags.ExternalDimAlloc) && (block->DataDim) ) free( block->DataDim ); block->DataDim = (long*) NULL; /* update data block flags for data*/ block->Flags.DataExternal = True; block->Flags.ExternalDataAlloc = False; block->Flags.ExternalDimAlloc = False; } } /* if (block) ... */ errval = RoutineSucceeded; if (pErrorValue) *pErrorValue = errval; return(0); disk_write_block_error: if (pErrorValue) *pErrorValue = errval; return(-1); } /* disk_write_block */ /*--------------------------------------------------------------------------- NAME open_write_block - open a single write to a data block SYNOPSIS int open_write_block( int stream, long int DataNumber, int DataChain, DBlock ** pblock, int * pErrorValue ); DESCRIPTION Opens a single write to the data_block file. Searches for header 'DataNumber' in 'DataChain' and returns pblock. If it does not exists, it is created. ´DataChain´ zero is the general block. It must be at the beginning of the file. RETURN VALUE In case of success the returned value is 0 otherwise -1. A more precise description of the error is returned in *pErrorValue. --------------------------------------------------------------------------*/ int open_write_block( int stream, long int DataNumber, int DataChain, DBlock ** pblock, int * pErrorValue ) { DFile * file = NULL; DChain * chain; DBlock * block; int errval; char BlockKey[MaxKeyLen+1]; char ChainKey[MaxKeyLen+1]; /* check stream */ if ( (stream<0)||(stream>=MaxFiles) ) { errval = InvalidStream; goto open_write_block_error; } file = &FileTable[stream]; /* GeneralBlock can only be modified when active */ if (DataChain==0) if (file->GeneralBlock!=file->ActiveBlock) { errval=GeneralBlockNotFirst; goto open_write_block_error; } /* get Channel */ if ( !file->Used ) { errval=NoFileOpen; goto open_write_block_error; } /* find 'ChainKey' */ if ( find_chainkey ( stream, DataChain, ChainKey ) ) { errval=MissingKeyDefinition; goto open_write_block_error; } /* find 'BlockKey' */ if ( find_blockkey ( DataChain, DataNumber, BlockKey ) ) { errval=MissingKeyDefinition; goto open_write_block_error; } /* insert header */ if (insert_data_chain( file, ChainKey, &chain) ) { errval=CouldNotInsertChain; goto open_write_block_error; } if (insert_data_block( chain, BlockKey, &block) ) { errval=CouldNotInsertBlock; goto open_write_block_error; } /* update data block flags */ if ( file->Flags.TemporaryFile ) { block->Flags.InternalHeader = True; block->Flags.InternalData = True; block->Flags.HeaderExternal = False; block->Flags.DataExternal = False; } /* flush previously active block */ if ( file->ActiveBlock != block) { /* flush ActiveBlock */ if ( disk_write_block ( block->Chain->File->ActiveBlock, &errval ) ) goto open_write_block_error; /* update ActiveBlock */ file->ActiveBlock = block; } if (pblock) *pblock = block; errval=RoutineSucceeded; if (pErrorValue) *pErrorValue=errval; return(0); open_write_block_error: if (pErrorValue) *pErrorValue=errval; return(-1); } /* open_write_block */ /*--------------------------------------------------------------------------- NAME close_write_block - close a single write to a data block SYNOPSIS int close_write_block(DBlock * block, int * pErrorValue ); DESCRIPTION Closes a single write to the data_block, currently a dummy routine. RETURN VALUE In case of success the returned value is 0 otherwise -1. A more precise description of the error is returned in *pErrorValue. --------------------------------------------------------------------------*/ int close_write_block( DBlock * block, int * pErrorValue ) { DFile * file; DChain * chain; // int GeneralBlock = is_general_block ( block ); // unused chain = block->Chain; file = chain->File; *pErrorValue = RoutineSucceeded; return(0); } /* close_write_block */ /*--------------------------------------------------------------------------- NAME open_read_block - open a single read from a data block SYNOPSIS int open_read_block(int stream, long int DataNumber, int DataChain, DBlock ** pblock, int * pErrorValue ); DESCRIPTION Opens a single read from the data_block file. In case of success the return value is 1, otherwise 0. RETURN VALUE In case of success the returned value is 0. If the header was not found and without other error the return value is 1. In case of an error the return value is -1. A more detailed description of the error is returned in *pErrorValue. return value 1 : Warning ´DataNumber´ or ´DataChain´ not found, no other error *pErrorValue=CouldNotFindHeader; 0 : OK, data header found *pErrorValue=RoutineSucceeded -1 : Error, *pErrorValue = --------------------------------------------------------------------------*/ int open_read_block( int stream, long int DataNumber, int DataChain, DBlock ** pblock, int * pErrorValue ) { DFile * file; DChain * chain; DBlock * block; int errval; char BlockKey[MaxKeyLen+1]; char ChainKey[MaxKeyLen+1]; /* check stream */ if ((stream<0)||(stream>=MaxFiles)) { errval = InvalidStream; goto open_read_block_error; } /* get file */ file = &FileTable[stream]; if ( !file->Used ) { errval = NoFileOpen; goto open_read_block_error; } /* find 'ChainKey' */ if ( find_chainkey ( stream, DataChain, ChainKey ) ) { errval = MissingKeyDefinition; goto open_read_block_error; } /* find 'BlockKey' */ if ( find_blockkey ( DataChain, DataNumber, BlockKey ) ) { errval = MissingKeyDefinition; goto open_read_block_error; } /* search header */ if (search_data_chain( file, ChainKey, &chain) ) { errval = CouldNotFindHeader; goto open_read_block_notfound; } if (search_data_block( chain, BlockKey, &block) ) { errval = CouldNotFindHeader; goto open_read_block_notfound; } /* update data block flags */ if ( file->Flags.TemporaryFile ) { block->Flags.InternalHeader = True; block->Flags.InternalData = True; block->Flags.HeaderExternal = False; block->Flags.DataExternal = False; } /* flush previously active block and get block from disk */ if ( file->ActiveBlock != block) { /* flush ActiveBlock */ if ( disk_write_block( file->ActiveBlock, &errval ) ) goto open_read_block_error; /* read header */ if ( get_data_header( block ) ) { errval = ReadDataError; // error reading header goto open_read_block_error; } /* update ActiveBlock */ file->ActiveBlock = block; } *pblock = block; errval = RoutineSucceeded; /* success */ if (pErrorValue) *pErrorValue = errval; return(0); open_read_block_notfound: /* warning */ if (pErrorValue) *pErrorValue = errval; return(1); open_read_block_error: /* error */ if (pErrorValue) *pErrorValue = errval; return(-1); } /* open_read_block */ /*--------------------------------------------------------------------------- NAME close_read_block - close a single read from a data block SYNOPSIS int close_read_block(DBlock * block, int * pErrorValue); DESCRIPTION Closes a single read from a data_block, currently a dummy routine. RETURN VALUE In case of success the returned value is 0 otherwise -1. A more precise description of the error is returned in *pErrorValue. --------------------------------------------------------------------------*/ int close_read_block( DBlock * block, int * pErrorValue ) { DFile * file; DChain * chain; // int GeneralBlock = is_general_block ( block ); // unused chain = block->Chain; file = chain->File; if (pErrorValue) *pErrorValue = RoutineSucceeded; return(0); } /* close_read_block */ /*--------------------------------------------------------------------------- NAME read_header_string --- read a string from the header DESCRIPTION Searches for 'keyword' in the header 'DataNumber' in 'DataChain'. If the header or the keyword does not exists, the return value is 0 and a specific error value is returned. This error is not fatal and can be used as a test for the existence of the keyword or the header. The returned argument *pString is a pointer to a location that contains the string of the element 'keyword'. This string is not accesible any more when the file is closed or if the file header is not kept in memory when another block is accessed. RETURN VALUE return value 0 if not found and no other error return( int ) 0 : data header not found or keyword not found *pstatus = status_error; *pErrorValue= ( CouldNotFindHeader, CouldNotFindSymbol, RoutineSucceeded ); 1 : data header found or error, *pstatus = Success or status_error; *pErrorValue = --------------------------------------------------------------------------+*/ int read_header_string ( int stream, long int DataNumber, int DataChain, const char * keyword, const char ** pString, int * pErrorValue, int * pstatus ) /*---*/ { DBlock * block; SElement * symbol; const char *String; int errval, status=status_error; if (EDFIO_debug) printf("read_header_string"); switch ( open_read_block (stream, DataNumber, DataChain, &block, &errval) ) { case 1: /* data header not found */ if (EDFIO_debug) printf("\n"); goto read_header_string_notfound; case -1: /* error */ goto read_header_string_error; } /* read keyword value from symbol list */ if (search_general( block, keyword, &symbol) ) { if (EDFIO_debug) printf(" %s missing;\n",keyword); errval = CouldNotFindSymbol; goto read_header_string_notfound; } if ( close_read_block( block, &errval ) ) goto read_header_string_error; String = symbol->String; if (pString) *pString = String; if (EDFIO_debug) printf(" %s = \"%s\";\n",keyword,String); errval = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; return(1); read_header_string_notfound: if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; return(0); read_header_string_error: if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; return(1); } /* read_header_string */ /*--------------------------------------------------------------------------- NAME write_header_string --- write character string into header DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. If it does not exists, it is created. It writes keyword and value with insert_string into the header. This routine writes, if necessary, the input string with several continuation keys into the header. RETURN VALUE In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int write_header_string ( int stream, long int DataNumber, int DataChain, const char * keyword, const char *String, int * pErrorValue, int * pstatus ) /*---*/ { DBlock * block; SElement * symbol; if (EDFIO_debug) printf("write_header_string %s = \"%s\";\n",keyword,String); if ( open_write_block (stream, DataNumber, DataChain, &block, pErrorValue ) ) { *pstatus=status_error; return(0); } /* create/replace keyword and value in header */ if (insert_string( block, keyword, String, &symbol) ) { *pstatus = status_error; *pErrorValue = CouldNotInsertSymbol; return(0); } if ( close_write_block( block, pErrorValue ) ) { *pstatus = status_error; return(0); } /* The header was changed and must be written to disk */ block->Flags.HeaderChanged = True; *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(1); } /* write_header_string */ /*--------------------------------------------------------------------------- NAME delete_key --- delete key, continuation keys and values DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. and deletes non DATA FORMAT SPECIFIC keys, otherwise error. RETURN VALUE In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int delete_key ( int stream, long int DataNumber, int DataChain, const char * keyword, int * pErrorValue, int * pstatus ) /*---*/ { DBlock * block; int errval, status; if (EDFIO_debug) printf("delete_key %s BEGIN\n",keyword); // check, if keyword is data format specific if (!is_prefix(keyword,DATA_FORMAT_PREFIX,UpperCaseSort)) { if ( edf_test_header ( stream, DataNumber,DataChain, NULL, NULL ) ) { /* read header */ if ( open_read_block (stream, DataNumber, DataChain, &block, &errval) ) goto delete_key_error; if ( close_read_block( block, &errval ) ) goto delete_key_error; /* modify and write header */ if ( open_write_block (stream, DataNumber, DataChain, &block, &errval ) ) goto delete_key_error; /* remove keyword, continuation keys and values from header */ if ( remove_string( block, keyword ) ) { errval = CouldNotDeleteString; goto delete_key_error; } if ( close_write_block( block, &errval ) ) goto delete_key_error; /* The header was changed and must be written to disk */ block->Flags.HeaderChanged = True; } errval = RoutineSucceeded; } else { errval = CouldNotDeleteString; goto delete_key_error; } status = status_success; if (pstatus) *pstatus=status; if (pErrorValue) *pErrorValue=errval; if (EDFIO_debug) printf("delete_key END 1\n"); return(1); delete_key_error: status=status_error; if (pstatus) *pstatus=status; if (pErrorValue) *pErrorValue=errval; if (EDFIO_debug) printf("delete_key END (status=%d) 0\n",status); return(0); } /* delete_key */ /*===machinetype BEGIN====================================================*/ /*+++ public interface of machinetypes------------------------------------ DESCRIPTION The function edf_datatype2machinetype returns a machine type for data type. If a machine type does not exist to a given data type the return value is zero. If MachineTypeInit is set, MachineType contains a translation table from DType to MType, e.g mtype = MachineType[dtype]. PUBLIC enum MType; // defined in edfio.h PUBLIC const char * MachineType2String ( int mtype ); PUBLIC int String2MachineType( const char * string ); PUBLIC int edf_datatype2machinetype ( int dtype ); PUBLIC int edf_machinetype2datatype ( int mtype ); PUBLIC size_t edf_machine_sizeof( int mtype ); PUBLIC void edf_showdatatypes ( int full ); PUBLIC void edf_showmachinetypes ( int full ); ----------------------------------------------- end of machinetypes ---*/ # define Unsigned8Max 255UL # define Unsigned8Min 0UL # define Unsigned16Max 65535UL # define Unsigned16Min 0UL # define Unsigned32Max 4294967295UL # define Unsigned32Min 0UL # if __WORDSIZE == 64 # define Unsigned64Max 18446744073709551615UL # else # define Unsigned64Max 0UL # endif # define Unsigned64Min 0UL # define Signed8Max 127L # define Signed8Min ( -Signed8Max -1L ) # define Signed16Max 32767L # define Signed16Min ( -Signed16Max -1L ) # define Signed32Max 2147483647L # define Signed32Min ( -Signed32Max -1L ) # if __WORDSIZE == 64 # define Signed64Max 9223372036854775807L # else # define Signed64Max 0UL # endif # define Signed64Min (-Signed64Max - 1L) PRIVATE unsigned long UCharMin, UCharMax, UShortMin, UShortMax; PRIVATE unsigned long UIntMin, UIntMax, ULongMin, ULongMax; PRIVATE long CharMin, CharMax, ShortMin, ShortMax; PRIVATE long IntMin, IntMax, LongMin, LongMax; PRIVATE int MachineType[EndDType]; PRIVATE int DataType[EndMType]; PRIVATE int MachineTypeInit = 0; // not initialized const char * MTypeStrings[EndMType+1] = { "Invalid", "unsigned char", "char", "unsigned short", "short", "unsigned int", "int", "unsigned long", "long", "float", "double", (const char *) NULL }; /*+++------------------------------------------------------------------------ NAME edf_machine_sizeof --- returns the size of a machine data type element SYNOPSIS MType mtype; size_t edf_machine_sizeof( int mtype ) DESCRIPTION The size required for a MType element is returned. RETURN VALUE NULL : error (e.g. for invalid mtype) >NULL : size of mtype AUTHOR 30-Apr-2000 PB --------------------------------------------------------------------------+*/ size_t edf_machine_sizeof( int mtype ) { switch ( mtype ) { case MUnsignedChar : return ( sizeof( unsigned char ) ); case MChar : return ( sizeof( char ) ); case MUnsignedShort : return ( sizeof( unsigned short ) ); case MShort : return ( sizeof( short ) ); case MUnsignedInteger : return ( sizeof( unsigned int ) ); case MInteger : return ( sizeof( int ) ); case MUnsignedLong : return ( sizeof( unsigned long ) ); case MLong : return ( sizeof( long ) ); case MFloat : return ( sizeof( float ) ); case MDouble : return ( sizeof( double ) ); }; return ( (size_t) 0 ); } /* edf_machine_sizeof */ /*--------------------------------------------------------------------------- NAME MachineType2String --- returns mtype as string SYNOPSIS const char * MachineType2String ( int mtype ) DESCRIPTION shows internal data types ---------------------------------------------------------------------------*/ const char * MachineType2String ( int mtype ) { if ((mtype<0)||(mtype>=EndMType)) mtype = InValidMType; return( MTypeStrings[mtype] ); } /* MachineType2String */ /*--------------------------------------------------------------------------- NAME String2MachineType --- converts a string to MType SYNOPSIS (MType) int String2MachineType( const char * string ); DESCRIPTION GCC AND G++ For compatibility between gcc and g++ the declaration of the return value with its enumerated type has been replaced by "int". RETURN VALUE MType == 0 : error, e.g. cannot convert MType > 0 : valid machine type value AUTHOR 30-Apr-2000 PB from edf_string2datatype --------------------------------------------------------------------------*/ int String2MachineType( const char * string ) { int NE=True; long i = 0; while ( (NE && MTypeStrings[i]) ) NE = compare_keys( string, MTypeStrings[i++], UpperCaseSort ); i = MAX(0,i-1); if (NE) return( InValidMType ); else return( i ); } /* String2MachineType */ /*--------------------------------------------------------------------------- NAME initmachinetypes SYNOPSIS void initmachinetypes ( void ) DESCRIPTION inits machine type array ---------------------------------------------------------------------------*/ void initmachinetypes ( void ) { int i; int * machinetype = MachineType; int * datatype = DataType; for (i=0;i=EndDType)) dtype = InValidDType; return( MachineType[dtype] ); } /* edf_datatype2machinetype */ /*--------------------------------------------------------------------------- NAME edf_machinetype2datatype --- returns the data type of a machine type SYNOPSIS int edf_machinetype2datatype ( int mtype ) ---------------------------------------------------------------------------*/ int edf_machinetype2datatype ( int mtype ) { if (!MachineTypeInit) initmachinetypes(); if ((mtype<0)||(mtype>=EndMType)) mtype = InValidMType; return( DataType[mtype] ); } /* edf_machinetype2datatype */ /*--------------------------------------------------------------------------- NAME edf_showdatatypes SYNOPSIS void edf_showdatatypes ( int full ) DESCRIPTION Shows data types and the corresponding machine data types. If full is 0 only data types are shown that can be converted. ---------------------------------------------------------------------------*/ void edf_showdatatypes ( int full ) { int i; if (full) printf(" %15s = %15s\n", "DataType", "MachineType"); for (i=1; i( X))?0UL:(( UMAX)<( ( X) - ( UOFF)))?( UMAX):( ( X) - ( UOFF) ) //add UOFF and clip at 0 and UMAX (unsigned in, unsigned out) # define ACLIP_U2U( UX, UOFF, UMAX) ((UMAX)-( UOFF))<( UX)?( UMAX):( ( UOFF) + ( UX) ) //subtract UOFF and clip at 0 and UMAX (unsigned in, unsigned out) # define SCLIP_U2U( UX, UOFF, UMAX) (( UOFF)>( UX))?0UL:(( UMAX)<(( UX)-( UOFF)))?UMAX:(( UX)-( UOFF)) //clip at MIN and MAX (float in) # define CLIP_FLOAT(X, MIN, MAX) (( X)<( MIN))?( MIN):( (( X)>( MAX))?( MAX):( X) ) /*--------------------------------------------------------------------------- NAME Convert2UnsignedShort SYNOPSIS DType DataTypeIn; int Convert2UnsignedShort( unsigned short * Out, const void * In, long ValueOffset, int MachineTypeIn, unsigned long DataCount); DESCRIPTION Conversion of MachineTypeIn array In to unsigned short (MUnsignedShort) array Out. The input data buffer ´In´ with elements of the type ´MachineTypeIn´ is copied to the output data buffer ´Out´ with elements of the type unsigned short. Both buffers contain ´DataCount´ elements. The allocated memory for the output buffer must be sufficiently large. If the required memory for the output buffer is smaller or equal to the input buffer, the same buffer can be used for input and output. RETURN VALUE success: 0 error: -1 AUTHOR Peter Boesecke HISTORY 2001-09-02 PB from Convert2Float --------------------------------------------------------------------------*/ int Convert2UnsignedShort( unsigned short * Out, const void * In, long ValueOffset, int MachineTypeIn, unsigned long DataCount) { register unsigned long i; const unsigned char * pinuchar; const char * pinchar; const unsigned short * pinushort; const short * pinshort; const unsigned int * pinuint; const int * pinint; const unsigned long * pinulong; const long * pinlong; const float * pinfloat; const double * pindouble; unsigned short * pout; long dvo = ValueOffset; unsigned long advo = (ValueOffset<0)?-ValueOffset:ValueOffset; double tmp; size_t t_in, t_out = edf_machine_sizeof ( MUnsignedShort ); if (EDFIO_debug) { printf("Convert2UnsignedShort\n"); } // EDFIO_debug switch ( MachineTypeIn ) { // conversion to long, add dvo, conversion to unsigned short case MUnsignedChar : t_in = edf_machine_sizeof( MUnsignedChar ); if (t_in0;--i) { --pinuchar; if (dvo<0) *(--pout) = SCLIP_U2U(*pinuchar,advo,UShortMax); else *(--pout) = ACLIP_U2U(*pinuchar,advo,UShortMax); } } else { pinuchar = (unsigned char *) In; pout = Out; for (i=0;i0;--i) { --pinchar;--pout; if (dvo<0) *pout = SCLIP_S2U(*pinchar,advo,UShortMax); else *pout = ACLIP_S2U(*pinchar,advo,UShortMax); } } else { pinchar = (char *) In; pout = Out; for (i=0;i0;--i) { --pinushort; if (dvo<0) *(--pout) = SCLIP_U2U(*pinushort,advo,UShortMax); else *(--pout) = ACLIP_U2U(*pinushort,advo,UShortMax); } } break; case MShort : t_in = edf_machine_sizeof( MShort ); if (t_in0;--i) { --pinshort; if (dvo<0) *(--pout) = SCLIP_S2U(*pinshort,advo,UShortMax); else *(--pout) = ACLIP_S2U(*pinshort,advo,UShortMax); } } else { pinshort = (short *) In; pout = Out; for (i=0;i0;--i) { --pinuint; --pout; if (dvo<0) *pout = SCLIP_U2U(*pinuint,advo,UShortMax); else *pout = ACLIP_U2U(*pinuint,advo,UShortMax); } } else { pinuint = (unsigned int *) In; pout = Out; for (i=0;i0;--i) { --pinint;--pout; if (dvo<0) *pout = SCLIP_S2U(*pinint,advo,UShortMax); else *pout = ACLIP_S2U(*pinint,advo,UShortMax); } } else { pinint = (int *) In; pout = Out; for (i=0;i0;--i) { --pinulong; --pout; if (dvo<0) *pout = SCLIP_U2U(*pinulong,advo,UShortMax); else *pout = ACLIP_U2U(*pinulong,advo,UShortMax); } } else { pinulong = (unsigned long *) In; pout = Out; for (i=0;i0;--i) { --pinlong; --pout; if (dvo<0) *pout = SCLIP_S2U(*pinlong,advo,UShortMax); else *pout = ACLIP_S2U(*pinlong,advo,UShortMax); } } else { pinlong = (long *) In; pout = Out; for (i=0;i0;--i) { // round pout--; --pinfloat; tmp = floor( *pinfloat + 0.5 + dvo ); *pout = (short) CLIP_FLOAT(tmp, UShortMin, UShortMax); } } else { pinfloat = (float *) In; pout = Out; for (i=0;i0;--i) { --pout; --pindouble; tmp = floor( *pindouble + 0.5 + dvo ); *pout = (short) CLIP_FLOAT(tmp, UShortMin, UShortMax); } } else { pindouble = (double *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuchar; *pout = dvo + (short) *pinuchar; } } else { pinuchar = (unsigned char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinchar; *pout = dvo + (short) *pinchar; } } else { pinchar = (char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinushort; *pout = dvo + (short) *pinushort; } } else { pinushort = (unsigned short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinshort; *pout = dvo + (short) *pinshort; } } break; case MUnsignedInteger: t_in = edf_machine_sizeof( MUnsignedInteger ); if (t_in0;--i) { --pout; --pinuint; *pout = dvo + (short) *pinuint; } } else { pinuint = (unsigned int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinint; *pout = dvo + (short) *pinint; } } else { pinint = (int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinulong; *pout = dvo + (short) *pinulong; } } else { pinulong = (unsigned long *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinlong; *pout = dvo + (short) *pinlong; } } else { pinlong = (long *) In; pout = Out; for (i=0;i0;--i) { // round pout--; --pinfloat; tmp = floor( *pinfloat + 0.5 + dvo ); *pout = (short) CLIP_FLOAT(tmp, ShortMin, ShortMax); } } else { pinfloat = (float *) In; pout = Out; for (i=0;i0;--i) { --pout; --pindouble; tmp = floor( *pindouble + 0.5 + dvo ); *pout = (short) CLIP_FLOAT(tmp, ShortMin, ShortMax); } } else { pindouble = (double *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuchar; *pout = dvo + (int) *pinuchar; } } else { pinuchar = (unsigned char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinchar; *pout = dvo + (int) *pinchar; } } else { pinchar = (char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinushort; *pout = dvo + (int) *pinushort; } } else { pinushort = (unsigned short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinshort; *pout = dvo + (int) *pinshort; } } else { pinshort = (short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuint; *pout = dvo + (int) *pinuint; } } else { pinuint = (unsigned int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinint; *pout = dvo + (int) *pinint; } } break; case MUnsignedLong: t_in = edf_machine_sizeof( MUnsignedLong ); if (t_in0;--i) { --pout; --pinulong; *pout = dvo + (int) *pinulong; } } else { pinulong = (unsigned long *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinlong; *pout = dvo + (int) *pinlong; } } else { pinlong = (long *) In; pout = Out; for (i=0;i0;--i) { // round pout--; --pinfloat; tmp = floor( *pinfloat + 0.5 + dvo ); *pout = (int) CLIP_FLOAT(tmp, IntMin, IntMax); } } else { pinfloat = (float *) In; pout = Out; for (i=0;i0;--i) { --pout; --pindouble; tmp = floor( *pindouble + 0.5 + dvo ); *pout = (int) CLIP_FLOAT(tmp, IntMin, IntMax); } } else { pindouble = (double *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuchar; *pout = dvo + (long) *pinuchar; } } else { pinuchar = (unsigned char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinchar; *pout = dvo + (long) *pinchar; } } else { pinchar = (char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinushort; *pout = dvo + (long) *pinushort; } } else { pinushort = (unsigned short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinshort; *pout = dvo + (long) *pinshort; } } else { pinshort = (short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuint; *pout = dvo + (long) *pinuint; } } else { pinuint = (unsigned int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinint; *pout = dvo + (long) *pinint; } } else { pinint = (int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinulong; *pout = dvo + (long) *pinulong; } } else { pinulong = (unsigned long *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinlong; *pout = dvo + (long) *pinlong; } } break; case MFloat: t_in = edf_machine_sizeof( MFloat ); if (t_in0;--i) { // round pout--; --pinfloat; tmp = floor( *pinfloat + 0.5 + dvo ); *pout = (long) CLIP_FLOAT(tmp, LongMin, LongMax); } } else { pinfloat = (float *) In; pout = Out; for (i=0;i0;--i) { --pout; --pindouble; tmp = floor( *pindouble + 0.5 + dvo ); *pout = (long) CLIP_FLOAT(tmp, LongMin, LongMax); } } else { pindouble = (double *) In; pout = Out; for (i=0;i MachineTypeIn DataValueOffset -> ValueOffset --------------------------------------------------------------------------*/ int Convert2Float( float * Out, const void * In, long ValueOffset, int MachineTypeIn, unsigned long DataCount) { register unsigned long i; const unsigned char * pinuchar; const char * pinchar; const unsigned short * pinushort; const short * pinshort; const unsigned int * pinuint; const int * pinint; const unsigned long * pinulong; const long * pinlong; const float * pinfloat; const double * pindouble; float * pout; float dvo = (float) ValueOffset; size_t t_in, t_out = edf_machine_sizeof ( MFloat ); if (EDFIO_debug) { printf("Convert2Float\n"); } // EDFIO_debug switch ( MachineTypeIn ) { case MUnsignedChar : t_in = edf_machine_sizeof( MUnsignedChar ); if (t_in0;--i) { --pout; --pinuchar; *pout = dvo + (float) *pinuchar; } } else { pinuchar = (unsigned char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinchar; *pout = dvo + (float) *pinchar; } } else { pinchar = (char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinushort; *pout = dvo + (float) *pinushort; } } else { pinushort = (unsigned short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinshort; *pout = dvo + (float) *pinshort; } } else { pinshort = (short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuint; *pout = dvo + (float) *pinuint; } } else { pinuint = (unsigned int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinint; *pout = dvo + (float) *pinint; } } else { pinint = (int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinulong; *pout = dvo + (float) *pinulong; } } else { pinulong = (unsigned long *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinlong; *pout = dvo + (float) *pinlong; } } else { pinlong = (long *) In; pout = Out; for (i=0;i0;--i) *(--pout) = dvo + *(--pinfloat); } break; case MDouble : t_in = edf_machine_sizeof( MDouble ); if (t_in0;--i) { --pout; --pindouble; *pout = dvo + (float) *pindouble; } } else { pindouble = (double *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuchar; *pout = dvo + (double) *pinuchar; } } else { pinuchar = (unsigned char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinchar; *pout = dvo + (double) *pinchar; } } else { pinchar = (char *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinushort; *pout = dvo + (double) *pinushort; } } else { pinushort = (unsigned short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinshort; *pout = dvo + (double) *pinshort; } } else { pinshort = (short *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinuint; *pout = dvo + (double) *pinuint; } } else { pinuint = (unsigned int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinint; *pout = dvo + (double) *pinint; } } else { pinint = (int *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinulong; *pout = dvo + (double) *pinulong; } } else { pinulong = (unsigned long *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinlong; *pout = dvo + (double) *pinlong; } } else { pinlong = (long *) In; pout = Out; for (i=0;i0;--i) { --pout; --pinfloat; *pout = dvo + (double) *pinfloat; } } else { pinfloat = (float *) In; pout = Out; for (i=0;i0;--i) *(--pout) = dvo + *(--pindouble); } break; default : return(-1); break; } /* switch */ return(0); } /* Convert2Double */ /*--------------------------------------------------------------------------- NAME edf_machine2machine SYNOPSIS MType mtype_src; MType mtype_dest; int edf_machine2machine ( void * dest, int mtype_dest, const void * src, long data_value_offset, int mtype_src, unsigned long n) DESCRIPTION The input data buffer ´src´ with element of the type ´mtype_src´ is copied to the output data buffer ´dest´ with elements of the type ´mtype_dest´. Both buffers consists of ´n´ elements. The data types are listed in ´MType´. The allocated memory for the output buffer must be sufficiently large. If the required memory for the output buffer is smaller or equal to the length of the input buffer both buffers can be identical. RETURN VALUE success: 0 error: -1 AUTHOR Peter Boesecke 08-Mar-1998 HISTORY 23-Jul-1999 DataValueOffset (_DataVersion 2.20) 30-Apr-2000 Name changed to edf_data2machine and MachineType introduced. 02-Sep-2001 dtype_src changed to mtype_src, name changed to edf_machine2machine --------------------------------------------------------------------------*/ int edf_machine2machine ( void * dest, int mtype_dest, const void * src, long value_offset, int mtype_src, unsigned long n) { int failed = True; void *out = dest; const void *in = src; if (EDFIO_debug) { printf("edf_machine2machine\n"); edf_showmachinetypes( True ); printf("Conversion of %s to %s\n", MachineType2String( mtype_src ), MachineType2String( mtype_dest ) ); } // EDFIO_debug if ( (!dest)||(!src) ) { fprintf(stderr, "SEVERE: edf_machine2machine: NULL pointer\n"); exit(-1); } if (!mtype_src) return(-1); switch ( mtype_dest ) { case MUnsignedChar : break; case MChar : break; case MUnsignedShort : failed = Convert2UnsignedShort( (unsigned short *) out, in, value_offset, mtype_src, n ); break; case MShort : failed = Convert2Short( (short *) out, in, value_offset, mtype_src, n ); break; case MUnsignedInteger: break; case MInteger : failed = Convert2Integer( (int *) out, in, value_offset, mtype_src, n ); break; case MUnsignedLong : break; case MLong : failed = Convert2Long( (long *) out, in, value_offset, mtype_src, n ); break; case MFloat : failed = Convert2Float( (float *) out, in, value_offset, mtype_src, n ); break; case MDouble : failed = Convert2Double( (double *) out, in, value_offset, mtype_src, n ); break; default : break; } /* switch */ if (failed) return(-1); return(0); } /* edf_machine2machine */ /*===data_conversion END=================================================---*/ /*===history BEGIN========================================================*/ /*+++ public interface of history ------------------------------------------- DESCRIPTION The routines of this module are used to read and write history lines. 'edf_history_new' must be called first. It clears and initializes the internal history list and argument list. 'edf_history_skip' marks the next argument as not required 'edf_history_take' marks the next argument as required (default) 'edf_history_argv' is used to store the arguments of the call in an internal list. It can be called several times to pass all arguments. 'edf_read_header_history' initializes the history list and reads the history strings from the file header. 'edf_write_header_history' writes the history strings into the output file header. 'edf_history_free' releases all internal lists. 'edf_history_new' must be called before using one of the routines again. 'hist_debug' sets the module into debug mode. The length of a history line is limited to MaxHistoryLineSize-1. HISTORY 1999-06-24 V1.0 Peter Boesecke 1999-11-08 V1.1 PB 2001-09-13 PB history_key 2001-09-15 V1.2 PB history_root -> history_line_root history_root used for HBlock PUBLIC extern int edf_history_new ( const char * history_key ), edf_history_skip ( const char * history_key ), edf_history_take ( const char * history_key ), edf_history_argv ( const char * history_key, const char * substring ), edf_read_header_history ( int stream, long int DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ), edf_write_header_history ( int stream, long int DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ), edf_history_read_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus ), edf_history_write_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus ), edf_history_copy ( const char * history_copy, const char * history_key ), edf_history_free ( const char * history_key ); PUBLIC extern void hist_debug ( int debug ); ---------------------------------- end of public interface of history ---*/ /**************************************************************************** * Constants * ****************************************************************************/ //# define MaxHistoryLineSize (MaxLinLen+1) no restriction 2005-02-27 # define MaxHistoryLineSize (2048+1) # define MaxHistoryKeySize (MaxKeyLen+1) # define HistoryKeyBufferSize 1024 /**************************************************************************** * Static Variables * ****************************************************************************/ static int HIST_debug = 0; static int InitHistory = 0; static HBlock * history_root = (HBlock *) NULL; static const char * argv_key = "_argv_key" ; static const char * default_history_line_key = HISTORY_KEY_PREFIX"1" ; /*--------------------------------------------------------------------------- NAME needquotes SYNOPSIS int needquotes( const char * string ); DESCRIPTION Tests, whether the string must be encapsulated between double quotes. Conditions: string starts with '\"' -> return value 0 string contains white spaces or characters that must be quoted -> return value >0 , otherwise 0 string has zero length -> return value 1 RETURN VALUES Returns a positive number when the string must be encapsulated, otherwise 0 ---------------------------------------------------------------------------*/ int needquotes( const char * string ) { int encapsulation = 0; const char * ps = string; if (string[0]!='\"') { while ( (*ps) && (!(encapsulation)) ) { encapsulation = is_white(*ps) + is_tobequoted ( *ps ); ps++; } } else encapsulation = 0; if ( strlen(string)==0 ) encapsulation = 1; return ( encapsulation ); } /* needquotes */ /*-------------------------------------------------------------------------- NAME hist_debug --- set / reset module history into debug mode SYNOPSIS void hist_debug ( int debug ); DESCRPTION Writes ´debug´ into HIST_debug. -----------------------------------------------------------------------------*/ void hist_debug ( int debug ) { HIST_debug = debug; } /* hist_debug */ /*--------------------------------------------------------------------------- print_history_list (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_history_list( FILE * out, int level, int verbose, HSymb * root ) { const char * SeparationLine = "- - - - - - - -"; HSymb * hline = root; if (level<1) return(0); while (hline!=(HSymb*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," key = %s\n",hline->key); fprintf(out," line = %s\n",hline->line); // fprintf(out," size = %zu\n",hline->size); fprintf(out," size = %zu | %lu\n", hline->size,hline->size); fprintf(out," required = %d\n",hline->required); // fprintf(out," shortlen = %zu\n",hline->shortlen); fprintf(out," shortlen = %zu | %lu\n", hline->shortlen, hline->shortlen); fprintf(out," Previous key = "); if ((hline->Previous)!=(HSymb*) NULL) fprintf(out,"%s\n", hline->Previous->key); else fprintf(out,"(no previous history line)\n"); fprintf(out," Next key = "); if ((hline->Next)!=(HSymb*) NULL) fprintf(out,"%s\n", hline->Next->key); else fprintf(out,"(no next history line)\n"); } else { fprintf(out," '%s' = '%s'\n",hline->key,hline->line); } hline=hline->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* print_history_list */ /*--------------------------------------------------------------------------- NAME init_history SYNOPSIS int init_history( void ) DESCRIPTION Inits history module RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ int init_history( void ) { history_root = (HBlock *) NULL; InitHistory = 1; return(0); } /* init_history */ /*--------------------------------------------------------------------------- NAME copy_history_list SYNOPSIS int copy_history_list(HSymb **proot, HSymb *src); DESCRIPTION Copies all history lines from src to *proot RETURN VALUES In case of success the return value is 0, otherwise -1. ---------------------------------------------------------------------------*/ int copy_history_list(HSymb **proot, HSymb *src) { HSymb * hline; while (src!=(HSymb*) NULL) { if (history_line_new ( proot, src->key, src->size, &hline )) return(-1); hline->line = strncpy(hline->line,src->line,src->size); hline->required = src->required; hline->shortlen = src->shortlen; src=src->Next; } return(0); } /* copy_history_list */ /*--------------------------------------------------------------------------- NAME history_free SYNOPSIS DESCRIPTION Removes all history lines. RETURN VALUES In case of success the return value is 0, otherwise -1. ---------------------------------------------------------------------------*/ int history_free ( HSymb **proot ) { HSymb * hline, * next; next = *proot; while (next) { hline = next; next = hline->Next; if (hline->key) free(hline->key); if (hline->line) free(hline->line); if (hline) free(hline); } *proot = (HSymb *) NULL; return(0); } /* history_free */ /*+++------------------------------------------------------------------------ NAME clear_header_history SYNOPSIS int clear_header_history ( HBlock * hblock ) DESCRIPTION Releases all allocated history lines of ´hblock´ RETURN VALUES In case of success the return value is 0, otherwise -1. ---------------------------------------------------------------------------*/ int clear_header_history ( HBlock * hblock ) /*---*/ { if (!InitHistory) return(-1); if (history_free( &hblock->history_line_root ) ) return(-1); if (hblock->current_history_line_key ) { free( hblock->current_history_line_key ); hblock->current_history_line_key = (char *) NULL; } return(0); } /* clear_header_history */ /*+++------------------------------------------------------------------------ NAME insert_history_block SYNOPSIS int insert_history_block( const char * history_key, HBlock **hblock ); DESCRIPTION Searches for a history block with ´history_key´ and clears it or inserts an empty history block with ´history_key´. The pointer to the history block is returned in *hblock. RETURN VALUES In case of success the return value is 0, otherwise -1. ---------------------------------------------------------------------------*/ int insert_history_block( const char * history_key, HBlock **hblock ) /*---*/ { HBlock * newhblock, * previous, * next; int notfound = 1; /* search for history_key */ *hblock = (HBlock *) NULL; previous = (HBlock *) NULL; next = history_root; /* search insertion point (insertion before next) */ while( ( next!=(HBlock *) NULL ) && (notfound>0) ) { notfound = compare_keys(next->key,history_key,UpperCaseSort); if (notfound>0) {previous = next; next = next->Next;} } if (notfound) { /* create new hblock */ if (!(newhblock = (HBlock *) malloc(sizeof(HBlock)))) return(-1); newhblock->key = newstr(history_key); if (!newhblock->key) {free(newhblock);return(-1);} newhblock->history_argv_root = (HSymb *) NULL; newhblock->history_line_root = (HSymb *) NULL; newhblock->current_history_line_key = (char *) NULL; /* insert newhblock before next */ if (next) next->Previous = newhblock; newhblock->Next=next; newhblock->Previous=previous; if (previous) previous->Next=newhblock; else history_root = newhblock; next = newhblock; } /* clear block (next) */ if (history_free( &next->history_argv_root )) return(-1); if (clear_header_history( next )) return(-1); *hblock = next; return(0); } /* insert_history_block */ /*+++------------------------------------------------------------------------ NAME copy_history_block SYNOPSIS int copy_history_block( const char * history_key, HBlock **hblock, HBlock *src ) DESCRIPTION Searches for a history block with ´history_key´ and clears it or inserts an empty history block with ´history_key´. The contents of src is copied into this block. The pointer to the history block is returned in *hblock. RETURN VALUES In case of success the return value is 0, otherwise -1. ---------------------------------------------------------------------------*/ int copy_history_block( const char * history_key, HBlock **hblock, HBlock *src ) /*---*/ { HBlock * dest; if (insert_history_block( history_key, hblock )) return(-1); // already done if src is identical to *hblock if (src == *hblock) return(0); // copy src to *hbloc dest = *hblock; if (copy_history_list(&(dest->history_line_root),src->history_line_root)) return(-1); if (copy_history_list(&(dest->history_argv_root),src->history_argv_root)) return(-1); if (!(dest->current_history_line_key=newstr(src->current_history_line_key))) return(-1); return(0); } /* copy_history_block */ /*+++------------------------------------------------------------------------ NAME search_history_block SYNOPSIS int search_history_block( const char * history_key, HBlock ** hblock ); DESCRIPTION Searches for history block ´history_key´ and returns it in *hblock RETURN VALUES In case of success the return value is 0, otherwise -1. ---------------------------------------------------------------------------*/ int search_history_block( const char * history_key, HBlock ** hblock ) { HBlock * previous, * next; int notfound = 1; /* search for history_key */ *hblock = (HBlock *) NULL; previous = (HBlock *) NULL; next = history_root; /* search history_key */ while( ( next!=(HBlock *) NULL ) && (notfound) ) { notfound = compare_keys(next->key,history_key,UpperCaseSort); if (notfound) {previous = next; next = next->Next;} } *hblock = next; if (*hblock==(HBlock *) NULL) return(-1); else return(0); } /* search_history_block */ /*+++------------------------------------------------------------------------ NAME remove_history_block SYNOPSIS int remove_history_block( HBlock * hblock ); DESCRIPTION Removes history block hblock from history_root and releases its contents RETURN VALUES In case of success the return value is 0, otherwise -1. ---------------------------------------------------------------------------*/ int remove_history_block( HBlock * hblock ) { HBlock * previous, *next; /* stop, if no symbol found */ if (hblock==(HBlock *) NULL) return(-1); /* change links */ previous = hblock->Previous; next = hblock->Next; if ( next != (HBlock *) NULL ) next->Previous = previous; if ( previous != (HBlock *) NULL ) previous->Next = next; else history_root = next; /* free history block and its elements */ if (history_free( &hblock->history_argv_root ) ) return(-1); if (clear_header_history ( hblock ) ) return(-1); if (hblock->key) free(hblock->key); free(hblock); return(0); } /* remove_history_block */ /*--------------------------------------------------------------------------- NAME history_line_new SYNOPSIS int history_line_new ( HSymb ** proot, const char * history_line_key, size_t history_size, HSymb ** phline ) DESCRIPTION Adds a new history line with the key 'history_line_key' to the list and allocates 'history_size' bytes for the line. If the key already exists, only the line is cleared and reallocated with 'history_size' bytes. The key list is ordered in reverse alphabetical order. If phline is not NULL a pointer to the history line is returned. RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ PRIVATE int history_line_new ( HSymb ** proot, const char * history_line_key, size_t history_size, HSymb ** phline ) { HSymb * newhline, * previous, * next; // HSymb * hline; // unused int notfound = 1; /* search for history_line_key */ if (phline!=(HSymb **)NULL) *phline = (HSymb *) NULL; previous = (HSymb *) NULL; next = *proot; /* search insertion point (insertion before next) */ while( ( next!=(HSymb *) NULL ) && (notfound>0) ) { notfound = compare_keys(next->key,history_line_key,UpperCaseSort); if (notfound>0) {previous = next; next = next->Next;} } if (notfound) { /* create new hline */ if (!(newhline = (HSymb *) malloc(sizeof(HSymb)))) return(-1); newhline->key = newstr(history_line_key); if (!newhline->key) {free(newhline); return(-1);} newhline->line = (char *) NULL; newhline->size = (size_t) 0; newhline->required = 1; newhline->shortlen = 0; /* insert newhline before next */ if (next) next->Previous = newhline; newhline->Next=next; newhline->Previous=previous; if (previous) previous->Next=newhline; else *proot = newhline; next = newhline; } /* update next->line */ if (phline!=(HSymb **)NULL) *phline = next; if ( next->line ) { free ( next->line ); next->line = (char *) NULL; next->size = (size_t) 0; next->required = 1; next->shortlen = 0; } if (history_size<1) return(-1); if (!(next->line = (char *) malloc(history_size))) return(-1); next->line[0] = '\0'; next->size = history_size; next->required = 1; next->shortlen = strlen(next->line); return(0); } /* history_line_new */ /*--------------------------------------------------------------------------- NAME history_line_add SYNOPSIS int history_line_add ( HSymb ** proot, const char * history_line_key, const char * substring ) DESCRIPTION Appends a space and a new item to the end of the history line. If the history line becomes longer than size bytes (including trailing zero) the rest is skipped. RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ int history_line_add ( HSymb ** proot, const char * history_line_key, const char * substring ) { HSymb * next = *proot; int notfound = 1; size_t n, linelen; /* search history line (next) */ while( ( next!=(HSymb *) NULL ) && (notfound>0) ) { notfound = compare_keys(next->key,history_line_key,UpperCaseSort); if (notfound>0) {next = next->Next;} } /* add arguments */ if ( next!=(HSymb *) NULL ) { /* append space if string not empty */ linelen = STRLEN(next->line); if ((linelen>0) && (linelensize-1)) strcat(next->line, " "); linelen = STRLEN(next->line); n = (size_t) MAX(0l,MIN((long) next->size - (long) linelen - 1l, (long) STRLEN(substring))); if (n>0) { // strncat(next->line, substring, n ); // not ansic ++++++++++++++ // strcat(next->line, "\0"); // ++++++++++++++ strncpy(next->line+linelen, substring, n); // start at terminating 0 next->line[linelen+n]='\0'; // write terminating 0 } /* update shortlen if argument is required */ if (next->required) next->shortlen = strlen(next->line); next->required = 1; } return(0); } /* history_line_add */ /*+++------------------------------------------------------------------------ NAME edf_history_new SYNOPSIS int edf_history_new ( const char * history_key ) DESCRIPTION This routines must be called first. If not already initialized, it initializes all history lists. Existing history lines are removed and a new empty history line with size MaxHistoryLineSize is created. ´edf_history_argv´ adds parameters to this line. ´edf_write_header_history´ appends it with a new key to the history lines that were read with ´edf_read_header_history´. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_new ( const char * history_key ) /*---*/ { HBlock * hblock; if (HIST_debug) printf("\n edf_history_new BEGIN\n"); /* init history module */ if (!InitHistory) init_history(); /* create an empty history block */ if (insert_history_block( history_key, &hblock )) return(0); /* create empty history line */ if (history_line_new ( &hblock->history_argv_root, argv_key, MaxHistoryLineSize, (HSymb **) NULL ) ) return(0); /* default history key */ if (hblock->current_history_line_key) free(hblock->current_history_line_key); hblock->current_history_line_key = newstr(default_history_line_key); if (HIST_debug) printf("\n edf_history_new END\n"); return(1); } /* edf_history_new */ /*--------------------------------------------------------------------------- NAME history_line_required SYNOPSIS int history_line_required ( HSymb ** proot, const char * history_line_key, int required ) DESCRIPTION Sets the parameter 'required' of 'history_line_key' to required. If 'required' is 1, the next call to history_line_add will update the parameter 'shortlen', if 'required' is 0, the next call to history_line_add will not update the parameter 'shortlen' RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ int history_line_required ( HSymb ** proot, const char * history_line_key, int required ) { HSymb * next = *proot; int notfound = 1; /* search history line (next) */ while( ( next!=(HSymb *) NULL ) && (notfound>0) ) { notfound = compare_keys(next->key,history_line_key,UpperCaseSort); if (notfound>0) {next = next->Next;} } if ( next!=(HSymb *) NULL ) { next->required = required; } return(0); } /* history_line_required */ /*+++------------------------------------------------------------------------ NAME edf_history_skip SYNOPSIS int edf_history_skip ( const char * history_key ) DESCRIPTION This routines marks the next parameter that is passed to edf_history_argv as not required. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_skip ( const char * history_key ) /*---*/ { HBlock * hblock; if (HIST_debug) printf("\n edf_history_skip BEGIN\n"); if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) return(0); if (history_line_required ( &hblock->history_argv_root, argv_key, 0 )) return(0); if (HIST_debug) { print_history_list( stdout, 1, 1, hblock->history_argv_root ); } if (HIST_debug) printf("\n edf_history_skip END\n"); return(1); } /* edf_history_skip */ /*+++------------------------------------------------------------------------ NAME edf_history_take SYNOPSIS int edf_history_take ( const char * history_key ) DESCRIPTION This routines marks the next parameter that is passed to edf_history_argv as required (opposite of edf_history_skip) RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_take ( const char * history_key ) /*---*/ { HBlock *hblock; if (HIST_debug) printf("\n edf_history_take BEGIN\n"); if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) return(0); if (history_line_required ( &hblock->history_argv_root, argv_key, 1 )) return(0); if (HIST_debug) { print_history_list( stdout, 1, 1, hblock->history_argv_root ); } if (HIST_debug) printf("\n edf_history_take END\n"); return(1); } /* edf_history_take */ /*+++------------------------------------------------------------------------ NAME edf_history_free SYNOPSIS int edf_history_free ( const char * history_key ) DESCRIPTION Removes all history lines from history_key. If called with history_key == (char *) NULL, all history blocks are removed RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_free ( const char * history_key ) /*---*/ { HBlock * next, * hblock; if (HIST_debug) printf("\n edf_history_free BEGIN\n"); if (!InitHistory) init_history(); if ( history_key != (char *) NULL ) { /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) return(0); /* clear and remove history block */ if (remove_history_block( hblock )) return(0); } else { next = history_root; while ( next != (HBlock *) NULL ) { hblock = next; next = hblock->Next; /* clear and remove history block */ if (remove_history_block( hblock )) return(0); } } if (HIST_debug) printf("\n edf_history_free END\n"); return( 1 ); } /* edf_history_free */ /*+++------------------------------------------------------------------------ NAME edf_read_header_history SYNOPSIS int edf_read_header_history (int stream, long int DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ) DESCRIPTION Reads all history lines from the date file header and copies them to 'hline->key's. History lines have the keyword HISTORY_KEY_PREFIX'u', where 'u' is an unsigned positive integer. A new history line with the key HISTORY_KEY_PREFIX'last+1' and MaxHistoryLineSize bytes is created. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_read_header_history (int stream, long int DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ) /*---*/ { HBlock *hblock; char history_line[MaxHistoryLineSize]; char history_line_key_buffer[HistoryKeyBufferSize]; long depth=1; const char *String; int ErrorValue = RoutineSucceeded, status = status_error; if (HIST_debug) printf("\n edf_read_header_history BEGIN\n"); if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) goto edf_read_header_history_error; if (clear_header_history ( hblock ) ) goto edf_read_header_history_error; sprintf(history_line_key_buffer,"%s%lu",HISTORY_KEY_PREFIX,depth++); while ( edf_read_header_string ( stream, DataNumber, DataChain, history_line_key_buffer, &String, &ErrorValue, &status )) { if (status != status_success) goto edf_read_header_history_error; /* Copy string to history line */ if (String) { strncpy(history_line,String,MaxHistoryLineSize-1); history_line[MaxHistoryLineSize-1]='\0'; } else history_line[0]='\0'; if (history_line_new( &hblock->history_line_root, history_line_key_buffer, STRLEN(history_line)+1, (HSymb **) NULL )) goto edf_read_header_history_error; if (history_line_add( &hblock->history_line_root, history_line_key_buffer, history_line)) goto edf_read_header_history_error; sprintf(history_line_key_buffer,"%s%lu",HISTORY_KEY_PREFIX,depth++); } /* save current history key */ if (hblock->current_history_line_key) free(hblock->current_history_line_key); hblock->current_history_line_key = newstr(history_line_key_buffer); if (HIST_debug) { printf(" history block key = %s\n",hblock->key); printf(" current_history_line_key = %s\n", hblock->current_history_line_key); print_history_list( stdout, 1, 1, hblock->history_argv_root ); print_history_list( stdout, 1, 1, hblock->history_line_root ); } ErrorValue = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_read_header_history END\n"); return(1); edf_read_header_history_error: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_read_header_history END (status=%d)\n",status); return(0); } /* edf_read_header_history */ /*+++------------------------------------------------------------------------ NAME edf_write_header_history SYNOPSIS int edf_write_header_history ( int stream, long int DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ) DESCRIPTION Writes the history strings in 'history_line_root' into the date file header using the 'hline->key's as keywords. Writes the history string in 'history_argv_root' into the date file header using 'current_history_line_key' as keyword. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_write_header_history ( int stream, long int DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ) /*---*/ { HBlock * hblock; HSymb * next; int retval = 1; int ErrorValue = RoutineSucceeded, status = status_error; if (HIST_debug) printf("\n edf_write_header_history BEGIN\n"); if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) goto edf_write_header_history_error; if (HIST_debug) { printf(" history block key = %s\n",hblock->key); printf(" current_history_line_key = %s\n", hblock->current_history_line_key); print_history_list( stdout, 1, 1, hblock->history_argv_root ); print_history_list( stdout, 1, 1, hblock->history_line_root ); } /* history_argv_root */ if (( hblock->history_argv_root != (HSymb *) NULL ) && ( hblock->current_history_line_key != (char *) NULL ) && ( hblock->history_argv_root->line != (char *) NULL ) ) { /* write only non-empty history lines */ if (strlen(hblock->history_argv_root->line)>0) { /* remove not required arguments */ hblock->history_argv_root->line[hblock->history_argv_root->shortlen]='\0'; if (!(edf_write_header_string ( stream, DataNumber, DataChain, hblock->current_history_line_key, hblock->history_argv_root->line, &ErrorValue, &status ) ) ) goto edf_write_header_history_return; } } /* history_line_root */ next = hblock->history_line_root; while ( next!=(HSymb *) NULL ) { if (!(edf_write_header_string ( stream, DataNumber, DataChain, next->key, next->line, &ErrorValue, &status ) ) ) goto edf_write_header_history_return; next = next->Next; } ErrorValue = RoutineSucceeded; status = status_success; edf_write_header_history_return: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_write_header_history END\n"); return( retval ); edf_write_header_history_error: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_write_header_history (status=%d)\n",status); return(0); } /* edf_write_header_history */ /*+++------------------------------------------------------------------------ NAME edf_history_read_header SYNOPSIS int edf_history_read_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus); DESCRIPTION Reads all history lines from the header header_key and copies them to 'hline->key's. History lines have the keyword HISTORY_KEY_PREFIX'u', where 'u' is an unsigned positive integer. A new history line with the key HISTORY_KEY_PREFIX'last+1' and MaxHistoryLineSize bytes is created. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_read_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus) /*---*/ { HBlock *hblock; const char * history_line; char history_line_key_buffer[HistoryKeyBufferSize]; long depth=1; if (HIST_debug) printf("\n edf_history_read_header BEGIN\n"); int ErrorValue = RoutineSucceeded, status = status_error; if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) goto edf_history_read_header_error; if (clear_header_history ( hblock ) ) goto edf_history_read_header_error; sprintf(history_line_key_buffer,"%s%lu",HISTORY_KEY_PREFIX,depth++); while ( edf_search_header_element( header_key, history_line_key_buffer, &history_line, &ErrorValue, &status )) { if (status != status_success) goto edf_history_read_header_error; if (history_line_new( &hblock->history_line_root, history_line_key_buffer, STRLEN(history_line)+1, (HSymb **) NULL )) goto edf_history_read_header_error; if (history_line_add( &hblock->history_line_root, history_line_key_buffer, history_line)) goto edf_history_read_header_error; sprintf(history_line_key_buffer,"%s%lu",HISTORY_KEY_PREFIX,depth++); } /* save current history key */ if (hblock->current_history_line_key) free(hblock->current_history_line_key); hblock->current_history_line_key = newstr(history_line_key_buffer); if (HIST_debug) { printf(" history block key = %s\n",hblock->key); printf(" current_history_line_key = %s\n", hblock->current_history_line_key); print_history_list( stdout, 1, 1, hblock->history_argv_root ); print_history_list( stdout, 1, 1, hblock->history_line_root ); } ErrorValue = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_history_read_header END\n"); return(1); edf_history_read_header_error: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_history_read_header END (status=%d)\n",status); return(0); } /* edf_history_read_header */ /*+++------------------------------------------------------------------------ NAME edf_history_write_header SYNOPSIS int edf_history_write_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus ); DESCRIPTION Writes the history strings in 'history_line_root' into the date file header using the 'hline->key's as keywords. Writes the history string in 'history_argv_root' into the date file header using 'current_history_line_key' as keyword. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_write_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus) /*---*/ { HBlock * hblock; HSymb * next; int retval = 1; int ErrorValue = RoutineSucceeded, status = status_error; if (HIST_debug) printf("\n edf_history_write_header BEGIN\n"); if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) goto edf_history_write_header_error; if (HIST_debug) { printf(" history block key = %s\n",hblock->key); printf(" current_history_line_key = %s\n", hblock->current_history_line_key); print_history_list( stdout, 1, 1, hblock->history_argv_root ); print_history_list( stdout, 1, 1, hblock->history_line_root ); } /* history_argv_root */ if (( hblock->history_argv_root != (HSymb *) NULL ) && ( hblock->current_history_line_key != (char *) NULL ) && ( hblock->history_argv_root->line != (char *) NULL ) ) { /* write only non-empty history lines */ if (strlen(hblock->history_argv_root->line)>0) { /* remove not required arguments */ hblock->history_argv_root->line[hblock->history_argv_root->shortlen]='\0'; if (!( edf_add_header_element ( header_key, hblock->current_history_line_key, hblock->history_argv_root->line, &ErrorValue, &status ) ) ) goto edf_history_write_header_return; } } /* history_line_root */ next = hblock->history_line_root; while ( next!=(HSymb *) NULL ) { if (!( edf_add_header_element ( header_key, next->key, next->line, &ErrorValue, &status ) ) ) goto edf_history_write_header_return; next = next->Next; } ErrorValue = RoutineSucceeded; status = status_success; edf_history_write_header_return: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_history_write_header END\n"); return( retval ); edf_history_write_header_error: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (HIST_debug) printf("\n edf_history_write_header END (status=%d)\n",status); return(0); } /* edf_history_write_header */ /*+++------------------------------------------------------------------------ NAME edf_history_copy --- copies a history block SYNOPSIS int edf_history_copy ( const char * history_key_copy, const char * history_key ); DESCRIPTION Copies the history block history_key to a new or existing history block with the name history_key_copy. The existing contents of history_key_copy will be lost. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_copy ( const char * history_key_copy, const char * history_key ) /*---*/ { HBlock *hcopy, *hblock; if (HIST_debug) printf("\n edf_history_copy BEGIN\n"); if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) return(0); /* copy hblock to history_key_copy */ if (copy_history_block( history_key_copy, &hcopy, hblock )) return(0); if (HIST_debug) { printf(" copied history block\n"); printf(" history block key = %s\n",hcopy->key); printf(" current_history_line_key = %s\n", hcopy->current_history_line_key); print_history_list( stdout, 1, 1, hcopy->history_argv_root ); print_history_list( stdout, 1, 1, hcopy->history_line_root ); } if (HIST_debug) printf("\n edf_history_copy END\n"); return(1); } /* edf_history_copy */ /*+++------------------------------------------------------------------------ NAME edf_history_argv --- appends an argument to history line SYNOPSIS int edf_history_argv ( const char * history_key, const char * argument ) DESCRIPTION Appends argument to history line RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_history_argv ( const char * history_key, const char * argument ) /*---*/ { HBlock *hblock; char * buffer = (char *) NULL; if (HIST_debug) printf("\n edf_history_argv BEGIN\n"); if (!InitHistory) init_history(); /* search block ´history_key´ */ if (search_history_block( history_key, &hblock )) return(0); if (needquotes(argument)) { /* add double quotes */ if (!(buffer = (char *) malloc ( strlen(argument)+3 ))) return(0); sprintf(buffer,"\"%s\"",argument); if (history_line_add ( &hblock->history_argv_root, argv_key, buffer )) return(0); free(buffer); } else { /* do not add quotes */ if (history_line_add ( &hblock->history_argv_root, argv_key, argument )) return(0); } if (HIST_debug) { print_history_list( stdout, 1, 1, hblock->history_argv_root ); } if (HIST_debug) printf("\n edf_history_argv END\n"); return(1); } /* edf_history_argv */ /*+++------------------------------------------------------------------------ NAME edf_history_print SYNOPSIS int edf_history_print ( FILE * out, const char * history_key, int level, int verbose ) DESCRIPTION Prints contents of history ´history_key´ to ´out´, or contents of all histories, if ´history_key´ is NULL. RETURN VALUE 1: success 0: failed (specified history not found) ---------------------------------------------------------------------------*/ int edf_history_print ( FILE * out, const char * history_key, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - -"; HBlock * hblock, * stop = (HBlock*) NULL; if (HIST_debug) printf("edf_history_print\n"); if (level<1) return(0); if (!InitHistory) init_history(); if ( history_key != (const char *) NULL ) { // list a single history block if (search_history_block( history_key, &hblock )) return(0); if ( hblock == (HBlock *) NULL ) return(0); stop = hblock->Next; } else hblock = history_root; // list all history blocks while ( hblock != stop ) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," History block key = %s\n",hblock->key); fprintf(out," Previous Key = "); if ((hblock->Previous)!=(HBlock*) NULL) fprintf(out,"%s\n", hblock->Previous->key); else fprintf(out,"(no previous history block)\n"); fprintf(out," Next Key = "); if ((hblock->Next)!=(HBlock*) NULL) fprintf(out,"%s\n", hblock->Next->key); else fprintf(out,"(no next history block)\n"); print_history_list( out, level-1, verbose, hblock->history_line_root ); print_history_list( out, level-1, verbose, hblock->history_argv_root ); printf(" current_history_line_key = %s\n", hblock->current_history_line_key); } else { fprintf(out," History block key = %s\n",hblock->key); print_history_list( out, level-1, verbose, hblock->history_line_root ); print_history_list( out, level-1, verbose, hblock->history_argv_root ); printf(" current_history_line_key = %s\n", hblock->current_history_line_key); } hblock=hblock->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); if (HIST_debug) printf("\n edf_history_print END\n"); return(1); } /* edf_history_print */ /*===history END=============================================================*/ /****************************************************************************/ /*--------------------------------------------------------------------------- NAME renorm_data_array --- Convert data into a machine readable form SYNOPSIS MType mtype; int renorm_data_array ( DBlock * block, void * buffer, size_t buflen, int mtype, int * pErrorValue, int * pstatus ); DESCRIPTION Convert the data in ´block´ into a machine readable form of type ´mtype´. - endian correction - binary decompression (not implemented) - raster order normalization - conversion of data to mtype If ´buffer´ is not the NULL-pointer the converted data are always written to ´buffer´ and block->Flags.ExternalDataAlloc is set. ´buflen´ is the available memory in bytes. If the input data buffer was internally allocated it is released. If block->Flags.ExternalDataAlloc is set and ´buffer´ is NULL the converted data are written back to the input data buffer. No additional memory is allocated. The routine exits with an error if the buffer length is too small (DataBufferTooSmall). An endian correction is applied to the data if ByteOrder is different from the InternalByteOrder of the machine. The data is decompressed, raster order is normalized and the data are converted into a machine readable form (´mtype´). ERROR VALUES int * pErrorValue returned ErrorValue, int * pstatus return status HISTORY 01-Jan-2001 PB extracted from read_data_array --------------------------------------------------------------------------+*/ int renorm_data_array ( DBlock * block, void * buffer, size_t buflen, int mtype, int * pErrorValue, int * pstatus ) { static const char * RDA_Error = "ERROR: renorm_data_array:"; int internal_byte_order; void *als[4] = { (void *) NULL }; int i, alc = 0; long *data_dim; long data_value_offset; long raster_configuration; size_t data_size, data_len; unsigned long data_number; size_t data_buffer_len, data_out_len; void *current = (void*) NULL, *dest = (void*) NULL, *tmp; size_t current_len = (size_t) 0, dest_len = (size_t) 0, tmp_len; *pstatus = status_error; *pErrorValue = RoutineSucceeded; internal_byte_order = byteorder(); /* check whether ´block´ exists */ if (!block) return(-1); /* check, if data available */ if ( block->Flags.DataExternal ) { // data must be read first *pErrorValue = ExternalData; return(-1); } /* do not use buffer if it is identical to block->Data */ if (block->Data == buffer) { // do not use buffer buffer = (void *) NULL; buflen = (size_t) NULL; } /* get binary data description */ data_value_offset = block->DataValueOffset; raster_configuration = block->DataRasterConfiguration; if (!block->DataDim) { *pErrorValue = MissingArrayDimensions; return(-1); } data_dim = block->DataDim; data_size = edf_data_sizeof ( block->DataType ); data_number = edf_dim_product ( data_dim ); data_len = data_size * data_number ; data_buffer_len = block->DataBufferLen; data_out_len = edf_machine_sizeof(mtype)*data_number; /* test output buffer size */ if ( buffer == (void *) NULL ) { if (block->Flags.ExternalDataAlloc) { // use input data buffer for output if (data_buffer_lenData; current_len = data_buffer_len; /* --- endian correction */ if ( block->DataByteOrder != internal_byte_order ) edf_bswap ( current, current, data_size, data_number ); block->DataByteOrder = internal_byte_order; /* --- raster order normalization */ if (block->DataRasterConfiguration!=1l) { /* input and output memory must be different, allocate new memory */ dest_len = data_len; if (!(dest = malloc( dest_len ))) { *pErrorValue = CouldNotMallocMemory; // fprintf(stderr,"%s malloc of %zu bytes failed\n",RDA_Error,dest_len);return(-1); fprintf(stderr,"%s malloc of %zu | %lu bytes failed\n", RDA_Error,dest_len,dest_len);return(-1); } als[alc++] = dest; // add allocated memory if (raster_normalization ( dest, current, data_dim, raster_configuration, data_size, NULL)) { for ( i=alc; i>0; --i ) if (als[i]) free(als[i]); return(-1); } tmp = current; current = dest; dest = tmp; tmp_len = current_len; current_len = dest_len; dest_len = tmp_len; } /* if (raster_configuration!=1) */ block->DataRasterConfiguration = 1l; /* last step, if ´buffer´ is set destination should be buffer, otherwise destination should be ´block->Data´, source is ´current´ */ if ( buffer==(void *) NULL ) { dest = block->Data; dest_len = data_buffer_len; } else { dest = buffer; dest_len = buflen; if (dest_len0; --i ) if (als[i]) free(als[i]); *pErrorValue = CouldNotMallocMemory; // fprintf(stderr,"%s malloc of %zu bytes failed\n",RDA_Error,dest_len);return(-1); fprintf(stderr,"%s malloc of %zu | %lu bytes failed\n", RDA_Error,dest_len,dest_len); return(-1); } als[alc++] = dest; // add allocated memory } /* if (dest_len ... */ if ( edf_machine2machine ( dest, mtype, current, data_value_offset, edf_datatype2machinetype(block->DataType), data_number ) ) { for ( i=alc; i>0; --i ) if (als[i]) free(als[i]); *pErrorValue = DataConversionFailed; return(-1); } if ( dest!=block->Data ) { // relink new memory // release only internally allocated data buffer if (!block->Flags.ExternalDataAlloc) free(block->Data); block->Data = dest; block->DataBufferLen = dest_len; if (dest==buffer) block->Flags.ExternalDataAlloc = True; else block->Flags.ExternalDataAlloc = False; /* remove from allocated memory list */ for ( i=alc; i>0; --i ) if (als[i]==dest) als[i]=(void *) NULL; } /* update data block description */ block->DataLen = data_out_len; block->DataValueOffset = 0l; block->DataType = InValidDType; block->Flags.DataExternal = True; /* release temporary memory */ for ( i=alc; i>0; --i ) if (als[i]) free(als[i]); *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(0); } /* renorm_data_array */ /*--------------------------------------------------------------------------- NAME read_data_array --- read data array (raw, without conversion) SYNOPSIS int read_data_array ( DBlock * block, void *buffer, size_t buflen, int must_use_buffer, long dim[], int * pErrorValue, int * pstatus ) DESCRIPTION Reads a data array from the block ´DataNumber´ in ´DataChain´. If ( block->DataExternal ) the data is read from the file, if not, it is taken directy from ´block´. buffer is an optional data buffer. If buffer!=NULL buflen describes the available memory in bytes and ´must_use_buffer´ is a flag that indicates whether this buffer must be used or whether it is optional. The data are written to buffer. If its size is too short and the flag ´must_use_buffer´ is set the routine stops with an error, otherwise an internal buffer with correct length is allocated. If buffer is NULL internal memory is always allocated. Internally allocated memory is released automatically after the next write, when a different data block is accessed. or when the stream is closed. If dim!=NULL the dimension array is copied to dim. The first element dim[0] must contain the maximum image dimension, e.g. 2 for a 2d array. If dim is too short the routine exits with an error. In all other cases a correct dimension array is allocated and available in block->DataDim. PARAMETERS DBlock * block Current data block void *buffer Data buffer input: buffer == NULL -> memory allocated and pointer returned buffer != NULL -> up to buflen bytes are written to *buffer (buflen is data buffer size in bytes) If ´must_use_buffer´ is False memory is allocated if external buffer is too short. size_t buflen Size of input data buffer in bytes. int must_use_buffer True: use always the supplied buffer Fallse: use supplied buffer only if it is big enough long dim[] Optional dimension array for output dim[0] length of the dimension array dim[1] length of dimension 1 ... dim[dim[0]] length of last dimension input: dim == NULL -> not used dim != NULL -> data array dimension is copied to dim. dim[0] must contain the dimensions. dim[0] dimensions. Unused dimensions are set to 1, error if too short. ERROR VALUES int * pErrorValue returned ErrorValue, only used when *pstatus!=status_success. CouldNotGetBinaryArray: routine get_binary_array failed. int * pstatus return status AUTHOR 05-Mar-1998 Peter Boesecke 30-Apr-1998 PB no conversion for ConversionType==0, parameter pDataType added 23-Jul-1999 PB data_value_offset_in added 30-Apr-2000 PB Parameter ConversionType renamed to mtype 12-Nov-2000 PB DataDim is not unlinked any more 12-Nov-2000 PB DBlock * block instead of DataChain etc. 01-Jan-2001 PB totally redesigned, no conversion any more --------------------------------------------------------------------------+*/ int read_data_array ( DBlock * block, void *buffer, size_t buflen, int must_use_buffer, long dim[], int * pErrorValue, int * pstatus ) { *pstatus = status_error; *pErrorValue = RoutineSucceeded; /* check whether ´block´ exists */ if (!block) return(-1); /* get data array */ if ( block->Flags.DataExternal ) { if ( get_binary_array ( block, buffer, buflen, must_use_buffer ) ) { *pErrorValue = CouldNotGetBinaryArray; return(-1); } } /* copy dimensions to dim */ if (dim) { // copy dimensions to dim if ( !(copydim( dim, dim[0], block->DataDim ) ) ) { *pErrorValue = NotNdData; return(-1); } } *pstatus = status_success; *pErrorValue = RoutineSucceeded; return(0); } /* read_data_array */ /****************************************************************************/ /*--------------------------------------------------------------------------- NAME free_data_file --- deallocates and reinitializes an edf file. SYNOPSIS int free_data_file ( DFile * file ); DESCRIPTION Deallocates all memory of a DFile. If it is already done nothing happens. RETURN VALUE success: int 0 error: int -1 ---------------------------------------------------------------------------*/ int free_data_file ( DFile * file ) { /* remove chainlist */ if (free_data_chain_list( file )) return(-1); /* close file */ if (file->Channel!=NULL) if (fclose(file->Channel)) return(-1); file->Channel = (FILE *) NULL; /* release IO-buffer */ if (file->Buffer!=NULL) free(file->Buffer); file->Buffer = (char *) NULL; /* release file name */ if (file->Name!=NULL) free(file->Name); file->Name = (char *) NULL; init_file ( file ); return(0); } /* free_data_file */ /*--------------------------------------------------------------------------- NAME open_as_bsl_file --- reads the file as a bsl file SYNOPSIS int open_as_bsl_file ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ); DESCRIPTION Opens ´fname´ as a BSL file and, if successful, creates an edf file structure with chains corresponding to bsl memories and data blocks corresponding to bsl frames. The translation is done in the following way: memnum franum chain key block key block id 1 n image.psd n n.image.psd m n image.m n n.image.m The data block headers exist only in memory, they are not read a second time from the file. The only allowed opening mode is ´Old´. ERROR VALUES *pErrorValue *pstatus RETURN VALUE success: int stream (Channel not opened) error: int -1 ---------------------------------------------------------------------------*/ int open_as_bsl_file ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ) { int stream=-1, bsl_stream; long memnum, minmem, maxmem; long franum, minfra, maxfra; BslDataSpec *data_spec; char *first_header, *second_header; char chain_key[MaxKeyLen+1]; char block_key[MaxKeyLen+1]; char symbol_key[MaxKeyLen+1]; char symbol_value[MaxValLen+1]; DFile * file; DChain * chain; DBlock * block; SElement * symbol; int i; *pstatus = status_error; *pErrorValue = RoutineSucceeded; if (EDFIO_debug) printf("open_as_bsl_file\n"); if ( (STRCMP(mode,Old)!=0) && (STRCMP(mode,Read)!=0) ) { *pErrorValue = CannotOpenAsBslFile; return ( stream ); } if (!InitTable) init_file_table( FileTable ); if ( ( stream=search_free_stream( FileTable ) ) < 0 ) { *pErrorValue = NoMoreStreamsAvailable; return(-1); } if (EDFIO_debug) printf("\"%s\" : stream = %d (%s)\n",fname,stream,mode); file = &FileTable[stream]; init_file ( file ); file->Used = True; if ( !(file->Name = newstr( fname ) ) ) return(-1); /* set general flags */ file->Flags.NoGeneralHeader = True; /* create general header */ if ( new_general_block( file ) ) { *pErrorValue = ErrorCreatingGeneralBlock; return(-1); } bsl_stream = open_bsl_file ( fname , "read" ); if (bsl_stream<0) { *pErrorValue = CannotOpenAsBslFile; return( stream ); } /* create edf file structure */ read_bsl_file_headers( bsl_stream, &first_header, &second_header ); if (EDFIO_debug) print_bsl_filetable ( stdout, 4, True ); insert_string ( file->GeneralBlock, "Title", first_header, &symbol ); insert_string ( file->GeneralBlock, "SubTitle", second_header, &symbol ); if (bsl_memory_range( bsl_stream, &minmem, &maxmem )) return(-1); for (memnum = minmem; memnum<=maxmem; memnum++) { if (bsl_frame_range( bsl_stream, memnum, &minfra, &maxfra )) return(-1); if (!(default_chain_key(chain_key, memnum))) return(-1); if ( insert_data_chain( file, chain_key, &chain ) ) return(-1); for (franum = minfra; franum<=maxfra; franum++) { data_spec = read_bsl_data_spec ( bsl_stream, memnum, franum ); if (!data_spec) return(-1); sprintf( block_key, "%ld", franum); if ( insert_data_block( chain, block_key, &block ) ) return(-1); block->Flags.InternalHeader = True; block->Flags.DataExternal = True; block->BinaryFileName = newstr(data_spec->BinaryFileName); block->BinaryFilePos = data_spec->BinaryFilePos; block->BinaryFileLen = data_spec->BinaryFileLen; for (i=1;i<=data_spec->Dim[0];i++) { sprintf(symbol_key,"%s%1u",DIMENSION_KEY_PREFIX,i); long2s(symbol_value,data_spec->Dim[i]); if (insert_string ( block, symbol_key, symbol_value, &symbol )) return(-1); } if (insert_string ( block, DATA_TYPE_KEY, edf_datatype2string( data_spec->DataType ), &symbol )) return(-1); if ( bsl_input_byteorder == InValidBOrder ) { if (insert_string ( block, BYTE_ORDER_KEY, ByteOrder2String( data_spec->ByteOrder ), &symbol )) return(-1); } else { if (insert_string ( block, BYTE_ORDER_KEY, ByteOrder2String( bsl_input_byteorder ), &symbol )) return(-1); } if (data_spec->RasterConfiguration!=1l) { sprintf(symbol_value,"%ld",data_spec->RasterConfiguration); if (insert_string ( block, RASTER_CONFIGURATION_KEY, symbol_value, &symbol ) ) return(-1); } if (insert_string ( block, COMPRESSION_KEY, edf_compression2string( data_spec->Compression ), &symbol )) return(-1); } /* for franum */ } /* for memnum */ if (close_bsl_file ( bsl_stream )) return(-1); /* open existing file read only */ file->Channel = fopen( fname,"rb"); file->Flags.ExistingFile = True; file->Flags.ReadOnlyFile = True; *pstatus = status_success; *pErrorValue = RoutineSucceeded; return (stream); } /* open_as_bsl_file */ /*--------------------------------------------------------------------------- open_as_edf_file Open the file 'fname' with mode "new", "old", "any", "read" and "temp" return a stream (success: 0 .. MaxFiles-1, error: -1); --------------------------------------------------------------------------+*/ int open_as_edf_file ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ) /*---*/ { int stream; int locate_status; DFile * file; DBlock * block; *pstatus = status_error; *pErrorValue = RoutineSucceeded; if (EDFIO_debug) printf("open_as_edf_file\n"); if (!InitTable) init_file_table( FileTable ); if ( ( stream=search_free_stream( FileTable ) ) < 0 ) { *pErrorValue = NoMoreStreamsAvailable; return(-1); } if (EDFIO_debug) printf("\"%s\" : stream = %d (%s)\n",fname,stream,mode); file = &FileTable[stream]; init_file ( file ); file->Used = True; if ( !(file->Name = newstr( fname ) ) ) return(-1); if (STRCMP(mode,Old)==0) { /* open old file */ file->Channel = fopen( fname,"rb+"); file->Flags.ExistingFile = True; file->Flags.ReadOnlyFile = False; } else if (STRCMP(mode,New)==0) { /* open new file */ file->Channel = fopen( fname,"wb+"); file->Flags.ExistingFile = False; file->Flags.ReadOnlyFile = False; } else if (STRCMP(mode,Any)==0) { /* open old file or create new file */ if ( (file->Channel = fopen( fname,"rb+")) ) { file->Flags.ExistingFile = True; file->Flags.ReadOnlyFile = False; } else { file->Channel = fopen( fname,"wb+"); file->Flags.ExistingFile = False; file->Flags.ReadOnlyFile = False; } } else if (STRCMP(mode,Read)==0) { /* open old file */ file->Channel = fopen( fname,"rb"); file->Flags.ExistingFile = True; file->Flags.ReadOnlyFile = True; } if (STRCMP(mode,Temp)==0) { /* open internal temporary file */ file->Flags.TemporaryFile = True; file->Channel = (FILE *) NULL; } else { // open i/o-channel of non-temporary files if (file->Channel == (FILE *) NULL) { *pErrorValue = CouldNotOpenFile; return(-1); } /* allocate IO-buffer */ file->Buffer = (char *) malloc(BufferSize*sizeof(char)); if ( file->Buffer == (char *) NULL ) { *pErrorValue = CouldNotMallocMemory; return(-1); } if ( setvbuf(file->Channel, file->Buffer, _IOFBF, BufferSize) ) { *pErrorValue = CouldNotSetBuffer; return(-1); } } /* read general header */ if ( new_general_block( file ) ) { *pErrorValue = ErrorCreatingGeneralBlock; return(-1); } if ( file->Flags.ExistingFile ) { if ( !read_general_block( file ) ) { /* This must be an EDF file */ if ( !file->Flags.NoGeneralHeader ) file->LastBlockInFile = file->GeneralBlock; /* Update sequence number of general block */ if (!file->Flags.NoGeneralHeader) file->GeneralBlock->SequenceNumber = file->NextSequenceNumber++; /* locate data blocks */ locate_status = locate_block( file , &block ); while ( !locate_status ) { file->LastBlockInFile = block; block->SequenceNumber = file->NextSequenceNumber++; locate_status = locate_block( file , &block ); } /* verify that end of file is reached */ if ( locate_status<0 ) { /* fatal error */ *pErrorValue = ErrorLocatingBlocks; return(-1); } } else { if (free_data_file ( file )) { *pErrorValue = CouldNotCloseFile; return(-1); }; *pErrorValue = ErrorReadingGeneralBlock; return(-1); } /* if read_general_block */ } else file->GeneralBlock->Flags.HeaderChanged = True; /* check, if something is in the file */ if (STRCMP(mode,Old)==0) /* open old file */ if (!file->LastBlockInFile) { *pstatus = status_error; *pErrorValue = CouldNotFindHeader; return(-1); } *pstatus = status_success; return(stream); } /* open_as_edf_file */ /*--------------------------------------------------------------------------- NAME data_file_type --- returns the data file type SYNOPSIS int data_file_type ( const char *fname ); DESCRIPTION Checks file 'fname' and checks its start bytes with check_header for a header start of an edf file. If it fails, the file name is checked for a bsl type file. If the file starts with the following sequence, it is opened as an edf type file. '\r' '\n' 'StartHeader´ '\n' 'StartHeader´ 'StartHeader´ REMARK All V2.0 Edf files must start with the following sequence '\n', StartHeader, '\r', '\n', "DATA_FORMAT_PREFIX". The first 8 bytes for a version 2.0 edf data file look today explicitely (22-Mar-1998): 1 2 3 4 5 6 7 8 '\n' '{' '\r' '\n' 'E' 'D' 'F' '_' ARGUMENT const char * fname filename int * pErrorValue error value on exit int * pstatus status on exit RETURN VALUE success: int stream error: int -1 HISTORY 22-Mar-1998 Peter Boesecke 11-Jul-2001 PB accepts empty files as edf files --------------------------------------------------------------------------+*/ int data_file_type ( const char * fname, int *pErrorValue, int *pstatus ) { int dftype = InValidDFType; FILE * channel; *pstatus = status_error; if (!(channel = fopen( fname, "rb" ))) { *pErrorValue = CouldNotOpenFile; return(dftype); } /* check for edf file */ switch ( check_start( channel ) ) { case 0: dftype = EdfType; break; case -1: dftype = EdfType; break; // empty edf file default: dftype = BslType; // check for bsl file name } fclose ( channel ); *pstatus = status_success; *pErrorValue = RoutineSucceeded; return( dftype ); } /* data_file_type */ /*+++------------------------------------------------------------------------ NAME edf_open_data_file --- open file 'fname' with new, old, any, read or temp SYNOPSIS int edf_open_data_file ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ); DESCRIPTION Opens the file 'fname' with mode "new", "old", "any" or "read" and return a stream (success: 0 .. MaxFiles-1, error: -1). "new": open a new file for read/write, an existing file with the same name is overwritten "old": open an existing file for read/write and check file format "any": open either an existing file and check its file format or open a new file for read/write "read": open an existing file for read and check its file format "temp": open a new temporary file If an existing file is opened with "old", "any" or "read" its file start marker is checked and, according to it, it is opened as an edf file or a bsl file. A temporary file is newer written to disk or read from disk. It can only be accessed internally and it disappears after edf_close. Attention, a temporary file is entirely kept in memory until it is closed. RETURN VALUE success: int stream error: int -1 HISTORY 22-Mar-1998 Peter Boesecke 05-Aug-2001 PB temporary file --------------------------------------------------------------------------+*/ int edf_open_data_file ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ) /*---*/ { int stream; int ErrorValue = RoutineSucceeded, status = status_error; if (EDFIO_debug) printf("edf_open_data_file BEGIN\n"); if ( (STRCMP(mode,Old)==0) || (STRCMP(mode,Read)==0) ) { /* open old file */ switch (data_file_type ( fname, &ErrorValue, &status )) { case EdfType: stream = open_as_edf_file ( fname, mode, &ErrorValue, &status ); break; case BslType: stream = open_as_bsl_file ( fname, mode, &ErrorValue, &status ); break; default: /* unknown data file type */ stream = -1; status = status_error; }; } else stream = open_as_edf_file ( fname, mode, &ErrorValue, &status ); if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_open_data_file END (status=%d)\n",status); if (EDFIO_debug) edf_print_filetable( stdout, 4, True ); return( stream ); } /* edf_open_data_file */ /*+++------------------------------------------------------------------------ NAME check_mode --- check, whether opening mode mode is compatible with stream SYNOPSIS int check_mode( int stream, int mode ); DESCRIPTION RETURN VALUE compatible : 0 incompatible: -1 HISTORY 06-Jul-2001 Peter Boesecke --------------------------------------------------------------------------+*/ int check_mode( int stream, const char * mode ) { int value=-1; unsigned short ef, ro; if ( (stream<0)||(stream>=MaxFiles) ) return(value); ef = FileTable[stream].Flags.ExistingFile; ro = FileTable[stream].Flags.ReadOnlyFile; if (!STRCMP(mode,Read)) { value = 0; // any file is readable } else if (!STRCMP(mode,Old)) { if ( ef && (!ro) ) value=0; // file must exist and not be write protected } else if (!STRCMP(mode,New)) { if ((!ef) && (!ro)) value = 0; // must have been opened with new } else if (!STRCMP(mode,Any)) { if (!ro) value = 0; // must not be write protected } return(value); } // check_mode /*+++------------------------------------------------------------------------ NAME edf_search_stream --- check, whether data file is already opened SYNOPSIS int edf_search_stream ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ); DESCRIPTION If a file called fname is already opened the function returns its stream, otherwise -1. If a file is already opened with an incompatible opening mode the error IncompatibleOpeningMode is returned together with the stream. RETURN VALUE success: int stream error: int -1 HISTORY 05-Jul-2001 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_search_stream ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ) { int stream; int ErrorValue=RoutineSucceeded, status=status_success; if (EDFIO_debug) printf("edf_search_stream BEGIN\n"); if (!InitTable) init_file_table( FileTable ); stream=search_stream( FileTable, fname ); if ( (stream>=0)&&(stream=0)&&(streamActiveBlock, &ErrorValue ) ) goto edf_close_data_file_error; /* update active block */ file->ActiveBlock = (DBlock *) NULL; if (free_data_file ( file )) { status=status_error; ErrorValue = CouldNotCloseFile; goto edf_close_data_file_error; } } // if stream ErrorValue = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_close_data_file END\n"); return; edf_close_data_file_error: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_close_data_file END (status=%d)\n",status); return; } /* edf_close_data_file */ /*+++------------------------------------------------------------------------ NAME edf_free_data_file --- close all edf data files SYNOPSIS int edf_free_data_file ( void ); DESCRIPTION Closes all edf data files and releases all allocated memory buffers. --------------------------------------------------------------------------+*/ int edf_free_data_file ( void ) /*---*/ { int i; for (i=0;iData = pData; block->Flags.ExternalDataAlloc = True; block->DataLen = edf_data_sizeof(DataType) * edf_dim_product(Dim); block->DataBufferLen = block->DataLen; block->DataType = DataType; block->DataValueOffset = DataValueOffset; block->DataByteOrder = ByteOrder; block->DataRasterConfiguration = RasterConfiguration; block->DataCompression = DataCompression; block->DataDim = newcopydim(Dim); /* write compulsary keywords */ /* --- Array Dimensions */ for (idim = 1l; idim <= Dim[0]; idim++) { /* write DIM_idim */ sprintf(KeyBuf,"%s%lu",DIMENSION_KEY_PREFIX,idim); long2s(ValBuf,Dim[idim]); if (insert_string( block, KeyBuf, ValBuf, &symbol) ) { errval=CouldNotWriteDimension; goto edf_write_data_raw_error; } } /* --- DataType */ if (insert_string( block, DATA_TYPE_KEY, edf_datatype2string( DataType ), &symbol) ) { errval=CouldNotWriteBinary; goto edf_write_data_raw_error; } /* --- DataValueOffset */ if (DataValueOffset!=0l) { /* write only if not zero, otherwise remove */ if (insert_string( block, DATA_VALUE_OFFSET_KEY, long2s(ValBuf,DataValueOffset), &symbol) ) { errval=CouldNotWriteBinary; goto edf_write_data_raw_error; } } else { /* remove if zero */ if (remove_symbol( block, DATA_VALUE_OFFSET_KEY , NULL )) { errval=CouldNotWriteBinary; goto edf_write_data_raw_error; } } /* --- ByteOrder */ if (insert_string( block, BYTE_ORDER_KEY, ByteOrder2String( ByteOrder ), &symbol) ) { errval=CouldNotWriteBinary; goto edf_write_data_raw_error; } /* --- RasterConfiguration */ if (RasterConfiguration!=1l) { // only compulsary for RasterConfiguration!=1 if (insert_string( block, RASTER_CONFIGURATION_KEY, long2s(ValBuf,RasterConfiguration), &symbol) ) { errval=CouldNotWriteBinary; goto edf_write_data_raw_error; } } else { /* remove if 1 */ if (remove_symbol( block, RASTER_CONFIGURATION_KEY, NULL )) { errval=CouldNotWriteBinary; goto edf_write_data_raw_error; } } /* --- Compression */ if (insert_string( block, COMPRESSION_KEY, edf_compression2string( DataCompression ), &symbol) ) { errval=CouldNotWriteBinary; goto edf_write_data_raw_error; } /* end of compulsary keywords */ /* close output to block */ if ( close_write_block( block, &errval ) ) goto edf_write_data_raw_error; block->Flags.HeaderChanged = True; block->Flags.DataChanged = True; /* write active data block to disk (this block) immediately */ if ( disk_write_block ( block->Chain->File->ActiveBlock, &errval ) ) goto edf_write_data_raw_error; /* update ActiveBlock */ block->Chain->File->ActiveBlock = (DBlock *) NULL; errval = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_write_data_raw END\n"); return; edf_write_data_raw_error: status=status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) { printf("edf_write_data_raw: %s",edf_report_data_error ( errval )); printf("edf_write_data_raw END (status=%d)\n",status); } return; } /* edf_write_data_raw */ /*+++------------------------------------------------------------------------ NAME edf_write_data --- Write n-dimensional machine data array SYNOPSIS void edf_write_data ( int stream, long DataNumber, int DataChain, const long Dim[], void *pData, int MachineType, int * pErrorValue, int *pstatus ); DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. If it does not exists, it is created. Writes an n-dimensional MachineType data array as binary data after the end of the header. MachineType is translated to the corresponding data type. If this is not possible, the data is converted into another data type. The data array is specified by Dim and MachineType. Default values are used for DataValueOffset (0), ByteOrder (internal order) and RasterConfiguration (1). All (non-default) informations are written into the header. Parameters: void *pData (i) pointer to the start of the data array const long Dim[0] (i) N, number of dimensions Dim[1] (i) dimension 1 Dim[2] (i) dimension 2 ... Dim[N] (i) dimension N --------------------------------------------------------------------------+*/ void edf_write_data ( int stream, long DataNumber, int DataChain, const long Dim[], void *pData, int MachineType, int * pErrorValue, int *pstatus ) /*---*/ { int DataTypeOut; int MachineTypeOut; long DataValueOffsetOut = data_value_offset_out; int ByteOrder = 0; long RasterConfiguration = 1l; void *DataOut = pData; // default long DataCount; void *tmp = (void *) NULL; int errval, status; if (EDFIO_debug) printf("edf_write_data BEGIN\n"); ByteOrder = byteorder(); /* get output data type */ if (data_type_out==InValidDType) { /* do not convert */ DataTypeOut = edf_machinetype2datatype( MachineType ); MachineTypeOut = MachineType; } else { /* convert */ DataTypeOut = data_type_out; /* get machine type of output data type */ MachineTypeOut = edf_datatype2machinetype( DataTypeOut ); } /* get number of array elements */ DataCount = edf_dim_product ( Dim ); if (EDFIO_debug) { edf_showmachinetypes( True ); printf("Save %s as %s (%s)\n", MachineType2String( MachineType ), edf_datatype2string( DataTypeOut ), MachineType2String( MachineTypeOut) ); } // EDFIO_debug if ( (MachineTypeOut!=MachineType) || (DataValueOffsetOut!=0l) ) { /* allocate new memory */ if (!(tmp = malloc( edf_machine_sizeof(MachineTypeOut) * DataCount ) )) { errval=CouldNotMallocMemory; goto edf_write_data_error; } DataOut = tmp; /* convert to MachineTypeOut */ if ( edf_machine2machine ( DataOut, MachineTypeOut, pData, -DataValueOffsetOut, MachineType, DataCount ) ) { errval=DataConversionFailed; goto edf_write_data_error; } } // if MachineTypeOut!=MachineType edf_write_data_raw ( stream, DataNumber, DataChain, Dim, DataOut, DataTypeOut, DataValueOffsetOut, ByteOrder, RasterConfiguration, &errval, &status ); if ( status != status_success ) goto edf_write_data_error; /* free tmp array */ if (tmp) { free(tmp); tmp=(void *) NULL; } errval=RoutineSucceeded; status=status_success; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_write_data END\n"); return; edf_write_data_error: if (tmp) { free(tmp); tmp=(void *) NULL; } status = status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) { printf("edf_write_data: %s",edf_report_data_error ( errval )); printf("edf_write_data END (status=%d)\n",status); } return; } /* edf_write_data */ /*+++------------------------------------------------------------------------ NAME edf_read_header_line --- reads a line SYNOPSIS int edf_read_header_line ( int stream, long int DataNumber, int DataChain, const char * keyword, char * Value, int * pErrorValue, int * pstatus ); DESCRIPTION Searches for 'keyword' in the header 'DataNumber' in 'DataChain'. If the header or the keyword does not exists, the return value is 0 and a specific error value is returned. This error is not fatal and can be used as a test for the existence of the keyword or the header. The ´Value´ string specified by ´keyword´ is copied after the location pointed to by Value. The minimum allocated size for Value must be MaxValLen+1. The function has not changed Value when the return value is 0. RETURN VALUE return value FALSE if not found and no other error return( int ) FALSE : data header not found, *pstatus = status_error; *pErrorValue=(CouldNotFindHeader, RoutineSucceeded); TRUE : data header found or error, *pstatus = Success or status_error; *pErrorValue = --------------------------------------------------------------------------+*/ int edf_read_header_line ( int stream, long int DataNumber, int DataChain, const char * keyword, char * Value, int * pErrorValue, int * pstatus ) /*---*/ { const char *hstring; *pErrorValue = RoutineSucceeded; *pstatus = status_error; if (!(read_header_string ( stream, DataNumber, DataChain, keyword, &hstring, pErrorValue, pstatus ))) return(0); if (*pstatus != status_success) return(1); /* copy header value to output line value */ strncpy( Value, hstring, MaxLinLen ); Value[MaxLinLen] = '\0'; *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(1); } /* edf_read_header_line */ /*+++------------------------------------------------------------------------ NAME edf_read_header_string --- reads a string from the header SYNOPSIS int edf_read_header_string ( int stream, long int DataNumber, int DataChain, const char * keyword, const char ** pValue, int * pErrorValue, int * pstatus ); DESCRIPTION Searches for 'keyword' in the header 'DataNumber' in 'DataChain'. If the header or the keyword does not exists, the return value is 0 and a specific error value is returned. The returned String pointer is NULL. This error is not fatal and can be used as a test for the existence of the keyword or the header. In case of success *pValue points to an internal character string that contains the concatenated string of all continuation lines. Because the length of *pValue depends on the sum of the lengths of all continuation lines its size is theoretically unlimited. RETURN VALUE In case of a failure the returned *pValue pointer can be NULL. return value FALSE if not found and no other error, return( int ) FALSE : data header not found, *pstatus = status_error; *pErrorValue=(CouldNotFindHeader, RoutineSucceeded); TRUE : data header found or error, *pstatus = Success or status_error; *pErrorValue = --------------------------------------------------------------------------+*/ int edf_read_header_string ( int stream, long int DataNumber, int DataChain, const char * keyword, const char ** String, int * pErrorValue, int * pstatus ) /*---*/ { *pErrorValue = RoutineSucceeded; *pstatus = status_error; if (!(read_header_string ( stream, DataNumber, DataChain, keyword, String, pErrorValue, pstatus ))) return(0); if (*pstatus != status_success) return(1); *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(1); } /* edf_read_header_string */ /*+++------------------------------------------------------------------------ NAME edf_read_header_float --- reads a float value SYNOPSIS int edf_read_header_float ( int stream, long int DataNumber, int DataChain, const char * keyword, float * Value, int * pErrorValue, int * pstatus ); DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. In this headers it searches for 'keyword'. If the header or the keyword do not exists, the return value is 0 and a specific error value is returned. This error is not fatal and can be used as a test for the existence of the keyword or the header. A pointer to the float value specified by 'keyword' is returned in 'Value'. The function has not changed Value when the return value is 0. RETURN VALUE return value FALSE if not found and no other error return( int ) FALSE : data header not found, *pstatus = status_error; *pErrorValue=(CouldNotFindHeader, RoutineSucceeded); TRUE : data header found or error, *pstatus = Success or status_error; *pErrorValue = --------------------------------------------------------------------------+*/ int edf_read_header_float ( int stream, long int DataNumber, int DataChain, const char * keyword, float * Value, int * pErrorValue, int * pstatus ) /*---*/ { const char *hstring; int errval; *pErrorValue = RoutineSucceeded; *pstatus = status_error; if (!(read_header_string ( stream, DataNumber, DataChain, keyword, &hstring, pErrorValue, pstatus ))) return(0); if (*pstatus != status_success) return(1); /* copy header value to output float value */ *Value = ( float ) num_str2double( hstring, NULL, &errval ); if (errval) { // num_errval2str( errbuf, errbuflen, errval ); ++++++++++ get details *pErrorValue = NumberConversionFailed; *pstatus = status_error; } else { *pErrorValue = RoutineSucceeded; *pstatus = status_success; } return(1); } /* edf_read_header_float */ /*+++------------------------------------------------------------------------ NAME edf_read_header_long --- reads a long integer value SYNOPSIS int edf_read_header_long ( int stream, long int DataNumber, int DataChain, const char * keyword, long int * Value, int * pErrorValue, int * pstatus ); DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. In this headers it searches for 'keyword'. If the header or the keyword do not exists, the return value is 0 and a specific error value is returned. This error is not fatal and can be used as a test for the existence of the keyword or the header. A pointer to the long int value specified by 'keyword' is returned in 'Value'. The function has not changed Value when the return value is 0. RETURN VALUE return value FALSE if not found and no other error return( int ) FALSE : data header not found, *pstatus = status_error; *pErrorValue=(CouldNotFindHeader, RoutineSucceeded); TRUE : data header found or error, *pstatus = Success or status_error; *pErrorValue = --------------------------------------------------------------------------+*/ int edf_read_header_long ( int stream, long int DataNumber, int DataChain, const char * keyword, long int * Value, int * pErrorValue, int * pstatus ) /*---*/ { const char *hstring; int errval; *pErrorValue = RoutineSucceeded; *pstatus = status_error; if (!(read_header_string ( stream, DataNumber, DataChain, keyword, &hstring, pErrorValue, pstatus ))) return(0); if (*pstatus != status_success) return(1); /* copy header value to long value */ *Value = num_str2long( hstring, NULL, &errval ); if (errval) { // num_errval2str( errbuf, errbuflen, errval ); ++++++++++ get details *pErrorValue = NumberConversionFailed; *pstatus = status_error; } else { *pErrorValue = RoutineSucceeded; *pstatus = status_success; } return(1); } /* edf_read_header_long */ /*+++------------------------------------------------------------------------ NAME edf_read_data_raw --- reads 2d data without type conversion SYNOPSIS void edf_read_data_raw ( int stream, long int DataNumber, int DataChain, long **pDim, size_t * pDataArraySize, void **ppData, int * pDataType, long * pDataValueOffset, int * pByteOrder, long * pRasterConfiguration, int * pErrorValue, int * pstatus ); DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. If it does not exist the routine stops with an error. A data array with the dimension Data[(*pDim)[1],(*pDim)[2],...] is read from the file. The pointer &&Data[0,0] is returned in ppData. The data type, the data value offset, the byte order and the raster configuration of the array are returned. The returned array has a length of *pDataArraySize bytes. The data buffer is allocated and must be released explicitly. ARGUMENTS (If memory allocated for the dimension array otherwise *pDim=0) long (*pDim)[0] (i) number of dimensions N (*pDim)[1] (o) dimension 1 (*pDim)[2] (o) dimension 2 ... (*pDim)[N] (o) dimension N If the supplied *pDim is the NULL pointer a pointer to an allocated dimension array is returned, otherwise the dimensions are copied to the array (*pDim)[]. (*pDim)[0] must contain the dimension, e.g. 2 for a 2d data array. The dimension array must have N+1 elements, e.g. 3 elements for a 2d-array. The first element of the dimension array defines always the number of dimensions and is not changed. Remaining dimensions are set to 1. If the supplied dimension array is too short an error is returned (NotNdData). The internally allocated memory for (*pDim) is released automatically during the next data-i/o or when the file is closed. size_t * pDataArraySize (o) size of the data array in bytes void ** pData (o) pointer to the pointer of the data array long * pDataValueOffset (o) data value offset of the array elements int * pDataType (o) data type of the array elements (DType) HISTORY 23-Jul-1999 PB pDataValueOffset, pByteOrder and pRasterConfiguration added 29-Dec-2000 PB total redesign --------------------------------------------------------------------------+*/ void edf_read_data_raw ( int stream, long int DataNumber, int DataChain, long **pDim, size_t * pDataArraySize, void **ppData, int * pDataType, long * pDataValueOffset, int * pByteOrder, long * pRasterConfiguration, int * pErrorValue, int * pstatus ) /*---*/ { DBlock * block; int errval, status; if (EDFIO_debug) printf("edf_read_data_raw BEGIN\n"); if ( open_read_block(stream, DataNumber, DataChain, &block, &errval ) ) goto edf_read_data_raw_error; // read without conversion read_data_array ( block, *ppData, *pDataArraySize, True, *pDim, &errval, &status ); if ( status != status_success ) goto edf_read_data_raw_error; if ( close_read_block( block, &errval ) ) goto edf_read_data_raw_error; *pDataType = block->DataType; *pDataValueOffset = block->DataValueOffset; *pByteOrder = block->DataByteOrder; *pRasterConfiguration = block->DataRasterConfiguration; *ppData = block->Data; if (!(*pDim)) *pDim = block->DataDim; *pDataArraySize = block->DataBufferLen; status = status_success; errval = RoutineSucceeded; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_read_data_raw END\n"); return; edf_read_data_raw_error: status = status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_read_data_raw END (status=%d)\n",status); return; } /* edf_read_data_raw */ /*+++------------------------------------------------------------------------ NAME edf_read_data --- read data array and convert to MachineType SYNOPSIS void edf_read_data ( int stream, long DataNumber, int DataChain, long **pDim, size_t * pDataArraySize, void **ppData, int MachineType, int * pErrorValue, int * pstatus ); DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. If it does not exist the routine stops with an error. A data array is read from the file and converted into a float array of the type float Data[Dim[1],Dim[2]]. The data array is allocated. The pointer &&Data[0,0] is returned in ppData. If the stored array is only 1 dimensional, the data is read with Dim[2] set to 1. The data are read with the specification given in the header. All read data values are converted into float and the returned data array has a length of *pDataArraySize bytes. The data buffer is allocated and must be released explicitly. ARGUMENTS (If memory allocated for the dimension array otherwise *pDim=0) long (*pDim)[0] (i) number of dimensions N (*pDim)[1] (o) dimension 1 (*pDim)[2] (o) dimension 2 ... (*pDim)[N] (o) dimension N If the supplied *pDim is the NULL pointer a pointer to an allocated dimension array is returned, otherwise the dimensions are copied to the array (*pDim)[]. (*pDim)[0] must contain the dimension, e.g. 2 for a 2d data array. The dimension array must have N+2 elements, e.g. 4 elements for a 2d-array. The first element of the dimension array defines always the number of dimensions and is not changed. Remaining dimensions are set to 1. If the the supplied dimension array is too short an error is returned (NotNdData). The internally allocated memory for (*pDim) is released automatically during the next data-i/o or when the file is closed. size_t * pDataArraySize (o) size of the data array in bytes float ** pData (o) pointer to the pointer of the data array HISTORY 29-Dec-2000 PB total redesign --------------------------------------------------------------------------+*/ void edf_read_data ( int stream, long DataNumber, int DataChain, long **pDim, size_t * pDataArraySize, void **ppData, int MachineType, int * pErrorValue, int * pstatus ) /*---*/ { DBlock * block; int errval, status; if (EDFIO_debug) printf("edf_read_data BEGIN\n"); if ( open_read_block(stream, DataNumber, DataChain, &block, &errval ) ) goto edf_read_data_error; // read without conversion read_data_array ( block, *ppData, *pDataArraySize, False, *pDim, &errval, &status ); if ( status != status_success ) goto edf_read_data_error; // conversion to MachineType renorm_data_array ( block, *ppData, *pDataArraySize, MachineType, &errval, &status ); if ( status != status_success ) goto edf_read_data_error; *ppData = block->Data; if (!(*pDim)) *pDim = block->DataDim; *pDataArraySize = block->DataBufferLen; if ( close_read_block( block, &errval ) ) goto edf_read_data_error; status = status_success; errval = RoutineSucceeded; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_read_data END\n"); return; edf_read_data_error: status = status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_read_data END (status=%d)\n",status); return; } /* edf_read_data */ /*+++------------------------------------------------------------------------ NAME edf_search_minmax_number SYNOPSIS int edf_search_minmax_number( int stream, int DataChain, long int *pMinNumber, long int * pMaxNumber, int *pErrorValue, int *pstatus) DESCRIPTION Reads the headers in 'DataChain' and searches for the minimum and maximum data number. int DataChain (i) : data chain (0: general, 1: key_1, 2: key_2) long int * pMinNumber (o) : minimum data number long int * pMaxNumber (o) : maximum data number int *pErrorValue (o) : error value int *pstatus (o) : SAXS status RETURN VALUE TRUE : successful FALSE : failed --------------------------------------------------------------------------+*/ int edf_search_minmax_number( int stream, int DataChain, long int *pMinNumber, long int * pMaxNumber, int *pErrorValue, int *pstatus) /*---*/ { DBlock * block; DChain * chain; DFile * file; int ErrorValue = RoutineSucceeded, status = status_error; char *min = (char *) NULL, *max = (char *) NULL; char ChainKey[MaxKeyLen+1]; if (EDFIO_debug) printf("edf_search_minmax_number BEGIN\n"); *pMinNumber = -1l; *pMaxNumber = -2l; /* check stream */ if ((stream<0)||(stream>=MaxFiles)) { *pErrorValue = InvalidStream; goto edf_search_minmax_number_error; } /* get file */ file = &FileTable[stream]; if ( !file->Used ) { ErrorValue = NoFileOpen; goto edf_search_minmax_number_error; } /* find 'ChainKey' */ if ( find_chainkey ( stream, DataChain, ChainKey ) ) { ErrorValue = MissingKeyDefinition; goto edf_search_minmax_number_error; } /* search chain */ if (search_data_chain( file, ChainKey, &chain) ) { ErrorValue = CouldNotFindHeader; goto edf_search_minmax_number_error; } /* loop over all blocks */ block = chain->BlockList; if ( block ) { min = max = block->BlockKey; block = block->Next; while ( block ) { if ( compare_keys( block->BlockKey, min , NumberSort ) < 0 ) { min = block->BlockKey; } else if ( compare_keys( block->BlockKey, max , NumberSort ) > 0 ) { max = block->BlockKey; } block = block->Next; } /* while */ *pMinNumber = (long int) s2u_long( min ); *pMaxNumber = (long int) s2u_long( max ); } else { ErrorValue = NoDataBlocksFound; goto edf_search_minmax_number_error; } ErrorValue = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_search_minmax_number END (status=%d)\n",status); return(1); edf_search_minmax_number_error: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_search_minmax_number END (status=%d)\n",status); return(0); } /* edf_search_minmax_number */ /*+++------------------------------------------------------------------------ NAME edf_read_data_dimension SYNOPSIS int edf_read_data_dimension ( int stream, long int DataNumber, int DataChain, long ** pDim, size_t * pDataArraySize, int * pErrorValue, int * pstatus ) DESCRIPTION Searches for header 'DataNumber' in 'DataChain' and inquires for the dimension of the two dimensional data array. If the header or the dimension of the data array does not exist, the return value is FALSE and a specific error value is returned. This error is not fatal and can be used as a test for the existence of a header. ARGUMENTS long int DataNumber (i) : data number int DataChain (i) : data chain (0: general, 1: key_1, 2: key_2) If memory is allocated for the dimension array otherwise *pDim=0 long (*pDim)[0] (i) : number of dimensions N (*pDim)[1] (o) : dimension 1 (*pDim)[2] (o) : dimension 2 ... (*pDim)[N] (o) : dimension N If the supplied *pDim is the NULL pointer a pointer to an allocated dimension array is returned, otherwise the dimensions are copied to the array (*pDim)[]. (*pDim)[0] must contain the dimension, e.g. 2 for a 2d data array. The dimension array must have N+2 elements, e.g. 4 elements for a 2d-array. The first element of the dimension array defines always the number of dimensions and is not changed. Remaining dimensions are set to 1. If the supplied dimension array is too short an error is returned (NotNdData). The internally allocated memory for (*pDim) is released automatically during the next data-i/o or when the file is closed. Attention, it is also released when the actual data is read. size_t * pDataArraySize (o) : size of the raw data array in bytes int *pErrorValue (o) : error value int *pstatus (o) : SAXS status RETURN VALUE TRUE : data header found, if *pstatus == Success FALSE : data header not found, *pstatus == status_error; *pErrorValue == CouldNotFindHeader; HISTORY --------------------------------------------------------------------------+*/ int edf_read_data_dimension ( int stream, long int DataNumber, int DataChain, long ** pDim, size_t * pDataArraySize, int * pErrorValue, int * pstatus ) /*---*/ { DBlock * block; long * data_dim; size_t data_len; int errval, status; if (EDFIO_debug) printf("edf_read_data_dimension BEGIN\n"); switch ( open_read_block (stream, DataNumber, DataChain, &block, &errval) ) { case 1: goto edf_read_data_dimension_notfound; case -1: goto edf_read_data_dimension_error; } /* get dimension */ if ( ! (data_dim = get_data_dim ( block )) ) { errval = CouldNotReadDimension; goto edf_read_data_dimension_error; } data_len = edf_dim_product(data_dim)*edf_data_sizeof(get_data_type(block)); *pDataArraySize = data_len; /* copy data_dim to *pDim */ if (*pDim) { // use supplied buffer if ( !(copydim( *pDim, (*pDim)[0], data_dim ) ) ) { errval = NotNdData; goto edf_read_data_dimension_error; } } else { // use allocated buffer *pDim = data_dim; } /* update DataDim array */ if (block->DataDim) { // copy dimensions into existing array if ( !(copydim( block->DataDim, block->DataDim[0], data_dim ) ) ) { errval = NotNdData; goto edf_read_data_dimension_error; } } else { // use allocated buffer block->DataDim = data_dim; } if ( close_read_block( block, &errval ) ) goto edf_read_data_dimension_error; errval = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_read_data_dimension END\n"); return(1); edf_read_data_dimension_notfound: status = status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) { printf("edf_read_data_dimension: %s",edf_report_data_error ( errval )); printf("edf_read_data_dimension END (status=%d)\n",status); } return(0); edf_read_data_dimension_error: status = status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (EDFIO_debug) { printf("edf_read_data_dimension: %s",edf_report_data_error ( errval )); printf("edf_read_data_dimension END (status=%d)\n",status); } return(1); } /* edf_read_data_dimension */ /*+++------------------------------------------------------------------------ NAME edf_test_header --- test, whether a header exists SYNOPSIS int edf_test_header ( int stream, long DataNumber, int DataChain, int *pErrorValue, int *pstatus ); DESCRIPTION Searches for header 'DataNumber' in 'DataChain'. Returns only 1 if it was found, otherwise it returns 0. --------------------------------------------------------------------------+*/ int edf_test_header ( int stream, long DataNumber, int DataChain, int *pErrorValue, int *pstatus ) /*---*/ { DFile * file; DChain * chain; DBlock * block; int ErrorValue = RoutineSucceeded, status = status_error; int found = 0; char BlockKey[MaxKeyLen+1]; char ChainKey[MaxKeyLen+1]; if (EDFIO_debug) printf("edf_test_header BEGIN\n"); /* check stream */ if ((stream<0)||(stream>=MaxFiles)) { *pErrorValue = InvalidStream; goto edf_test_header_error; } /* get file */ file = &FileTable[stream]; if ( !file->Used ) { ErrorValue = NoFileOpen; goto edf_test_header_error; } /* find 'ChainKey' */ if ( find_chainkey ( stream, DataChain, ChainKey ) ) { ErrorValue = MissingKeyDefinition; goto edf_test_header_error; } /* find 'BlockKey' */ if ( find_blockkey ( DataChain, DataNumber, BlockKey ) ) { ErrorValue = MissingKeyDefinition; goto edf_test_header_error; } status = status_success; /* search header */ if ( (!search_data_chain( file, ChainKey, &chain) ) && (!search_data_block( chain, BlockKey, &block) ) ) found = 1; if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_test_header END %d\n",found); return(found); edf_test_header_error: if (pErrorValue) *pErrorValue = ErrorValue; if (pstatus) *pstatus = status; if (EDFIO_debug) printf("edf_test_header END (status=%d)\n",status); return(found); } /* edf_test_header */ /*===keyorder BEGIN=======================================================*/ /*+++ public interface of keyorder ----------------------------------------- HISTORY 2001-11-25 V1.0 Peter Boesecke PUBLIC extern void edf_keyorder_set_table ( const char * table[] ), edf_keyorder_print_table ( FILE * out ); The following routines are only used in edfio.c PRIVATE SElement ** keyorder_ordersymbols ( DBlock * block ); PRIVATE int keyorder_first_header_element ( HList * header, HElement ** element ), keyorder_next_header_element ( HList * header, HElement ** element ); ---------------------------------- end of public interface of keyorder ---*/ /**************************************************************************** * Static Variables * ****************************************************************************/ static int keyorder_Debug = 0; //static const char * keyorder_DefaultTable[] = { (const char *) NULL }; static const char * keyorder_DefaultTable[] = { "ByteOrder", "DataType", "DataRasterConfiguration", "Dim_*", "Title", "Time", "Intensity*", "ExposureTime", "Dummy", "DDummy", "Offset_*", "Center_*", "BSize_*", "PSize_*", "Sample*", "WaveLength", "DetectorRotation_*", "Projection*", "Raster*", "AxisType_*", "Norm*", "Attenuator*", "Detector*", "Experiment*", "Gestion*", "Machine*", "Monitor*", "Msensi*", "Optics*", "Proposal*", "Psic*", "Session*", "Pslit*", "Slit*", "Station*", "History-*", "HS32*", "H*", (const char *) NULL }; static const char ** keyorder_KeyOrderTable = keyorder_DefaultTable; /*-------------------------------------------------------------------------- NAME keyorder_setkeyordertable --- defines a key order table SYNOPSIS void keyorder_setkeyordertable( const char * keyordertable[] ) DESCRPTION Redefines the internal order table by keyordertable. The table must be a list of key words and the last element of the table must be a (char *) NULL. The key words can be terminated by the wild card character '*'. In this case, all keywords starting with the characters before the wild card will be ordered in alphabetical order. -----------------------------------------------------------------------------*/ void keyorder_setkeyordertable( const char * keyordertable[] ) { keyorder_KeyOrderTable = keyordertable; } // keyorder_setkeyordertable /*-------------------------------------------------------------------------- NAME keyorder_debug --- set / reset module keyorder into debug mode SYNOPSIS void keyorder_debug ( int debug ); DESCRPTION Writes ´debug´ into keyorder_debug. -----------------------------------------------------------------------------*/ void keyorder_debug ( int debug ) { keyorder_Debug = debug; } // keyorder_debug /*-------------------------------------------------------------------------- NAME void keyorder_print_keyordertable ( FILE * out ) --- print order key table SYNOPSIS void keyorder_print_keyordertable ( FILE * out ); DESCRPTION Prints the internal order key table. -----------------------------------------------------------------------------*/ void keyorder_print_keyordertable ( FILE * out ) { const char **pkeyorder=keyorder_KeyOrderTable; int i; if (!pkeyorder) pkeyorder = keyorder_DefaultTable; i=0; while (*pkeyorder) { printf("keyorder_DefaultTable[%u] = %s\n", i++,*pkeyorder); pkeyorder++; } return; } // keyorder_print_keyordertable /*--------------------------------------------------------------------------- NAME keyorder_next_header_element_wild -- searches for next ´keyorder´ in header SYNOPSIS int keyorder_next_header_element_wild( HList * header, const char * keyorder, HElement ** element ) DESCRIPTION Searches the first header element matching ´keyorder´. ´keyorder´ can terminate with '*' as a wild card. RETURN VALUE ´keyorder´ found, element pointer returned in **element ´keyorder´ pointer (HElement *) NULL returned in **element return value 0: OK, -1 : ERROR ---------------------------------------------------------------------------*/ int keyorder_next_header_element_wild( HList * header, const char * keyorder, HElement ** element ) { HElement * current; /* return NULL in case that header was not found */ *element = (HElement *) NULL; /* stop, if header not defined */ if ( !header ) return(-1); /* search element */ current = header->ElementRoot; while ( current!=(HElement *) NULL ) { if ( !(current->Flags.Read) ) { if (!keyorder) { current->Flags.Read = True; break; } if ( ( keyorder_compare( current->Key, keyorder ) ) == 0 ) { current->Flags.Read = True; break; } } current = current->Next; } *element = current; return( 0 ); } // keyorder_next_header_element_wild /*--------------------------------------------------------------------------- NAME keyorder_clear_header_element_readflag -- clears all read flags SYNOPSIS int keyorder_clear_header_element_readflag( HList * header ); DESCRIPTION Clears the read flags of all header elements of header RETURN VALUE 0, if OK -1 if not OK ---------------------------------------------------------------------------*/ int keyorder_clear_header_element_readflags( HList * header ) { HElement * current; /* stop, if header not defined */ if ( !header ) return(-1); current = header->ElementRoot; while ( current!=(HElement *) NULL ) { current->Flags.Read = False; current = current->Next; } return(0); } // keyorder_clear_header_element_readflag /*--------------------------------------------------------------------------- NAME keyorder_first_header_element -- searches first element in header list SYNOPSIS int keyorder_first_header_element( HList * header, HElement ** element ) DESCRIPTION Returns the first header element according to KeyOrderTable. The following header elements must be read with keyorder_next_header_element The function clears the Read flags of all header elements and resets the KeyOrderNo of header. RETURN VALUE first element found, element pointer returned in **element no element found, (HElement *) NULL returned in **element --------------------------------------------------------------------------*/ int keyorder_first_header_element( HList * header, HElement ** element ) { /* return NULL in case that header was not found */ *element = (HElement *) NULL; /* stop, if header not defined */ if ( !header ) return(-1); keyorder_clear_header_element_readflags( header ); /* return NULL in case that header was not found */ *element = (HElement *) NULL; header->KeyOrderNo = 0; do { keyorder_next_header_element_wild( header, keyorder_KeyOrderTable[header->KeyOrderNo], element ); if ( (*element!=(HElement *) NULL) ) break; } while ( (keyorder_KeyOrderTable[header->KeyOrderNo++]) ); return(0); } // keyorder_first_header_element /*--------------------------------------------------------------------------- NAME keyorder_next_header_element -- returns next element in header list SYNOPSIS int keyorder_next_header_element( HList * header, HElement ** element ) DESCRIPTION Returns the next header element according to KeyOrderTable. The first element must be read with keyorder_first_header_element. RETURN VALUE first element found, element pointer returned in **element no element found, (HElement *) NULL returned in **element ---------------------------------------------------------------------------*/ int keyorder_next_header_element( HList * header, HElement ** element ) { /* return NULL in case that header was not found */ *element = (HElement *) NULL; /* stop, if header not defined */ if ( !header ) return(-1); do { keyorder_next_header_element_wild( header, keyorder_KeyOrderTable[header->KeyOrderNo], element ); if ( (*element!=(HElement *) NULL) ) break; } while ( (keyorder_KeyOrderTable[header->KeyOrderNo++]) ); return(0); } // keyorder_next_header_element /*--------------------------------------------------------------------------- NAME keyorder_strcolup --- converts a string to upper case and removes spaces SYNOPSIS char * keyorder_strcolup( char buffer[], unsigned long buflen, const char * string ) DESCRIPTION Copies all printable characters except space to buffer and converts them to upper case. RETURN VALUES Pointer to buffer HISTORY Peter Boesecke ---------------------------------------------------------------------------*/ char * keyorder_strcolup( char buffer[], unsigned long buflen, const char * string ) { register unsigned int i; char *pc; pc = &buffer[0]; if (string) for (i=0;(i<(buflen-1))&&(*string);i++) { if (isgraph(*string)) { *pc=toupper(*string); pc++; } string++; } *pc=(char) 0; return( buffer ); } // keyorder_strcolup /*--------------------------------------------------------------------------- NAME keyorder_wildcmp --- compares a key with a wild card key SYNOPSIS int keyorder_wildcmp( const char *key, const char *wild ); DESCRIPTION The routines compares the characters of wild with the characters of key. If '*' is found in wild the comparison of the remaining characters in key is skipped until the first character after '*' is found in key. There, the comparison is continued. However, the function may not return the expected result if '*' is not the last character in wild and if key contains several times the character after '*', e.g. key="abcabc", wild = "abcabc" -> 0 key="abcabc", wild = "abc*" -> 0 key="abcabc", wild = "*abc" -> 1 comparison is stopped after the first occurrence of abc key="abcabc", wild = "*abc*" -> 0 key="abcabc", wild = "*cabc" -> 0 RETURN VALUES The routine returnes as result: input output key < wild -1 key = wild 0 key > wild +1 HISTORY Peter Boesecke ---------------------------------------------------------------------------*/ int keyorder_wildcmp( const char *key1, const char *key2 ) { const char *pc1, *pc2; int value=0; if ((!key1) || (!key2) ) { if (key2) return(-1); else { if (key1) return(1); else return(0); } } pc1 = key1; pc2 = key2; value=0; do { if ((*pc2)=='*') { // wild card do pc2++; while ((*pc2)=='*'); // get first character after wild cards while ((*pc1)!=(*pc2)) { if (*pc1) pc1++; else break; } } if (*pc2) { if ( (*pc1)!=(*pc2) ) { if ( (*pc1)<(*pc2) ) value=-1; else value=1; } } else { if (*pc1) value=1; } } while ( (*pc1++) && (*pc2++) ); return( value ); } // keyorder_wildcmp /*--------------------------------------------------------------------------- NAME keyorder_compare --- compares a key with a criterion card key SYNOPSIS int keyorder_compare( const char *key, const char *criterion ); DESCRIPTION The comparison is done for printable characters only, except spaces. Other characters are suppressed. The comparison is done for a maximum of MaxKeyLen characters (including all characters, printable and non-printable). The comparison is not case sensitive and is done after conversion of all characters to upper-case. If the criterion key contains a '*' the comparison is stopped a this position RETURN VALUES The routine returnes as result: input output key < criterion -1 key = criterion 0 key > criterion +1 HISTORY Peter Boesecke ---------------------------------------------------------------------------*/ PRIVATE int keyorder_compare( const char *key, const char *criterion ) { char buf1[MaxKeyLen+1], buf2[MaxKeyLen+1]; /* convert to upper case */ keyorder_strcolup( buf1, MaxKeyLen+1, key ); keyorder_strcolup( buf2, MaxKeyLen+1, criterion ); /* compare */ return(keyorder_wildcmp( buf1, buf2 )); } /* keyorder_compare */ //============================================================================== /*--------------------------------------------------------------------------- NAME keyorder_clear_symbol_readflag -- clears all symbol read flags SYNOPSIS int keyorder_clear_symbol_readflag( DBlock * block, unsigned long * ptablelen ); DESCRIPTION Clears the read flags of all symbols in block and returns the total number of keys in *ptablelen. Must be called before using keyorder_copy_formatsymbols, keyorder_next_symbol_wild and keyorder_next_symbol RETURN VALUE 0, if OK -1 if not OK ---------------------------------------------------------------------------*/ int keyorder_clear_symbol_readflags( DBlock * block, unsigned long * ptablelen ) { SElement * current; *ptablelen = 0l; if ( !block ) return(-1); current = block->SymbolList; while ( current!=(SElement *) NULL ) { current->Flags.Read = False; current = current->Next; (*ptablelen)++; } block->KeyOrderNextSymbol = block->SymbolList; block->KeyOrderNo = 0; return(0); } // keyorder_clear_symbol_readflags /*--------------------------------------------------------------------------- NAME keyorder_copy_formatsymbols -- copies all data format symbols SYNOPSIS int keyorder_copy_formatsymbols( DBlock * block, SElement *** ptable ); DESCRIPTION Copies all data format specific symbol pointers of block to *ptable[i]. After return *ptable points after the copied format symbols. RETURN VALUE 0, if OK -1 if not OK ---------------------------------------------------------------------------*/ int keyorder_copy_formatsymbols( DBlock * block, SElement *** ptable ) { SElement * current; if ( !block ) return(-1); current = block->KeyOrderNextSymbol; while ( ( current!=(SElement *) NULL ) && (is_prefix(current->Key,DATA_FORMAT_PREFIX,UpperCaseSort)) ) { *(*ptable) = current; (*ptable)++; current->Flags.Read = True; current = current->Next; } block->KeyOrderNextSymbol = current; return(0); } // keyorder_copy_formatsymbols /*--------------------------------------------------------------------------- NAME keyorder_next_symbol_wild -- searches for next ´keyorder´ in block SYNOPSIS int keyorder_next_symbol_wild( DBlock * block, const char * keyorder, SElement ** symbol ) DESCRIPTION Searches the first symbol matching ´keyorder´. ´keyorder´ can terminate with '*' as a wild card. To increase the speed in long lists the search starts at block->KeyOrderNextSymbol which is the first symbol that has not already been read. First, block->KeyOrderNextSymbol is updated. Then the search is started. The first symbol that matches keyorder and that has not already been read. RETURN VALUE ´keyorder´ found, symbol pointer returned in **symbol ´keyorder´ pointer (HElement *) NULL returned in **symbol return value 0: OK, -1 : ERROR ---------------------------------------------------------------------------*/ int keyorder_next_symbol_wild( DBlock * block, const char * keyorder, SElement ** symbol ) { SElement * current; /* reset symbol */ *symbol = (SElement *) NULL; /* stop, if block not defined */ if ( !block ) return(-1); /* get start point */ current = block->KeyOrderNextSymbol; /* skip already read symbols */ while ( ( current!=(SElement *) NULL ) && (current->Flags.Read) ) { current = current->Next; } /* set new start point */ block->KeyOrderNextSymbol = current; /* search symbol */ while ( current!=(SElement *) NULL ) { if ( !(current->Flags.Read) ) { if (!keyorder) { current->Flags.Read = True; break; } if ( ( keyorder_compare( current->Key, keyorder ) ) == 0 ) { current->Flags.Read = True; break; } } current = current->Next; } *symbol = current; return( 0 ); } // keyorder_next_symbol_wild /*--------------------------------------------------------------------------- NAME keyorder_next_symbol -- returns next symbol SYNOPSIS int keyorder_next_symbol( DBlock * block, SElement ** symbol ) DESCRIPTION Returns the next symbol according to KeyOrderTable. The first symbol must be read with keyorder_first_symbol. RETURN VALUE next symbol found, symbol pointer returned in **symbol no symbol found, (SElement *) NULL returned in **symbol ---------------------------------------------------------------------------*/ int keyorder_next_symbol( DBlock * block, SElement ** symbol ) { /* reset symbol */ *symbol = (SElement *) NULL; /* stop, if block not defined */ if ( !block ) return(-1); do { keyorder_next_symbol_wild( block, keyorder_KeyOrderTable[block->KeyOrderNo], symbol ); if ( (*symbol!=(SElement *) NULL) ) break; } while ( (keyorder_KeyOrderTable[block->KeyOrderNo++]) ); return(0); } // keyorder_next_symbol /*--------------------------------------------------------------------------- NAME keyorder_ordersymbols --- return a table with symbols in order SYNOPSIS SElement ** keyorder_ordersymbols( DBlock * block ) DESCRIPTION Returns a table that lists pointers to the user symbols of block according to keyorder_KeyOrderTable. The table is terminated with an empty element (SElement*) NULL. The table must be released after use. RETURN VALUES The routine returnes as result: (SElement **) NULL: error otherwise, pointer to allocated ordered symbol table HISTORY Peter Boesecke ---------------------------------------------------------------------------*/ PRIVATE SElement ** keyorder_ordersymbols( DBlock * block ) { SElement * symbol, ** table = (SElement **) NULL, ** ptable; unsigned long tablelen; if ( keyorder_clear_symbol_readflags( block, &tablelen ) ) return( table ); table = (SElement **) malloc ( (tablelen+1) * sizeof(SElement **) ); if (!table) return( table ); ptable = table; // copy all format symbols into table keyorder_copy_formatsymbols( block, &ptable ); // search first user symbol keyorder_next_symbol( block, &symbol ); while ( symbol ) { // save symbol pointer in table *ptable = symbol; ptable++; // search next symbol keyorder_next_symbol( block, &symbol ); } *ptable = (SElement *) NULL; return( table ); } /* keyorder_ordersymbols */ /*+++------------------------------------------------------------------------ NAME edf_keyorder_set_table --- sets a new order key table SYNOPSIS void edf_keyorder_set_table( const char * table[] ) DESCRIPTION This function defines a new order key table. The table contains all keys in the order in what they should be written. The table must be terminated with (char *) NULL. Keys that are not found in the table are listed after the keys that have been found. An asterisk at the end of a key in the table is a wild card. HISTORY 2001-11-24 Peter Boesecke --------------------------------------------------------------------------+*/ void edf_keyorder_set_table( const char * table[] ) { keyorder_setkeyordertable( table ); } /* edf_keyorder_set_table */ /*+++------------------------------------------------------------------------ NAME edf_keyorder_print_table --- prints the order key table SYNOPSIS void edf_keyorder_print_table( FILE * out ) DESCRIPTION The order key table is printed to out. HISTORY 2001-11-24 Peter Boesecke --------------------------------------------------------------------------+*/ void edf_keyorder_print_table( FILE * out ) { keyorder_print_keyordertable ( out ); } /* edf_keyorder_print_table */ /*===keyorder END=======================================================---*/ /*===header_list BEGIN=====================================================*/ /*+++ public interface of header_list --------------------------------------- DESCRIPTION The routines of this module are used to read and write header lines. 'edf_new_header' must be called first. Opens a header with header_key. 'edf_read_header' reads the header from the input image 'edf_write_header' writes the header to the output image 'edf_first_header_element' returns key and value of the first header element 'edf_next_header_element' returns key and value of the next header element 'edf_search_header_element' returns value of header element 'edf_add_header_element' adds or replaces a header element 'edf_delete_header_element' deletes a header element 'edf_free_header' releases a specific or all header keys. 'header_debug' sets the module into debug mode. The values of header_list do not contain escape sequences. HISTORY 2000-12-31 PB 2001-11-25 PB edf_first_header_element, edf_next_header_element PUBLIC extern int edf_new_header ( const char * header_key ), edf_read_header ( int stream, long int DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus ), edf_write_header ( int stream, long int DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus ), edf_first_header_element ( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ), edf_next_header_element ( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ), edf_search_header_element( const char * header_key, const char * key, const char ** pvalue, int * pErrorValue, int * pstatus ), edf_add_header_element ( const char * header_key, const char * key, const char * value, int * pErrorValue, int * pstatus ), edf_delete_header_element( const char * header_key, const char * key, int * pErrorValue, int * pstatus ), edf_free_header ( const char * header_key ), edf_print_header ( FILE * out, const char * header_key, int level, int verbose ); PUBLIC extern void header_debug ( int debug ); ------------------------------ end of public interface of header_list ---*/ /**************************************************************************** * Static Variables * ****************************************************************************/ static int InitHeader = 0; static HList * header_root = (HList *) NULL; static int HEADER_debug = 0; /*--------------------------------------------------------------------------- NAME init_header() SYNOPSIS DESCRIPTION RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ int init_header( void ) { header_root = (HList *) NULL; InitHeader = 1; return(0); } /* init_header */ /*+++------------------------------------------------------------------------ NAME free_header_list (success:0, error:-1) SYNOPSIS int free_header_list( HList * header ) DESCRIPTION Frees the element list of header. RETURN VALUE 0: success -1: failed ---------------------------------------------------------------------------*/ int free_header_list( HList * header ) { HElement * element, * next; if (header==(HList *)NULL) return(-1); next = header->ElementRoot; while(next!=(HElement*) NULL) { element = next; next=next->Next; free(element->Value); free(element->Key); free(element); } header->ElementRoot = (HElement *) NULL; return(0); } /* free_header_list */ /*--------------------------------------------------------------------------- NAME search_header_list SYNOPSIS int search_header_list ( HList * root, const char * header_key, HList ** pheader ) DESCRIPTION Searches the key 'header_key' in the header list and returns the pointer to the header (*pheader) or NULL if not found. RETURN VALUES Returns 0 if found and -1 if no success. ---------------------------------------------------------------------------*/ int search_header_list ( HList * root, const char * header_key, HList ** pheader ) { HList * previous, * next; int notfound = 1; *pheader = (HList *) NULL; /* search for header_key */ previous = (HList *) NULL; next = root; if (root == (HList*) NULL) return(-1); /* search insertion point (insertion before next) */ while( ( next!=(HList *) NULL ) && (notfound>0) ) { notfound = compare_keys(next->Key,header_key,UpperCaseSort); if (notfound>0) {previous = next; next = next->Next;} } if (!notfound) *pheader = next; return(0); } /* search_header_list */ /*--------------------------------------------------------------------------- NAME header_list_new SYNOPSIS int header_list_new ( HList ** proot, const char * header_key, HList ** pheader ); DESCRIPTION Adds a new header list with the key 'header_key' to the header list If the key already exists, the existing elements are removed. The key list is ordered in reverse alphabetical order. RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ int header_list_new ( HList ** proot, const char * header_key, HList ** pheader ) { HList * newhlist, * previous, * next; int notfound = 1; /* search for header_key */ previous = (HList *) NULL; next = *proot; *pheader = (HList *) NULL; /* search insertion point (insertion before next) */ while( ( next!=(HList *) NULL ) && (notfound>0) ) { notfound = compare_keys(next->Key,header_key,UpperCaseSort); if (notfound>0) {previous = next; next = next->Next;} } if (notfound) { /* create new hlist */ if (!(newhlist = (HList *) malloc(sizeof(HList)))) return(-1); newhlist->Key = newstr(header_key); if (!newhlist->Key) return(-1); newhlist->ElementRoot = (HElement *) NULL; newhlist->KeyOrderNo = 0; /* insert newhlist before next */ if (next) next->Previous = newhlist; newhlist->Next=next; newhlist->Previous=previous; if (previous) previous->Next=newhlist; else *proot = newhlist; next = newhlist; } /* free next->ElementRoot */ if ( next->ElementRoot ) { free_header_list( next ); } *pheader = next; return(0); } /* header_list_new */ /*--------------------------------------------------------------------------- NAME header_list_free SYNOPSIS int header_list_free ( HList ** proot ); DESCRIPTION Removes all header lists from proot. RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ int header_list_free ( HList ** proot ) { HList *current, * next; /* search for header_key */ next = *proot; while( next!=(HList *) NULL ) { current = next; next = next->Next; free_header_list( current ); free( current ); } *proot = next; return(0); } /* header_list_free */ /*--------------------------------------------------------------------------- NAME header_list_remove SYNOPSIS int header_list_remove ( HList ** proot, const char * header_key ); DESCRIPTION Removes header_key from proot. RETURN VALUES Returns 0 in case of success and -1 if no success. ---------------------------------------------------------------------------*/ int header_list_remove ( HList ** proot, const char * header_key ) { HList *current, *previous, *next; /* search for header_key */ if (search_header_list ( *proot, header_key, &next )) return(-1); if ( next!=(HList *) NULL ) { // remove current current = next; previous = current->Previous; next = current->Next; if (next) next->Previous = previous; if (previous) previous->Next = next; else *proot = next; free_header_list( current ); free ( current ); } return(0); } /* header_list_remove */ /*--------------------------------------------------------------------------- NAME init_header_element_flags --- initialize header element flags SYNOPSIS init init_header_element_flags( HEFlags * Flags ) RETURN VALUE success: 0 error: not 0 ---------------------------------------------------------------------------*/ int init_header_element_flags( HEFlags * Flags ) { Flags->Read = (unsigned short) 0; return(0); } /* init_header_element_flags */ /*--------------------------------------------------------------------------- print_header_element_flags (success:0, error:-1) ---------------------------------------------------------------------------*/ int print_header_element_flags ( FILE * out, const HEFlags * Flags ) { fprintf(out," Flags\n"); fprintf(out," Read = %hu\n",Flags->Read); return(0); } /* print_header_element_flags */ /*--------------------------------------------------------------------------- insert_header_element (success:0, error:-1) If 'Key' already exists, its 'Value' is updated, otherwise it is created. In case of success the pointer to the new element is returned. ---------------------------------------------------------------------------*/ int insert_header_element( HList * header, const char * Key, const char * Value , HElement ** element ) { HElement * newelement, * next, * previous; char * tmp; int notfound = -1; if ( header == (HList *) NULL) return(-1); if ( Value == (const char *) NULL ) return(-1); *element = (HElement *) NULL; previous = (HElement *) NULL; next = header->ElementRoot; /* search insertion point (insertion before next) */ while( ( next!=(HElement *) NULL ) && (notfound<0) ) { notfound = compare_keys(next->Key,Key,UpperCaseSort); if (notfound<0) {previous = next; next = next->Next;} } /* create new element, if (notfound) */ if ( notfound ) { /* create new element */ if (!(newelement = (HElement *) malloc( sizeof(HElement) ) )) return(-1); newelement->Key = newstr( Key ); if (!newelement->Key) return(-1); newelement->Value = (char *) NULL; init_header_element_flags( &(newelement->Flags) ); /* insert newelement before next */ if (next) next->Previous = newelement; newelement->Next=next; newelement->Previous=previous; if (previous) previous->Next=newelement; else header->ElementRoot = newelement; next = newelement; } /* update Value */ tmp = newstr( Value ); if (!tmp) return(-1); if ( next->Value ) free ( next->Value ); next->Value = tmp; *element = next; return(0); } /* insert_header_element */ /*--------------------------------------------------------------------------- search_header_element (success:0, error:-1) In case of success the pointer to the element is returned. ---------------------------------------------------------------------------*/ int search_header_element( HList * header, const char * Key, HElement ** element ) { HElement * current; /* return NULL in case that element was not found */ *element = (HElement *) NULL; /* stop, if header not defined */ if ( !header ) return(-1); /* search element */ current = header->ElementRoot; if ( current!=(HElement *) NULL ) while( ( current!=(HElement *) NULL ) && ( compare_keys(current->Key,Key,UpperCaseSort)!=0 ) ) { current = current->Next; } *element = current; if (current==(HElement *) NULL) return(-1); return(0); } /* search_header_element */ /*--------------------------------------------------------------------------- remove_header_element (success:0, error:-1) The routine ends with success if the element is not any more present, even if it does not exist before the call of this function. ---------------------------------------------------------------------------*/ int remove_header_element( HList * header, const char * Key ) { HElement * current, * previous, *next; /* search element */ current = header->ElementRoot; if ( current!=(HElement *) NULL ) while( ( current!=(HElement *) NULL ) && ( compare_keys(current->Key,Key,UpperCaseSort)!=0 ) ) { current = current->Next; } /* stop, if no element found */ if (current==(HElement *) NULL) return(0); /* change links */ previous = current->Previous; next = current->Next; if ( next != (HElement *) NULL ) next->Previous = previous; if ( previous != (HElement *) NULL ) previous->Next = next; else header->ElementRoot = next; /* remove element */ free(current->Key); free(current->Value); free(current); return(0); } /* remove_header_element */ /*--------------------------------------------------------------------------- read_header_list (success:0, error:-1) Add all header user values of block to a list and convert them to string. DBlock * block : input block HList * header : output header ---------------------------------------------------------------------------*/ int read_header_list( DBlock * block, HList * header ) { SElement * symbol, * next; HElement * element; if ( (block == (DBlock *) NULL) || (header==(HList*) NULL) ) return(-1); symbol = block->SymbolList; while (symbol!=(SElement*) NULL) { // update symbol string with values of continuation keys if ( update_string( symbol, &next ) ) { free_header_list(header); return(-1); } if (HEADER_debug) printf(" '%s' = '%s'\n",symbol->Key,symbol->String); if (!is_prefix(symbol->Key,DATA_FORMAT_PREFIX,UpperCaseSort)) { if (insert_header_element(header,symbol->Key,symbol->String,&element)) { free_header_list(header); return(-1); } } symbol=next; // skip continuation keys } return(0); } /* read_header_list */ /*--------------------------------------------------------------------------- write_header_list (success:0, error:-1) Write list into header of block DBlock * block : output block HList * header : input header ---------------------------------------------------------------------------*/ int write_header_list( DBlock * block, HList * header ) { HElement * element; if ( (block == (DBlock *) NULL) || (header==(HList*) NULL) ) return(-1); element = header->ElementRoot; while (element!=(HElement*) NULL) { if (HEADER_debug) printf(" '%s' = '%s'\n",element->Key,element->Value); /* create/replace keyword and value in header */ if (insert_string(block,element->Key,element->Value,NULL)) return(-1); /* The header was changed and must be written to disk */ block->Flags.HeaderChanged = True; element=element->Next; } return(0); } /* write_header_list */ /*+++------------------------------------------------------------------------ NAME print_header_list (success:0, error:-1) SYNOPSIS int print_header_list( FILE * out, HList * header, int level, int verbose ); DESCRIPTION Prints the header list to the file ´out´ RETURN VALUE 0: success -1: failed ---------------------------------------------------------------------------*/ int print_header_list( FILE * out, HList * header, int level, int verbose ) { const char * SeparationLine = "- - - - - - - -"; HElement * element; if (!header) return(-1); if (level<1) return(0); element = header->ElementRoot; while (element!=(HElement*) NULL) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Key = %s\n",element->Key); fprintf(out," Value = %s\n",element->Value); print_header_element_flags ( out, &(element->Flags) ); fprintf(out," Previous Key = "); if ((element->Previous)!=(HElement*) NULL) fprintf(out,"%s\n", element->Previous->Key); else fprintf(out,"(no previous element)\n"); fprintf(out," Next Key = "); if ((element->Next)!=(HElement*) NULL) fprintf(out,"%s\n", element->Next->Key); else fprintf(out,"(no next element)\n"); } else { fprintf(out," '%s' = '%s'\n",element->Key,element->Value); } element=element->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(0); } /* print_header_list */ /* print info about a single data block to out format 6: write lf, not crlf*/ int edf_dump_format ( FILE * out, DBlock * block, int format, int newchain, char * keyword[] ) { SElement * symbol; char **pkey; char *crlf="\r\n", *lf="\n"; char *ps; if (format==6) ps=lf; else ps=crlf; switch (format) { case 0: // standard format case 10000: case 10001: fprintf(out,"chain = %s%s", block->Chain->ChainKey,ps); fprintf(out," block = %s%s", block->BlockKey,ps); if (format>=10000) { fprintf(out, " HeaderBlockPos = %lu (%#lx), Length = %lu (%#lx)%s", block->TextPos, block->TextPos, block->TextLen, block->TextLen, ps); fprintf(out, " BinaryBlockPos = %lu (%#lx), Length = %lu (%#lx)%s", block->BinaryPos, block->BinaryPos, block->BinaryLen, block->BinaryLen, ps); } if ( (keyword) && (keyword[0]!=(char*) NULL) ) // load data header if (!get_data_header( block )) { for (pkey=keyword;*pkey!=(char*) NULL;pkey++) { if (!search_general( block, *pkey, &symbol )) { fprintf(out," %s = %s%s",*pkey, symbol->String,ps); if (format==10001) { fprintf(out, " KeyPos = %lu (%#lx), Length = %u (%#x)%s", symbol->KeyPos, symbol->KeyPos, symbol->KeyLen, symbol->KeyLen, ps); fprintf(out, " ValPos = %lu (%#lx), Length = %u (%#x)%s", symbol->ValPos, symbol->ValPos, symbol->ValLen, symbol->ValLen, ps); } } } } // get_data_header break; // case 0 case 1: // short format fprintf(out,"%s",block->Chain->File->Name); fprintf(out,"\t%s",block->Chain->ChainKey); fprintf(out,"\t%s",block->BlockKey); if ( (keyword) && (keyword[0]!=(char*) NULL) ) { // load data header if (!get_data_header( block )) { for (pkey=keyword;*pkey!=(char*) NULL;pkey++) { if (!search_general( block, *pkey, &symbol )) { fprintf(out,"\t%s", symbol->String ); } } } // get_data_header fprintf(out,"%s",ps); } // keyword break; // case 1 case 2: // very short format case 6: if ( (keyword) && (keyword[0]!=(char*) NULL) ) { // load data header if (!get_data_header( block )) { pkey=keyword; if (!search_general( block, *pkey, &symbol )) fprintf(out,"%s", symbol->String ); pkey++; for (;*pkey!=(char*) NULL;pkey++) { if (!search_general( block, *pkey, &symbol )) { fprintf(out,"\t%s", symbol->String ); } } } // get_data_header fprintf(out,"%s",ps); } // keyword break; // case 2 case 101: // short format, no keywords, one line per chain key if (newchain) { fprintf(out,"%s",block->Chain->File->Name); fprintf(out,"\t%s",block->Chain->ChainKey); } fprintf(out,"\t%s",block->BlockKey); break; // case 101 default : break; } // switch return(0); } // edf_dump_format /*+++------------------------------------------------------------------------ NAME SYNOPSIS int edf_dump( FILE * out, int stream, int format, char * chainkey[], char * blockkey[], char * keyword[] ); DESCRIPTION Prints the current structure of the file. When the keyword table is not empty the contents of all headers are read. format 0 : simple, all on separate lines 10000 : like 0 + write block positions 10001 : like 10000 + write keyword positions 1 : short, one line per block key with keywords: 101 : or one line per chain key without keywords: 2 : very short, one line per block key, keywords only 6 : very short, one line per block key, keywords only, last line without crlf PARAMETERS FILE * out : output file int stream : stream of opened edf file int format : output format char *chainkey[] : chainkey table (use all chainkeys, if empty) char *blockkey[] : blockkey table (use all blockkeys, if empty) char *keyword[] : keyword table (no keyword, if empty) The tables chainkey, blockkey and keyword must be terminated with (char *) NULL. RETURN VALUE 1: success 0: failed ---------------------------------------------------------------------------*/ int edf_dump( FILE * out, int stream, int format, char * chainkey[], char * blockkey[], char * keyword[] ) { DFile * file; DChain * chain; DBlock * block; char **pckey, **pbkey; int newchain, newline=0; /* check stream */ if ((stream<0)||(stream>=MaxFiles)) return(0); /* get file */ file = &FileTable[stream]; if ( !file->Used ) return(0); if ( (format==1) && ((!keyword)||(!keyword[0])) ) format=101; if ((format==0)||(format==10000)||(format==10001)) fprintf(out,"file = %s\r\n",file->Name); if ( chainkey && chainkey[0] ) { // specific chains only for (pckey=chainkey;*pckey!=(char*) NULL;pckey++) { newchain = True; if (!search_data_chain( file, * pckey, &chain )) { if ( blockkey && blockkey[0] ) { // specific blocks only for (pbkey=blockkey;*pbkey!=(char*) NULL;pbkey++) { if (!search_data_block( chain, * pbkey, &block )) { if ( !(is_general_block( block )) ) { edf_dump_format ( out, block, format, newchain, keyword ); newline=1; } newchain = False; } } // for block } else { // loop over all blocks block = chain->BlockList; while (block!=(DBlock*) NULL) { if ( !(is_general_block( block )) ) { edf_dump_format ( out, block, format, newchain, keyword ); newline=1; } block = block->Next; newchain = False; } // while block } // if (blockkey .. if ( (10<=format) && (newline) ) fprintf(out,"\r\n"); } } // for chain } else { // loop over all chains chain = file->ChainList; while(chain!=(DChain*) NULL) { newchain = True; if ( blockkey && blockkey[0] ) { // specific blocks only for (pbkey=blockkey;*pbkey!=(char*) NULL;pbkey++) { if (!search_data_block( chain, * pbkey, &block )) { if ( !(is_general_block( block )) ) { edf_dump_format ( out, block, format, newchain, keyword ); newline=1; } newchain = False; } } // for block } else { // loop over all blocks block = chain->BlockList; while (block!=(DBlock*) NULL) { if ( !(is_general_block( block )) ) { edf_dump_format ( out, block, format, newchain, keyword ); newline=1; } block = block->Next; newchain = False; } // while block } // if (blockkey .. if ( (10<=format) && (newline) ) fprintf(out,"\r\n"); chain = chain->Next; } // while chain } // if ( chainkey .. return(1); } // edf_dump /*+++------------------------------------------------------------------------ NAME edf_print_header SYNOPSIS int edf_print_header( FILE * out, const char * header_key, int level, int verbose ); DESCRIPTION Prints contents of header ´header_key´ to ´out´, or contents of all headers, if ´header_key´ is NULL. RETURN VALUE 1: success 0: failed (specified header not found) ---------------------------------------------------------------------------*/ int edf_print_header( FILE * out, const char * header_key, int level, int verbose ) { const char * SeparationLine = "- - - - - - - - - - - - - - -"; HList * header, * stop = (HList*) NULL; if (HEADER_debug) printf("edf_print_header\n"); if (level<1) return(0); if (!InitHeader) init_header(); if ( header_key != (const char *) NULL ) { // list a single header search_header_list ( header_root, header_key, &header ); if ( header == (HList *) NULL ) return(0); stop = header->Next; } else header = header_root; // list all headers while ( header != stop ) { if (verbose) { fprintf(out," %s\n",SeparationLine); fprintf(out," Header key = %s\n",header->Key); fprintf(out," Previous Key = "); if ((header->Previous)!=(HList*) NULL) fprintf(out,"%s\n", header->Previous->Key); else fprintf(out,"(no previous header)\n"); fprintf(out," Next Key = "); if ((header->Next)!=(HList*) NULL) fprintf(out,"%s\n", header->Next->Key); else fprintf(out,"(no next header)\n"); print_header_list( out, header, level-1, verbose ); fprintf(out," KeyOrderNo = %d\n",header->KeyOrderNo); } else { fprintf(out," Header key = %s\n",header->Key); print_header_list( out, header, level-1, verbose ); } header=header->Next; } if (verbose) fprintf(out," %s\n",SeparationLine); return(1); } /* edf_print_header */ /*+++------------------------------------------------------------------------ NAME edf_read_header --- reads all user keys and values from a header SYNOPSIS int edf_read_header ( int stream, long DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus); DESCRIPTION Reads all user keys and values from the data header and the general header. It writes them to the element list with the name ´header_key´. The header can be released with edf_free_header( ´header_key´ ); RETURN VALUE return value FALSE if not found and no other error return( int ) FALSE : data header not found, *pstatus = status_error; *pErrorValue=(CouldNotFindHeader, RoutineSucceeded); TRUE : data header found or error, *pstatus = Success or status_error; *pErrorValue = HISTORY 2000-12-31 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_read_header ( int stream, long DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus) { DBlock * block; HList * header; int errval, status; if (HEADER_debug) printf("edf_read_header BEGIN\n"); if (!InitHeader) init_header(); search_header_list ( header_root, header_key, &header ); if ( header == (HList*)NULL ) // try to create it header_list_new ( &header_root, header_key, &header ); if ( header == (HList*)NULL ) { errval = CouldNotCreateHeader; // cannot create header goto edf_read_header_error; } switch ( open_read_block (stream, DataNumber, DataChain, &block, &errval ) ) { case 1: goto edf_read_header_notfound; case -1: goto edf_read_header_error; } /* read keyword list from general block and copy it to element list */ if ( read_header_list( block->Chain->File->GeneralBlock, header ) ) { errval = CouldNotReadGeneralHeader; goto edf_read_header_error; } /* read keyword list from block and copy it to element list */ if ( read_header_list( block, header ) ) { errval = CouldNotReadHeader; goto edf_read_header_error; } if ( close_read_block( block, &errval ) ) goto edf_read_header_error; errval = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (HEADER_debug) printf("edf_read_header END\n"); return(1); edf_read_header_notfound: status = status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (HEADER_debug) { printf("edf_read_header: %s",edf_report_data_error ( errval )); printf("edf_read_header END (status=%d)\n",status); } return(0); edf_read_header_error: status = status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (HEADER_debug) { printf("edf_read_header: %s",edf_report_data_error ( errval )); printf("edf_read_header END (status=%d)\n",status); } return(1); } /* edf_read_header */ /*+++------------------------------------------------------------------------ NAME edf_write_header --- writes a header symbol list into the header SYNOPSIS int edf_write_header ( int stream, long DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus ) DESCRIPTION Writes the elementlist with the name ´header_key´ into the header of the specified image. RETURN VALUE In case of success the return value is 1, otherwise 0. HISTORY 2000-12-31 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_write_header ( int stream, long DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus ) { DBlock * block; HList * header; int errval, status; if (HEADER_debug) printf("edf_write_header\n"); if (!InitHeader) init_header(); search_header_list ( header_root, header_key, &header ); if ( header == (HList*) NULL ) { errval=CouldNotFindHeaderKey; goto edf_write_header_error; } if ( open_write_block (stream, DataNumber, DataChain, &block, &errval ) ) goto edf_write_header_error; /* create/replace keyword and value in header */ if ( write_header_list( block, header )) { errval = CouldNotInsertSymbol; goto edf_write_header_error; } if ( close_write_block( block, &errval ) ) goto edf_write_header_error; /* The header was changed and must be written to disk */ block->Flags.HeaderChanged = True; errval = RoutineSucceeded; status = status_success; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (HEADER_debug) printf("edf_write_header END\n"); return(1); edf_write_header_error: status=status_error; if (pErrorValue) *pErrorValue = errval; if (pstatus) *pstatus = status; if (HEADER_debug) { printf("edf_write_header: %s",edf_report_data_error ( errval )); printf("edf_write_header END (status=%d)\n",status); } return(0); } /* edf_write_header */ /*+++------------------------------------------------------------------------ NAME edf_first_header_element --- return first element of header ´header_key´ SYNOPSIS int edf_first_header_element( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ) DESCRIPTION The first element is read from the header list with the name ´header_key´. A pointer to the key of this element is returned in *pkey and a pointer to the value of this key is returned in *pvalue. If the end of the header list is reached or in case of an error NULL-pointers are returned. RETURN VALUE In case of success the return value is 1, otherwise 0. HISTORY 2001-11-24 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_first_header_element( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ) { HList * header; HElement * element; *pstatus = status_error; *pErrorValue = RoutineSucceeded; *pkey = (const char *) NULL; *pvalue = (const char *) NULL; if (HEADER_debug) printf("edf_first_header_element\n"); if (!InitHeader) init_header(); search_header_list ( header_root, header_key, &header ); if ( header == (HList*) NULL ) { *pErrorValue=CouldNotFindHeaderKey; return(0); } // header key not found keyorder_first_header_element( header, &element ); if ( element != (HElement *) NULL ) { *pkey = element->Key; *pvalue = element->Value; } *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(1); } /* edf_first_header_element */ /*+++------------------------------------------------------------------------ NAME edf_next_header_element --- return next element from header ´header_key´ SYNOPSIS int edf_next_header_element( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ) DESCRIPTION The next element is read from the header list with the name ´header_key´. A pointer to the key of this element is returned in *pkey and a pointer to the value of this key is returned in *pvalue. If the end of the header list is reached or in case of an error NULL-pointers are returned. Before using this function edf_first_header_element must have been called. RETURN VALUE In case of success the return value is 1, otherwise 0. HISTORY 2001-11-24 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_next_header_element( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ) { HList * header; HElement * element; *pstatus = status_error; *pErrorValue = RoutineSucceeded; *pkey = (const char *) NULL; *pvalue = (const char *) NULL; if (HEADER_debug) printf("edf_next_header_element\n"); if (!InitHeader) init_header(); search_header_list ( header_root, header_key, &header ); if ( header == (HList*) NULL ) { *pErrorValue=CouldNotFindHeaderKey; return(0); } // header key not found keyorder_next_header_element( header, &element ); if ( element != (HElement *) NULL ) { *pkey = element->Key; *pvalue = element->Value; } *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(1); } /* edf_next_header_element */ /*+++------------------------------------------------------------------------ NAME edf_search_header_element --- return value of header element SYNOPSIS int edf_search_header_element( const char * header_key, const char * key, const char ** pvalue, int * pErrorValue, int * pstatus ) DESCRIPTION The value of the element with name 'key' is read from the header list with the name ´header_key´. A pointer to the value of this key is returned in *pvalue. If the key was not found or in case of an error NULL-pointers are returned. RETURN VALUE In case of success (found) the return value is 1, otherwise 0. HISTORY 2002-01-08 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_search_header_element( const char * header_key, const char * key, const char ** pvalue, int * pErrorValue, int * pstatus ) { HList * header; HElement * element; int retval=0; *pstatus = status_error; *pErrorValue = RoutineSucceeded; *pvalue = (const char *) NULL; if (HEADER_debug) printf("edf_search_header_element\n"); if (!InitHeader) init_header(); search_header_list ( header_root, header_key, &header ); if ( header == (HList*) NULL ) { *pErrorValue=CouldNotFindHeaderKey; return(retval);} //header key not found search_header_element( header, key, &element ); if (element) { *pvalue = element->Value; retval = 1; } *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(retval); } /* edf_search_header_element */ /*+++------------------------------------------------------------------------ NAME edf_add_header_element --- add an element to header ´header_key´ SYNOPSIS int edf_add_header_element ( const char * header_key, const char * key, const char * value, int * pErrorValue, int * pstatus ) DESCRIPTION An element with key and value is inserted into the header list with the name ´header_key´. If a key with the same name already exists its value is replaced by the new value. Before using this function a header must have been created with edf_new_header. RETURN VALUE In case of success the return value is 1, otherwise 0. HISTORY 2001-12-08 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_add_header_element ( const char * header_key, const char * key, const char * value, int * pErrorValue, int * pstatus ) { HList * header; HElement * element; *pstatus = status_error; *pErrorValue = RoutineSucceeded; if (HEADER_debug) printf("edf_add_header_element\n"); if (!InitHeader) init_header(); search_header_list ( header_root, header_key, &header ); if ( header == (HList*) NULL ) { *pErrorValue=CouldNotFindHeaderKey; return(0); } // header key not found insert_header_element( header, key, value, &element ); if ( element == (HElement*) NULL) { *pErrorValue=CouldNotInsertElement; return(0);} // header not updated *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(1); } /* edf_add_header_element */ /*+++------------------------------------------------------------------------ NAME edf_delete_header_element --- remove an element from header ´header_key´ SYNOPSIS int edf_delete_header_element( const char * header_key, const char * key, int * pErrorValue, int * pstatus ); DESCRIPTION If an element with the name 'key' is found in the header with the name ´header_key´ it is removed otherwise nothing is done. In both cases the function returns with success. Before using this function a header must have been created with edf_new_header. RETURN VALUE In case of success the return value is 1, otherwise 0. HISTORY 2001-12-08 Peter Boesecke --------------------------------------------------------------------------+*/ int edf_delete_header_element( const char * header_key, const char * key, int * pErrorValue, int * pstatus ) { HList * header; *pstatus = status_error; *pErrorValue = RoutineSucceeded; if (HEADER_debug) printf("edf_add_header_element\n"); if (!InitHeader) init_header(); search_header_list ( header_root, header_key, &header ); if ( header == (HList*) NULL ) { *pErrorValue=CouldNotFindHeaderKey; return(0); } // header key not found remove_header_element( header, key ); *pErrorValue = RoutineSucceeded; *pstatus = status_success; return(1); } /* edf_add_header_element */ /*+++------------------------------------------------------------------------ NAME edf_new_header SYNOPSIS int edf_new_header ( const char * name ); DESCRIPTION This routines must be called first. If not already initialized, it initializes the header module and creates a header that can be accessed with name. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_new_header ( const char * header_key ) { HList * header; if (HEADER_debug) printf("\n edf_new_header BEGIN\n"); if (!InitHeader) init_header(); if (header_list_new ( &header_root, header_key, &header ) ) return(0); if (HEADER_debug) printf("\n edf_new_header END\n"); return(1); } /* edf_new_header */ /*+++------------------------------------------------------------------------ NAME edf_free_header SYNOPSIS int edf_free_header ( const char * header_key ); DESCRIPTION This routine removes all header lists with its contents. If not already initialized, it initializes the header module. RETURN VALUES In case of success the return value is 1, otherwise 0. --------------------------------------------------------------------------+*/ int edf_free_header ( const char * header_key ) { int retval; if (HEADER_debug) printf("\n edf_free_header BEGIN\n"); retval = 1; if (!InitHeader) init_header(); if ( header_key == (const char *) NULL ) { // remove all keys if (header_list_free ( &header_root ) ) retval = 0; } else { // remove header_key if (header_list_remove ( &header_root, header_key ) ) retval = 0; } if (HEADER_debug) printf("\n edf_free_header END\n"); return(retval); } /* edf_free_header */ /*-------------------------------------------------------------------------- NAME header_debug --- set / reset module history into debug mode SYNOPSIS void header_debug ( int debug ); DESCRPTION Writes ´debug´ into HEADER_debug. -----------------------------------------------------------------------------*/ void header_debug ( int debug ) { HEADER_debug = debug; } /* header_debug */ /*===header_list END====================================================---*/ /*+++------------------------------------------------------------------------ NAME edf_free_all --- remove all allocated memory SYNOPSIS int edf_free_all ( void ); DESCRIPTION Closes everything and releases all allocated memory buffers. --------------------------------------------------------------------------+*/ int edf_free_all ( void ) /*---*/ { edf_history_free( (const char *) NULL ); edf_free_header( (const char *) NULL ); edf_free_data_file(); return(1); } /* edf_free_all */ /*+++------------------------------------------------------------------------ NAME edf_report_data_error --- returns the error message of ErrorValue SYNOPSIS char * edf_report_data_error ( int ErrorValue ); DESCRIPTION Allocates a buffer and copies the error message corresponding to ´ErrorValue´. It returns a pointer to the allocated buffer. HISTORY --------------------------------------------------------------------------+*/ // PRIVATE const char *NDFE = "NoDataFormatError"; //unused PRIVATE const char *UEV = "UnknownErrorValue"; PRIVATE const char *RF = "RoutineFailed"; PRIVATE const char *RS = "RoutineSucceeded"; PRIVATE const char *CNMM = "CouldNotMallocMemory"; PRIVATE const char *CNFH = "CouldNotFreeHeaders"; PRIVATE const char *CNGA = "CouldNotGetBinaryArray"; PRIVATE const char *NMSA = "NoMoreStreamsAvailable"; PRIVATE const char *INVS = "InvalidStream"; PRIVATE const char *CNOF = "CouldNotOpenFile"; PRIVATE const char *EOFD = "EndOfFileDetected"; PRIVATE const char *CNFI = "CouldNotFindHeader"; PRIVATE const char *CNFS = "CouldNotFindSymbol"; // PRIVATE const char *BSD = "BadSizeDefinition"; // unused PRIVATE const char *BDB = "BadDataBlock"; PRIVATE const char *CNFK = "CouldNotFindKeyword"; PRIVATE const char *WDE = "WriteDataError"; PRIVATE const char *RDE = "ReadDataError"; PRIVATE const char *NFO = "NoFileOpen"; PRIVATE const char *NEDF = "NotESRFDataFile"; PRIVATE const char *NDBF = "NoDataBlocksFound"; PRIVATE const char *ED = "ExternalData"; PRIVATE const char *FINW = "FileIsNotWritable"; PRIVATE const char *FINO = "FileIsNotOpened"; PRIVATE const char *IOM = "IncompatibleOpeningModes"; PRIVATE const char *CNCF = "CouldNotCloseFile"; PRIVATE const char *CNCB = "CouldNotCloseBlock"; PRIVATE const char *CNIC = "CouldNotInsertChain"; PRIVATE const char *CNIB = "CouldNotInsertBlock"; PRIVATE const char *CNIS = "CouldNotInsertSymbol"; PRIVATE const char *MKD = "MissingKeyDefinition"; PRIVATE const char *GBNF = "GeneralBlockNotFirst"; PRIVATE const char *ECGB = "ErrorCreatingGeneralBlock"; PRIVATE const char *ERGB = "ErrorReadingGeneralBlock"; PRIVATE const char *ELB = "ErrorLocatingBlocks"; PRIVATE const char *CNSB = "CouldNotSetBuffer"; PRIVATE const char *NCVF = "NumberConversionFailed"; PRIVATE const char *DCVF = "DataConversionFailed"; PRIVATE const char *DBTS = "DataBufferTooSmall"; PRIVATE const char *MAD = "MissingArrayDimensions"; PRIVATE const char *NND = "NotNdData"; PRIVATE const char *N2D = "Not2dData"; PRIVATE const char *CNWD = "CouldNotWriteDimension"; PRIVATE const char *CNRD = "CouldNotReadDimension"; PRIVATE const char *CNWB = "CouldNotWriteBinary"; PRIVATE const char *CROG = "CannotReOpenGeneralBlock"; PRIVATE const char *COAB = "CannotOpenAsBslFile"; PRIVATE const char *CNIE = "CouldNotInsertElement"; PRIVATE const char *CNDS = "CouldNotDeleteString"; PRIVATE const char *CNFY = "CouldNotFindHeaderKey"; PRIVATE const char *CNCH = "CouldNotCreateHeader"; PRIVATE const char *CNRG = "CouldNotReadGeneralHeader"; PRIVATE const char *CNRH = "CouldNotReadHeader"; char * edf_report_data_error ( int ErrorValue ) /*---*/ { char * errmsg; errmsg = (char *) malloc(BufferSize); switch (ErrorValue) { case RoutineFailed : sprintf(errmsg,"\n%s\n",RF); break; case RoutineSucceeded : sprintf(errmsg,"\n%s\n",RS); break; case CouldNotMallocMemory : sprintf(errmsg,"\n%s\n",CNMM); break; case CouldNotFreeHeaders : sprintf(errmsg,"\n%s\n",CNFH); break; case NoMoreStreamsAvailable : sprintf(errmsg,"\n%s\n",NMSA); break; case InvalidStream : sprintf(errmsg,"\n%s\n",INVS); break; case CouldNotOpenFile : sprintf(errmsg,"\n%s\n",CNOF); break; case EndOfFileDetected : sprintf(errmsg,"\n%s\n",EOFD); break; case CouldNotFindHeader : sprintf(errmsg,"\n%s\n",CNFI); break; case CouldNotFindSymbol : sprintf(errmsg,"\n%s\n",CNFS); break; case CouldNotGetBinaryArray : sprintf(errmsg,"\n%s\n",CNGA); break; case BadDataBlock : sprintf(errmsg,"\n%s\n",BDB); break; case CouldNotFindKeyword : sprintf(errmsg,"\n%s\n",CNFK); break; case WriteDataError : sprintf(errmsg,"\n%s\n",WDE); break; case ReadDataError : sprintf(errmsg,"\n%s\n",RDE); break; case NoFileOpen : sprintf(errmsg,"\n%s\n",NFO); break; case NotESRFDataFile : sprintf(errmsg,"\n%s\n",NEDF); break; case NoDataBlocksFound : sprintf(errmsg,"\n%s\n",NDBF); break; case ExternalData : sprintf(errmsg,"\n%s\n",ED); break; case FileIsNotWritable : sprintf(errmsg,"\n%s\n",FINW); break; case FileIsNotOpened : sprintf(errmsg,"\n%s\n",FINO); break; case IncompatibleOpeningModes : sprintf(errmsg,"\n%s\n",IOM); break; case CouldNotCloseFile : sprintf(errmsg,"\n%s\n",CNCF); break; case CouldNotCloseBlock : sprintf(errmsg,"\n%s\n",CNCB); break; case CouldNotInsertChain : sprintf(errmsg,"\n%s\n",CNIC); break; case CouldNotInsertBlock : sprintf(errmsg,"\n%s\n",CNIB); break; case CouldNotInsertSymbol : sprintf(errmsg,"\n%s\n",CNIS); break; case MissingKeyDefinition : sprintf(errmsg,"\n%s\n",MKD); break; case GeneralBlockNotFirst : sprintf(errmsg,"\n%s\n",GBNF); break; case ErrorCreatingGeneralBlock: sprintf(errmsg,"\n%s\n",ECGB); break; case ErrorReadingGeneralBlock : sprintf(errmsg,"\n%s\n",ERGB); break; case ErrorLocatingBlocks : sprintf(errmsg,"\n%s\n",ELB); break; case CouldNotSetBuffer : sprintf(errmsg,"\n%s\n",CNSB); break; case NumberConversionFailed : sprintf(errmsg,"\n%s\n",NCVF); break; case DataConversionFailed : sprintf(errmsg,"\n%s\n",DCVF); break; case DataBufferTooSmall : sprintf(errmsg,"\n%s\n",DBTS); break; case MissingArrayDimensions : sprintf(errmsg,"\n%s\n",MAD); break; case NotNdData : sprintf(errmsg,"\n%s\n",NND); break; case Not2dData : sprintf(errmsg,"\n%s\n",N2D); break; case CouldNotWriteDimension : sprintf(errmsg,"\n%s\n",CNWD); break; case CouldNotReadDimension : sprintf(errmsg,"\n%s\n",CNRD); break; case CouldNotWriteBinary : sprintf(errmsg,"\n%s\n",CNWB); break; case CannotReOpenGeneralBlock : sprintf(errmsg,"\n%s\n",CROG); break; case CannotOpenAsBslFile : sprintf(errmsg,"\n%s\n",COAB); break; case CouldNotInsertElement : sprintf(errmsg,"\n%s\n",CNIE); break; case CouldNotDeleteString : sprintf(errmsg,"\n%s\n",CNDS); break; case CouldNotFindHeaderKey : sprintf(errmsg,"\n%s\n",CNFY); break; case CouldNotCreateHeader : sprintf(errmsg,"\n%s\n",CNCH); break; case CouldNotReadGeneralHeader: sprintf(errmsg,"\n%s\n",CNRG); break; case CouldNotReadHeader : sprintf(errmsg,"\n%s\n",CNRH); break; default : sprintf(errmsg,"\n%s : %d\n",UEV,ErrorValue); } return(errmsg); } /* edf_report_data_error */ /*****************************************************************************/ /*+++-------------------------------------------------------------------------- NAME edfio_debug --- set / reset module into debug mode SYNOPSIS void edfio_debug ( int debug ); DESCRPTION Sets/resets all sub-modules into debug mode ----------------------------------------------------------------------------+*/ void edfio_debug ( int debug ) /*---*/ { EDFIO_debug = debug; cmpr_debug ( EDFIO_debug ); raster_debug ( EDFIO_debug ); hist_debug ( EDFIO_debug ); header_debug ( EDFIO_debug ); keyorder_debug ( EDFIO_debug ); numio_debug ( EDFIO_debug ); } /* edfio_debug */ /*****************************************************************************/ spd-1.3.0/edfpack/bslio.h0000644000175000017500000000773711633462462012125 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME bslio.h DESCRIPTION Include file for bslio.c HISTORY 22-Mar-1998 Peter Boesecke 2000-12-31 PB V0.53 2001-01-23 PB V0.54 u_long -> unsigned long 2000-01-12 PB V0.54 Visual C++ compatibility ***************************************************************************/ #ifndef BSLIO /*************************************************************************** * Includes * ***************************************************************************/ #include "edfio.h" /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif /*************************************************************************** * Data Structure * ***************************************************************************/ typedef struct Bsl_Data_Specification { char *BinaryFileName; unsigned long BinaryFilePos; unsigned long BinaryFileLen; void *Data; long *Dim; /* Dim[0]=nn, Dim[1], ... Dim[nn] */ int DataType; int ByteOrder; long RasterConfiguration; int Compression; } BslDataSpec; /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern int open_bsl_file ( const char * FileName , const char * mode ), close_bsl_file ( int stream ), bsl_memory_range( int stream, long * minmem, long *maxmem ), bsl_frame_range( int stream, long memnum, long * minfra, long * maxfra ); PUBLIC extern BslDataSpec *read_bsl_data_spec ( int stream, long memnum, long franum ); PUBLIC extern void read_bsl_file_headers ( int stream, char **first_header, char **second_header ); /*************************************************************************** * Debug routines * ***************************************************************************/ PUBLIC extern void print_bsl_data_spec ( FILE * out, const BslDataSpec * data_spec ), print_bsl_filetable ( FILE * out, int level, int verbose ); PUBLIC extern char *bslio_version ( void ); #endif #ifndef BSLIO # define BSLIO #endif /***************************************************************************/ spd-1.3.0/edfpack/sx.h0000644000175000017500000001547011635105403011427 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME sx.h SYNOPSIS #include "sx.h" DESCRIPTION Header of the module "sx.c" ***********************************************************************---*/ #ifndef _SX_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include "strlib.h" # include "numio.h" # include "raster.h" # include "rot3d.h" # include "tilt3d.h" # include "r2t.h" # include "reference.h" /*************************************************************************** * MACROS * ***************************************************************************/ /****************************************************************************** * Public Type Defs * ******************************************************************************/ typedef struct sx_short { short V; int I; } SXS; typedef struct sx_int { int V; int I; } SXI; typedef struct sx_long { long V; int I; } SXL; typedef struct sx_float { float V; int I; } SXF; typedef struct sx_double { double V; int I; } SXD; typedef struct sx_params { SXI pro; // projection type (IO_ProSaxs, IO_ProWaxs) SXL ori; // orientation number (1-16) SXI axis1; SXI axis2; // axis types (IO_AxisTypeDistance, // IO_AxisTypeAngle, IO_AxisTypeNumerator) SXL dim1; SXL dim2; // dimensions of 2d array SXD off1; SXD off2; // offsets of array coordinates SXD bis1; SXD bis2; // binning sizes SXD ras1; SXD ras2; // raster region of 2d array SXD pix1; SXD pix2; // pixel sizes [m] SXD cen1; SXD cen2; // PONI (point of normal incidence) SXD dis; // distance sample-PONI [m] SXD rot1; SXD rot2; SXD rot3; // detector rotations [rad] SXD wvl; // wavelength [m] SXD bcen1; SXD bcen2; // beam center (alt. cen1, cen2) SXD bdis; // distance sample-bcen [m] (alt. dis) SXD tilt1; SXD tilt2; SXD tilt3; // detector tilts [rad] } SXParams; /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern SXParams *sx_new ( SXParams * params ), *sx_free ( SXParams * params ), *sx_init ( SXParams * params ), *sx_cp_params ( SXParams *params_out, const SXParams *params_in ), *sx_tf_params ( SXParams * params_out, const SXParams * params_in, long ori, int rot, int *perrval ), *sx_rd_params ( SXParams * params_out, char *argv[], int * perrval ); PUBLIC extern int sx_pr_params( FILE * out, const SXParams * params ), sx_pr_params_line( FILE *out, const SXParams *params, int head ); PUBLIC extern int sx_tf_img ( SXParams *params_out, void *data_out, void *variance_out, size_t item_number, const SXParams *params_in, const void *data_in, const void *variance_in, size_t item_size, long ori, int rot, int *perrval ); PUBLIC extern int sx_debug_set( int debug ), sx_debug ( void ), sx_level ( void ); PUBLIC extern const char *sx_version ( void ), *sx_usage2str( void ); PUBLIC extern char *sx_errval2str ( char buffer[], size_t buflen, int errval ); /*************************************************************************** * Definitions * ***************************************************************************/ # define SXBUFLEN 1024 # define SX_VERBOSE 0x1 # define SX_LEVEL 0x6 // 0x2 0x4 -> level 0 -> 3 # define SX_SHOWDATA 0x8 # define SX_SHOWTEMP 0x10 # define SX_DEBUG 0x20 # define SX_RASTER_DEBUG 0x40 /*************************************************************************** * Error Values * ***************************************************************************/ # define SX_SUCCESS 0 # define SX_NULL_POINTER 1 # define SX_INVALID_PROJECTION 2 # define SX_INVALID_ORIENTATION 3 # define SX_INVALID_AXISTYPE 4 # define SX_MEMORY_ALLOCATION_ERROR 5 # define SX_ORDER_CALCULATION_ERROR 6 # define SX_MATRIX_CALCULATION_ERROR 7 # define SX_ANGLE_CALCULATION_ERROR 8 # define SX_BEAMCENTER_CALCULATION_ERROR 9 # define SX_BEAMDISTANCE_CALCULATION_ERROR 10 # define SX_CENTER_CALCULATION_ERROR 11 # define SX_DISTANCE_CALCULATION_ERROR 12 # define SX_COPY_ERROR 13 # define SX_ARRAY_TOOSMALL 14 # define SX_RASTER_ERROR 15 // must be the last # define _SX_ #endif /* _SX_ */ /**************************************************************************** * * ****************************************************************************/ spd-1.3.0/edfpack/readascii.c0000644000175000017500000005554411633462461012732 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define READASCII_VERSION "readascii : V1.0 2007-09-07 Peter Boesecke" /*+++*********************************************************************** NAME readascii.c SYNOPSIS #include "readascii.h" INCLUDE FILES numio.h edfio.h filename.h TO LINK WITH standard C libraries edfio, bslio, numio, gamma, filename DESCRIPTION Header of the module "readascii.c" PURPOSE Conversion of ascii tables to float See PUBLIC functions for detail. PUBLIC ROUTINES // open, read and close a file RADescr *RA_openfile(const char *filename, int verbose, int *pstatus); long RA_readfile( RADescr * descr, float ** pdata, int * pstatus ); void RA_closefile( RADescr * descr, int * pstatus ); // set special parameters, defaults are used, if not set int RA_setbskp( RADescr * descr, long bskp ); int RA_setlskp( RADescr * descr, long lskp ); int RA_setcskp( RADescr * descr, long cskp ); int RA_setskipcol( RADescr * descr, long skipcol ); int RA_setskiprow( RADescr * descr, long skiprow ); int RA_setdim1( RADescr * descr, long dim1 ); int RA_setdim2( RADescr * descr, long dim2 ); int RA_setori( RADescr * descr, long ori ); int RA_setdummy( RADescr * descr, float dummy ); int RA_setdelimiterset( RADescr * descr, const char *delimiterset ); int RA_setcommentset( RADescr * descr, const char *commentset ); // return version string const char * RA_version ( void ); AUTHOR 2007 Peter Boesecke (PB) HISTORY 2007-09-07 V1.0 PB ***************************************************************************/ /*************************************************************************** * Private Include * ***************************************************************************/ # include "readascii.h" /*************************************************************************** * Private Definitions * ***************************************************************************/ /* Elements longer than RA_MAXELEMENTWIDTH-1 are truncated */ # define RA_MAXELEMENTWIDTH 1024 /*************************************************************************** * PRIVATE Constants and Variables * ***************************************************************************/ PRIVATE char RA_white_spaces[7] = { ' ', '\t', '\r', '\n', '\f', '\v', '\0' }; PRIVATE char RA_new_line[2] = { '\n', '\0' }; PRIVATE int RAInit = 0; PRIVATE RADescr * RA_root = (RADescr *) NULL; /***************************************************************************/ /**************************************************************************** * Routines * ****************************************************************************/ /*+++------------------------------------------------------------------------ NAME RA_version --- return version string SYNOPSIS const char * RA_version ( void ); DESCRIPTION RETURN VALUE Pointer to a constant character string containing the version of this module. ----------------------------------------------------------------------------*/ PUBLIC const char * RA_version ( void ) { return(READASCII_VERSION); } // RA_version char * RA_newstr( const char * string ) { char * newstring; if (!(newstring = (char *) malloc(strlen(string)+1))) return((char *) NULL); (void) strcpy(newstring,string); return( newstring ); } /* RA_newstr */ /*--------------------------------------------------------------------------- NAME RA_is_member SYNOPSIS int RA_is_member ( const char * chargroup, char c ); DESCRIPTION Returns 1 if c is contained in the string chargroup, 0, if not. HISTORY 18-Jan-1998 Peter Boesecke ---------------------------------------------------------------------------*/ int RA_is_member ( const char * chargroup, char c ) { if ( strchr( chargroup, (int) c ) ) return(1); /* is member */ else return(0); /* is not member */ } /* RA_is_member */ /*--------------------------------------------------------------------------- NAME RA_init() SYNOPSIS DESCRIPTION RETURN VALUES Returns 0 in case of success and -1 if no success. --------------------------------------------------------------------------*/ int RA_init( void ) { RA_root = (RADescr *) NULL; RAInit = 1; return(0); } /* RA_init */ int RA_descr_new ( RADescr ** proot, const char * key, RADescr ** pdescr ) { RADescr * newhlist, * previous, * next; int notfound = 1; /* search for key */ previous = (RADescr *) NULL; next = *proot; *pdescr = (RADescr *) NULL; /* search insertion point (insertion before next) */ while( ( next!=(RADescr *) NULL ) && (notfound>0) ) { notfound = strcmp(next->Key,key); if (notfound>0) {previous = next; next = next->Next;} } if (notfound) { /* create new hlist */ if (!(newhlist = (RADescr *) malloc(sizeof(RADescr)))) return(-1); newhlist->Key = RA_newstr(key); if (!newhlist->Key) return(-1); /* insert newhlist before next */ if (next) next->Previous = newhlist; newhlist->Next=next; newhlist->Previous=previous; if (previous) previous->Next=newhlist; else *proot = newhlist; next = newhlist; } next->in=(FILE *) NULL; next->verbose=0; next->filename=RA_newstr(key); // -1 == "undetermined/not set" next->bskp=-1; next->lskp=-1; next->cskp=-1; next->skipcol=-1; next->skiprow=-1; next->dim1=-1; next->dim2=-1; next->cnt=-1; next->ori=1; next->dummy=0.0; next->delimiterset=RA_newstr(RA_white_spaces); next->commentset=RA_newstr("#"); next->buffer=(float *) NULL; next->bufsiz=(size_t) NULL; *pdescr = next; return(0); } /* RA_descr_new */ int RA_descr_remove ( RADescr ** proot, RADescr * descr ) { RADescr *current, *previous, *next; next = descr; if ( next!=(RADescr *) NULL ) { current = next; previous = current->Previous; next = current->Next; // unlink descr if (next) next->Previous = previous; if (previous) previous->Next = next; else *proot = next; // release memory of descr if (current->filename) free(current->filename); if (current->Key) free(current->Key); if (current->buffer) free( current->buffer ); if (current->delimiterset) free( current->delimiterset ); if (current->commentset) free( current->commentset ); free ( current ); } return(0); } /* RA_descr_remove */ RADescr * RA_new_descr ( const char * key, int verbose ) { RADescr * descr = (RADescr *) NULL; if (!RAInit) RA_init(); RA_descr_new ( &RA_root, key, &descr ); if (!descr) return(descr); descr->verbose = verbose; return( descr ); } /* RA_new_descr */ int RA_rm_descr ( RADescr * descr ) { int status=0, verbose; if (!RAInit) RA_init(); verbose = descr->verbose; if ( (status=RA_descr_remove( &RA_root, descr )) ) return(status); return(status); } /* RA_rm_descr */ void _fprintset( FILE * out, const char * set ) { const char *ps; ps=set; fprintf( out, ">>" ); while (*ps) { if ((int) *ps<32) fprintf( out, "\'%02x\'",(int) *ps); else fprintf( out, "%c",*ps); ps++; } fprintf( out, "<<\n"); } // _fprintset int RA_printdescr( FILE * out, RADescr * descr ) { fprintf(out," in=%p\n",descr->in); fprintf(out," verbose=%d\n",descr->verbose); if (descr->filename) fprintf(out," filename=>>%s<<\n",descr->filename); else fprintf(out," filename=(null)\n"); fprintf(out," bskp=%ld\n",descr->bskp); fprintf(out," lskp=%ld\n",descr->lskp); fprintf(out," cskp=%ld\n",descr->cskp); fprintf(out," skipcol=%ld\n",descr->skipcol); fprintf(out," skiprow=%ld\n",descr->skiprow); fprintf(out," dim1=%ld\n",descr->dim1); fprintf(out," dim2=%ld\n",descr->dim2); fprintf(out," cnt=%ld\n",descr->cnt); fprintf(out," ori=%ld\n",descr->ori); fprintf(out," dummy=%g\n",descr->dummy); fprintf(out," commentset=");_fprintset( out,descr->commentset ); fprintf(out,"delimiterset=");_fprintset( out,descr->delimiterset ); fprintf(out," bufsiz=%lu\n",descr->bufsiz); fprintf(out," buffer=%p\n",descr->buffer); return(0); } // RA_printdescr /*+++------------------------------------------------------------------------ NAME RA_ReadElement --- copies the next element into buffer SYNOPSIS char * RA_ReadElement ( FILE * in, const char * delimiterset, const char * commentset, char * buffer, size_t buflen, long *pnlcnt ); DESCRIPTION Leading and trailing delimiters are skipped. It reads the next element from 'in', copies it into buffer and positions the file pointer at the start of the next element or at the first character after a trailing new line. If buflen is 0, the next element is just skipped and buffer is not filled. In this case buffer is not accessed. In both cases the pointer to buffer is returned or NULL in case of an error. If a comment character is read the rest of the line is skipped. RETURN VALUES NULL : eof or error pointer to buffer *pnlcnt : incremented by 1 if a new line follows the read element ----------------------------------------------------------------------------*/ char * RA_ReadElement ( FILE * in, const char * delimiterset, const char * commentset, char * buffer, size_t buflen, long *pnlcnt ) { int c; long i=0; size_t csize; long newlinecount=0; csize = sizeof(char); if (buflen>=csize) buffer[0] = '\0'; c = fgetc(in); if (ferror(in)) return((char*) NULL); if (feof(in)) return(buffer); while ((RA_is_member ( delimiterset, c ))||(RA_is_member ( commentset, c ))) { // skip all leading delimiters, do not count leading line feeds while (RA_is_member ( delimiterset, c )) { c = fgetc(in); if (ferror(in)) return((char*) NULL); if (feof(in)) return(buffer); } if (RA_is_member ( commentset, c )) { // skip rest of the line do { c = fgetc(in); if (ferror(in)) return((char*) NULL); if (feof(in)) return(buffer); } while (!RA_is_member ( RA_new_line, c )); } } // copy input to buffer until next delimiter or comment while (!(RA_is_member ( delimiterset, c )||(RA_is_member ( commentset, c )))) { if ((csize*i)(csize*i)) buffer[i] = '\0'; else if ((buflen>=csize)&&(buflen>csize*(i-1))) buffer[i-1] = '\0'; // skip all trailing delimiters and comments, stop after RA_new_line or at feof while (RA_is_member ( delimiterset, c )) { if (RA_is_member ( RA_new_line, c )) break; c = fgetc(in); if (ferror(in)) return((char*) NULL); if (feof(in)) break; } if (RA_is_member ( commentset, c )) { // skip rest of the line do { c = fgetc(in); if (ferror(in)) return((char*) NULL); if (feof(in)) break; } while (!RA_is_member ( RA_new_line, c )); } if ((RA_is_member ( RA_new_line, c ))||(feof(in))) newlinecount++; if (!RA_is_member ( delimiterset, c )) ungetc(c,in); if (ferror(in)) return((char*) NULL); if (pnlcnt) *pnlcnt+=newlinecount; return( buffer ); } // RA_ReadElement /*+++------------------------------------------------------------------------ NAME RA_skipchar --- Skips character in delimiter skp times SYNOPSIS int RA_skipchar ( FILE * in, const char *delimiter, long skp ); DESCRIPTION Skips all file input until any of the characters in delimiter have been read skp times. The file pointer is positioned after the last occurence of this character. RETURN VALUES 0: OK, otherwise not found or other error ----------------------------------------------------------------------------*/ int RA_skipchar ( FILE * in, const char * delimiterset, long skp ) { int c=(int) ' '; long i=0; if (skp>0) { for (i=0;i1) printf("RA_openfile BEGIN\n"); if ( (!filename) || (strlen(filename)<=0) ) return(NULL); // set descr to default descr = RA_new_descr ( filename, verbose ); if (!descr) return(NULL); descr->in = fopen(filename,"r"); if (descr->in == (FILE *) NULL) { RA_rm_descr(descr); return(NULL); } if (pstatus) *pstatus = 0; if (verbose>1) printf("RA_openfile END\n"); return(descr); } // RA_openfile /*+++------------------------------------------------------------------------ NAME RA_closefile --- Close the file SYNOPSIS void RA_closefile( RADescr * descr, int * pstatus ); DESCRIPTION Closes the file and releases all allocated memory. RETURN VALUE void ----------------------------------------------------------------------------*/ PUBLIC void RA_closefile( RADescr * descr, int * pstatus ) { if (pstatus) *pstatus = -1; if (descr->verbose>1) printf("RA_closefile BEGIN\n"); if (descr) { fclose(descr->in); if (RA_rm_descr( descr )) return; } if (pstatus) *pstatus = 0; if (descr->verbose>1) printf("RA_closefile END\n"); } // RA_closefile /*+++------------------------------------------------------------------------ NAME RA_readfile --- Read ascii table from file and convert to float SYNOPSIS long RA_readfile( RADescr * descr, float ** pdata, int * pstatus ) DESCRIPTION Reads data from the input file according to the file descriptor. An output data buffer *pdata is allocated and must be released with RA_closefile. RETURN VALUES In case of success the number of read elements is returned. ----------------------------------------------------------------------------*/ PUBLIC long RA_readfile( RADescr * descr, float ** pdata, int * pstatus ) { long nread=0, cnt=0, maxcnt=-1, newlinecnt=0, linecnt=0; long itemcnt=0, ipl=-1, maxipl=-1, minipl=-1; long rowcnt, colcnt; long startpos; float tmp; size_t bufsiz; int errval; char buffer1[RA_MAXELEMENTWIDTH]; char * C1; if (pstatus) *pstatus = -1; if (descr->verbose>1) printf("RA_readfile BEGIN\n"); if (descr->verbose>3) RA_printdescr( stdout, descr ); if (!descr->in) return(nread); if (descr->ori<1) descr->ori=1; if (!descr->delimiterset) descr->delimiterset=RA_newstr(RA_white_spaces); if (!descr->commentset) descr->commentset=RA_newstr("#"); if ((descr->dim1>0)&&(descr->dim2>0)) maxcnt = descr->dim1*descr->dim2; // two passes if (descr->verbose>2) printf("1st pass\n"); // search start position, skip bskp bytes if (descr->bskp<0) descr->bskp=0; if ( fseek( descr->in, descr->bskp, SEEK_SET) ) { perror("RA_readfile->fseek(SEEK_SET)"); return(nread); } // skip lskp lines if (descr->lskp<0) descr->lskp=0; if (RA_skipchar ( descr->in, RA_new_line, descr->lskp )) return(nread); // skip cskp bytes if (descr->cskp<0) descr->cskp=0; if ( fseek( descr->in, descr->cskp, SEEK_CUR) ) { perror("RA_readfile->fseek(SEEK_CUR)"); return(nread); } // remember current position as start position startpos = ftell(descr->in); if (startpos == -1l) { perror("RA_readfile->ftell"); return(nread); } if (descr->skipcol<0) descr->skipcol=0; if (descr->skiprow<0) descr->skiprow=0; // 1st pass (if number of items is not specified in options) // count number of items (stop counting at eof) linecnt=newlinecnt; if (maxcnt<0) { // skip rows for (rowcnt=0;rowcntskiprow;) { C1 = RA_ReadElement( descr->in, descr->delimiterset, descr->commentset, buffer1, (size_t) 0, &rowcnt ); if (!C1) return(nread); if (feof(descr->in)) break; } // count all elements until eof colcnt=0; for (maxcnt=0;;) { if (linecnt!=newlinecnt) { ipl=itemcnt; itemcnt=0;linecnt=newlinecnt; if (maxipl<0) maxipl=ipl; else if (ipl>maxipl) maxipl=ipl; if (minipl<0) minipl=ipl; else if (iplin, descr->delimiterset, descr->commentset, buffer1, (size_t) 0, &newlinecnt ); if (!C1) return(nread); if (feof(descr->in)) break; // Do not count the the skipped columns if (colcnt>=descr->skipcol) { itemcnt++; maxcnt++; } colcnt++; } if ((descr->dim1<0)&&(descr->dim2<0)) { // guess dimensions if ((maxipl==minipl)&&(maxipl*newlinecnt==maxcnt)) { descr->dim1 = maxipl; descr->dim2 = newlinecnt; } else { descr->dim1 = 1; descr->dim2 = maxcnt; } } else { // calculate missing dimension if ((descr->dim1<0)&&(descr->dim2>0)) { if (maxcnt%descr->dim2) descr->dim1 = maxcnt/descr->dim2+1; else descr->dim1 = maxcnt/descr->dim2; } else if ((descr->dim2<0)&&(descr->dim1>0)) { if (maxcnt%descr->dim1) descr->dim2 = maxcnt/descr->dim1+1; else descr->dim2 = maxcnt/descr->dim1; } } maxcnt = descr->dim1*descr->dim2; } // if (maxcnt<0) ... // 2nd pass (always) if (descr->verbose>2) printf("2nd pass\n"); if (descr->verbose>3) RA_printdescr( stdout, descr ); if (descr->verbose>0) printf(" Reading file \'%s\' dim=%ldx%ld\n", descr->filename,descr->dim1,descr->dim2); // search start position if ( fseek( descr->in, startpos, SEEK_SET) ) { perror("RA_readfile->fseek(startpos)"); return(nread); } // allocate output buffer bufsiz = sizeof(float)*maxcnt; if (bufsiz) { descr->buffer = (float *) malloc( bufsiz ); if (descr->buffer) { descr->bufsiz = bufsiz; if (pdata) *pdata=descr->buffer; } else return(nread); } // fill buffer with dummies for (cnt=0;cntbuffer)[cnt] = descr->dummy; } // skip rows for (rowcnt=0;rowcntskiprow;) { C1 = RA_ReadElement( descr->in, descr->delimiterset, descr->commentset, buffer1, (size_t) 0, &rowcnt ); if (!C1) return(nread); if (feof(descr->in)) break; } // read items and copy to output buffer colcnt=0;rowcnt=0; for (cnt=0;cntin, descr->delimiterset, descr->commentset, buffer1, RA_MAXELEMENTWIDTH, &rowcnt ); if (!C1) return(nread); if (feof(descr->in)) break; // Do not use the the skipped columns if (colcnt>=descr->skipcol) { if (descr->verbose>3) printf("C1=%s\n",C1); if (cntbuffer) { tmp=num_str2double ( C1, NULL, &errval); if (!errval) { (descr->buffer)[cnt] = tmp; } nread++; } } cnt++; } colcnt++; } descr->cnt=cnt; if (descr->verbose>1) { printf(" Number of lines = %ld\n",newlinecnt); printf(" Total number of items = %ld\n",cnt); printf(" Minimum/Maximum number of items per line = %ld/%ld\n", minipl,maxipl); printf(" Dim_1=%ld, Dim_2=%ld\n",descr->dim1,descr->dim2); if (descr->verbose>2) RA_printdescr( stdout, descr ); } if (pstatus) *pstatus = 0; if (descr->verbose>1) printf("RA_readfile END\n"); return(nread); } // RA_readfile PUBLIC int RA_setbskp( RADescr * descr, long bskp ) { if (bskp>=0) descr->bskp = bskp; return(0); } // RA_setbskp PUBLIC int RA_setlskp( RADescr * descr, long lskp ) { if (lskp>=0) descr->lskp = lskp; return(0); } // RA_setlskp PUBLIC int RA_setcskp( RADescr * descr, long cskp ) { if (cskp>=0) descr->cskp = cskp; return(0); } // RA_setcskp PUBLIC int RA_setskiprow( RADescr * descr, long skiprow ) { if (skiprow>=0) descr->skiprow = skiprow; return(0); } // RA_setskiprow PUBLIC int RA_setskipcol( RADescr * descr, long skipcol ) { if (skipcol>=0) descr->skipcol = skipcol; return(0); } // RA_setskipcol PUBLIC int RA_setdim1( RADescr * descr, long dim1 ) { if (dim1>=0) descr->dim1 = dim1; return(0); } // RA_setdim1 PUBLIC int RA_setdim2( RADescr * descr, long dim2 ) { if (dim2>=0) descr->dim2 = dim2; return(0); } // RA_setdim2 PUBLIC int RA_setori( RADescr * descr, long ori ) { if (ori>=1) descr->ori = ori; return(0); } // RA_setori PUBLIC int RA_setdummy( RADescr * descr, float dummy ) { if (dummy!=0.0) descr->dummy = dummy; return(0); } // RA_setdummy PUBLIC int RA_setdelimiterset( RADescr * descr, const char *delimiterset ) { if (delimiterset) { if (descr->delimiterset) free(descr->delimiterset); descr->delimiterset = RA_newstr(delimiterset); if (!(descr->delimiterset)) return(1); } return(0); } // RA_setdelimiterset PUBLIC int RA_setcommentset( RADescr * descr, const char *commentset ) { if (commentset) { if (descr->commentset) free(descr->commentset); descr->commentset = RA_newstr(commentset); if (!(descr->commentset)) return(1); } return(0); } // RA_setcommentset /****************************************************************************/ spd-1.3.0/edfpack/rot3d.c0000644000175000017500000003064511633462462012035 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define ROT3D_VERSION "rot3d : V1.01 Peter Boesecke 2011-06-16" /*--------------------------------------------------------------------------- NAME rot3d - Conversion between rot1, rot2, rot3 and 3d rotation matrix. SYNOPSIS DESCRIPTION Consecutive rotations, first around lab axis 1, second around lab axis 2 and third around lab axis 3. The axes 1, 2 and 3 define a right-handed orthogonal system in the laboratory space: around lab axis 1: | 1.0 0.0 0.0 | R1(rot1) = | 0.0 cos(rot1) -sin(rot1) | | 0.0 sin(rot1) cos(rot1) | around lab axis 2: | cos(rot2) 0.0 sin(rot2) | R2(rot2) = | 0.0 1.0 0.0 | | -sin(rot2) 0.0 cos(rot2) | around lab axis 3: | cos(rot3) -sin(rot3) 0.0 | R3(rot3) = | sin(rot3) cos(rot3) 0.0 | | 0.0 0.0 1.0 | all rotations: R(rot1,rot2,rot3) = R3(rot3).R2(rot2).R1(rot1) r11 = R[0][0] = cos(rot2) cos(rot3) r12 = R[1][0] = sin(rot1) sin(rot2) cos(rot3) - cos(rot1) sin(rot3) r13 = R[2][0] = cos(rot1) sin(rot2) cos(rot3) + sin(rot1) sin(rot3) r21 = R[0][1] = cos(rot2) sin(rot3) r22 = R[1][1] = cos(rot1) cos(rot3) + sin(rot1) sin(rot2) sin(rot3) r23 = R[2][1] = cos(rot1) sin(rot2) sin(rot3) - sin(rot1) cos(rot3) r31 = R[0][2] = -sin(rot2) r32 = R[1][2] = sin(rot1) cos(rot2) r33 = R[2][2] = cos(rot1) cos(rot2) | R[0][0] R[1][0] R[2][0] | R(rot1,rot2,rot3) = | R[0][1] R[1][1] R[2][1] | | R[0][2] R[1][2] R[2][2] | | r11 r12 r13 | = | r21 r22 r23 | | r31 r32 r33 | | c2 c3 s1 s2 c3 - c1 s3 c1 s2 c3 + s1 s3 | = | c2 s3 c1 c3 + s1 s2 s3 c1 s2 s3 - s1 c3 | | -s2 s1 c2 c1 c2 | (c1=cos(rot1), s1=sin(rot1), c2=cos(rot2) etc.) principal ranges of the angles rot1, rot2, rot3: rot1 ] -Pi .. +Pi ] rot2 [ -Pi/2 .. +Pi/2 ] rot3 ] -Pi .. +Pi ] History 2010-04-26 Peter Boesecke creation V0.0 2010-05-17 PB V1.0 2011-04-18 PB V1.0 rot3d_version() added 2011-05-17 PB V1.01 Suggested parentheses added ---------------------------------------------------------------------------*/ /*************************************************************************** * Include * ***************************************************************************/ # include "rot3d.h" /*************************************************************************** * Internal * ***************************************************************************/ /**************************************************************************** * Static Variables and Numbers * ****************************************************************************/ static double rot3d_eps=1e-8; static double rot3d_pi=3.1415926535897932384626; /**************************************************************************** * Routines * ****************************************************************************/ /*-------------------------------------------------------------------------- NAME rot3d_version --- returns pointer to the version string SYNOPSIS const char *rot3d_version ( void ); DESCRPTION Returns pointer to the version string. --------------------------------------------------------------------------*/ const char *rot3d_version ( void ) { return ( ROT3D_VERSION ); } /* rot3d_version */ /*--------------------------------------------------------------------------- NAME rot3d_determinante SYNOPSIS double rot3d_determinante ( double A[3][3] ) DESCRIPTION input: double A[3][3] (3d matrix) RETURN VALUE determinante of A ---------------------------------------------------------------------------*/ double rot3d_determinante ( double A[3][3] ) { double determinante=0.0; if (!A) { fprintf( stderr, "ERROR: rot3d_determinante: NULL pointer\n" ); goto rot3d_determinante_error; } determinante = A[0][0]*(A[1][1]*A[2][2]-A[2][1]*A[1][2]); determinante -= A[0][1]*(A[1][0]*A[2][2]-A[1][2]*A[2][0]); determinante += A[0][2]*(A[1][0]*A[2][1]-A[1][1]*A[2][0]); rot3d_determinante_error: return( determinante ); } // rot3d_determinante /*--------------------------------------------------------------------------- NAME rot3d_mat_scale SYNOPSIS int rot3d_mat_scale ( double A[3][3], double scale ) DESCRIPTION Multiplies each element of A with scale. input: double A[3][3] (3d matrix) double scale (scale factor) updated: A RETURN VALUE status ---------------------------------------------------------------------------*/ int rot3d_mat_scale ( double A[3][3], double scale ) { int status=-1; int i,j; if (!A) { fprintf( stderr, "ERROR: rot3d_mat_scale: NULL pointer\n" ); goto rot3d_mat_scale_error; } if (scale!=1.0) for (i=0;i<3;i++) for (j=0;j<3;j++) A[i][j] *= scale; status = 0; rot3d_mat_scale_error: return( status ); } // rot3d_mat_scale /*+++------------------------------------------------------------------------ NAME rot3d_mat_transpose --- transpose a 3-dimensional matrix SYNOPSIS int rot3d_mat_transpose ( double A[3][3] ) DESCRIPTION A[3][3] = Transpose(A[3][3]) RETURN VALUE status ----------------------------------------------------------------------------*/ int rot3d_mat_transpose ( double A[3][3] ) { int j,k; double tmp; for (j=0;j<3;j++) for (k=0;krot3d_eps ) is_not_rot=1; else { is_not_rot=0; for (i=0;i<3;i++) { len=0.0; for (j=0;j<3;j++) len+=R[i][j]*R[i][j]; if (fabs(len-1.0)>rot3d_eps) { is_not_rot=1; break; } } } rot3d_isnotrot_error: return( is_not_rot ); } // rot3d_isnotrot /*--------------------------------------------------------------------------- NAME rot3d_matrix SYNOPSIS int rot3d_matrix(double ROT[3], double R[3][3]); DESCRIPTION input: double ROT[3] (angles rot1, rot2, rot3) updated: double R[3][3] (3d rotation matrix) RETURN VALUE status ---------------------------------------------------------------------------*/ int rot3d_matrix(double ROT[3], double R[3][3]) { int status=-1; double c1, c2, c3; double s1, s2, s3; if ((!ROT)||(!R)) { fprintf( stderr, "ERROR: rot3d_matrix: NULL pointer\n" ); goto rot3d_matrix_error; } c1 = cos(ROT[0]); c2 = cos(ROT[1]); c3 = cos(ROT[2]); s1 = sin(ROT[0]); s2 = sin(ROT[1]); s3 = sin(ROT[2]); R[0][0] = c2 * c3; R[1][0] = s1 * s2 * c3 - c1 * s3; R[2][0] = c1 * s2 * c3 + s1 * s3; R[0][1] = c2 * s3; R[1][1] = c1 * c3 + s1 * s2 * s3; R[2][1] = c1 * s2 * s3 - s1 * c3; R[0][2] = -s2; R[1][2] = s1 * c2; R[2][2] = c1 * c2; status = 0; rot3d_matrix_error: return( status ); } // rot3d_matrix /*--------------------------------------------------------------------------- NAME rot3d_inverse_matrix SYNOPSIS int rot3d_inverse_matrix(double ROT[3], double R[3][3]); DESCRIPTION input: double ROT[3] (angles rot1, rot2, rot3) updated: double R[3][3] (inverse 3d rotation matrix) RETURN VALUE status ---------------------------------------------------------------------------*/ int rot3d_inverse_matrix(double ROT[3], double R[3][3]) { int status=-1; if ( (status=rot3d_matrix(ROT, R)) ) goto rot3d_inverse_matrix_error; if ( (status=rot3d_mat_transpose (R)) ) goto rot3d_inverse_matrix_error; return( status ); rot3d_inverse_matrix_error: return( status ); } // rot3d_inverse_matrix /*--------------------------------------------------------------------------- NAME rot3d_angles SYNOPSIS int rot3d_angles(double ROT[3], double R[3][3]); DESCRIPTION Calculate rot1, rot2 and rot3 for an arbitrary 3d rotation matrix. updated: double ROT[3] (angles rot1, rot2, rot3) input: double R[3][3] (3d rotation matrix) principal ranges of the angles rot1, rot2, rot3: rot1 ] -Pi .. +Pi ] rot2 [ -Pi/2 .. +Pi/2 ] => c2 >= 0.0 rot3 ] -Pi .. +Pi ] RETURN VALUE status ---------------------------------------------------------------------------*/ int rot3d_angles(double ROT[3], double R[3][3]) { int status=-1; double rot1=0.0, rot2=0.0, rot3=0.0; // set defaults double c1, c2; double s1; double determinante=0.0, scale=1.0; if ((!ROT)||(!R)) { fprintf( stderr, "ERROR: rot3d_angles: NULL pointer\n" ); goto rot3d_angle_error; } determinante = rot3d_determinante( R ); if ( determinante < rot3d_eps ) { fprintf( stderr, "ERROR: rot3d_angles: Det(R) = %lg is not positive\n", determinante ); goto rot3d_angle_error; } scale = pow( determinante, 1.0/3.0 ); ROT[0] = rot1; ROT[1] = rot2; ROT[2] = rot3; if ( (status=rot3d_mat_scale ( R, scale )) ) { goto rot3d_angle_error; } if ( rot3d_isnotrot ( R ) ) { fprintf( stderr, "ERROR: rot3d_angles: R is not a rotation matrix\n"); goto rot3d_angle_error; } // rot1 if ( (1.0-fabs(R[0][2])) > rot3d_eps ) { // c2 > 0 rot1 = atan2( R[1][2], R[2][2]); } else { // c2 == 0 if ( R[0][2] < 0) { // sin(rot2)==+1.0 rot1 = atan2( R[1][0],R[2][0])+rot3; } else { // sin(rot2)==-1.0 rot1 = atan2( -R[1][0],-R[2][0])-rot3; } } c1 = cos(rot1); s1 = sin(rot1); if (fabs(rot1+rot3d_pi)rot3d_pi) rot1-=rot3d_pi*2.0; if (rot1<=-rot3d_pi) rot1+=rot3d_pi*2.0; // rot2 if ( fabs(s1) > rot3d_eps ) { // s1 != 0.0 rot2 = atan2(-R[0][2],R[1][2]/s1); } else { // c2 != 0.0 rot2 = atan2(-R[0][2],R[2][2]/c1); } c2 = cos(rot2); if (fabs(rot2+rot3d_pi)rot3d_pi) rot2-=rot3d_pi*2.0; if (rot2<=-rot3d_pi) rot2+=rot3d_pi*2.0; // rot3 if ( fabs(c2) > rot3d_eps ) { rot3 = atan2(R[0][1]/c2,R[0][0]/c2); } else { // default of rot3 rot3 = atan2(-(R[1][1]*s1+R[2][1]*c1)/R[0][2], -(R[1][0]*s1+R[2][0]*c1)/R[0][2]); } if (fabs(rot3+rot3d_pi)rot3d_pi) rot3-=rot3d_pi*2.0; if (rot3<=-rot3d_pi) rot3+=rot3d_pi*2.0; ROT[0] = rot1; ROT[1] = rot2; ROT[2] = rot3; status = 0; rot3d_angle_error: return( status ); } // rot3d_angles spd-1.3.0/edfpack/angle.c0000644000175000017500000003762011633462461012067 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++------------------------------------------------------------------------ NAME angle --- routines for angular averaging SYNOPSIS # include angle.h HISTORY 2005-10-08 V1.0 Peter Boesecke 2005-10-29 V1.1 PB *pstatus = Success; added 2006-05-13 V1.2 PB angle_limits and checks for Min/MaxAngle and Min/MaxRadius added 2007-04-19 V1.3 PB -Wall compiler warnings resolved 2009-10-02 V1.4 PB Success -> 0, SaxsAngle -> angle include only ipol.h and reference.h DESCRIPTION * Attention: * - all values of the output array must have been preset with the value * "I0Dummy" ----------------------------------------------------------------------------*/ /****************************************************************************** * Include Files * ******************************************************************************/ # include "angle.h" /****************************************************************************** * Private Constants * ******************************************************************************/ static const double rad2deg = 180.0/NUM_PI; static const float twopi = 2.0*NUM_PI; /****************************************************************************** * Private Definitions * ******************************************************************************/ # define CALC_DIST(A) sqrt((A[0])*(A[0])+(A[1])*(A[1])) /****************************************************************************** * Routines * ******************************************************************************/ /*+++------------------------------------------------------------------------ NAME angle_limits SYNOPSIS float angle_limits( int mode, int I1Dim_1, int I1Dim_2, float Off_11, float Ps_11, float Off_21, float Ps_21, float Wcenter_1, float Wcenter_2 ) DESCRIPTION Returns the maximum or minimum distances and the maximum or minimum azimuthal angles of the edges in world coordinates from the center, depending on mode. The center is (Wcenter_1,Wcenter_2) in the world system. The returned distances are absolute values in world distances, the angles are returned in radian. mode 1: minimum radius mode 2: maximum radius mode -1: minimum angle mode -2: maximum angle | | | | G | H | I | | _________|_________|_________ edge4| |edge3 | | D | E | F | | _________|_________|_________ edge1| |edge2 | | A | B | C | | | | RETURN VALUE value depending on mode, -999.0 is error -------------------------------------------------------------------------+*/ float angle_limits( int mode, int I1Dim_1, int I1Dim_2, float Off_11, float Ps_11, float Off_21, float Ps_21, float Wcenter_1, float Wcenter_2 ) { float i10, i11, i20, i21; float edge1[2], edge2[2], edge3[2], edge4[2]; float dist1, dist2, dist3, dist4; float min_radius, max_radius, min_angle, max_angle; float value; i10 = i20 = A2INDEX(ARRAYSTART+LOWERBORDER); i11 = A2INDEX(ARRAYSTART+LOWERBORDER+I1Dim_1); i21 = A2INDEX(ARRAYSTART+LOWERBORDER+I1Dim_2); edge1[0] = WORLD(i10,Off_11,Ps_11)-Wcenter_1; edge1[1] = WORLD(i20,Off_21,Ps_21)-Wcenter_2; edge2[0] = WORLD(i11,Off_11,Ps_11)-Wcenter_1; edge2[1] = edge1[1]; edge3[0] = edge2[0]; edge3[1] = WORLD(i21,Off_21,Ps_21)-Wcenter_2; edge4[0] = edge1[0]; edge4[1] = edge3[1]; dist1 = CALC_DIST(edge1); dist2 = CALC_DIST(edge2); dist3 = CALC_DIST(edge3); dist4 = CALC_DIST(edge4); if ( 0.0 < edge1[0] ) { // A, D, G if ( 0.0 < edge1[1] ) { // A min_radius = dist1; max_radius = dist3; min_angle = atan2(edge2[1],edge2[0]); max_angle = atan2(edge4[1],edge4[0]); } else { if ( 0.0 < edge4[1] ) { // D min_radius = edge1[0]; max_radius = MAX2(dist2,dist3); min_angle = atan2(edge1[1],edge1[0]); max_angle = atan2(edge4[1],edge4[0]); } else { // G min_radius = dist4; max_radius = dist2; min_angle = atan2(edge1[1],edge1[0]); max_angle = atan2(edge3[1],edge3[0]); } } } else { if ( 0.0 < edge2[0] ) { // B, E, H if ( 0.0 < edge2[1] ) { // B min_radius = edge1[1]; max_radius = MAX2(dist4,dist3); min_angle = atan2(edge2[1],edge2[0]); max_angle = atan2(edge1[1],edge1[0]); } else { if ( 0.0 < edge3[1] ) { // E min_radius = 0.0; max_radius = MAX4(dist1, dist2, dist3, dist4); min_angle = 0.0; max_angle = twopi; } else { // H min_radius = -edge3[1]; max_radius = MAX2(dist1,dist2); min_angle = atan2(edge4[1],edge4[0]); max_angle = atan2(edge3[1],edge3[0]); } } } else { // C, F, I if ( 0.0 < edge2[1] ) { // C min_radius = dist2; max_radius = dist4; min_angle = atan2(edge3[1],edge3[0]); max_angle = atan2(edge1[1],edge1[0]); } else { if ( 0.0 < edge3[1] ) { // F min_radius = -edge2[0]; max_radius = MAX2(dist1,dist4); min_angle = atan2(edge3[1],edge3[0]); max_angle = atan2(edge2[1],edge2[0]); } else { // I min_radius = dist3; max_radius = dist1; min_angle = atan2(edge4[1],edge4[0]); max_angle = atan2(edge2[1],edge2[0]); } } } } // output range of min_angle [0..2*pi] if (min_angle< 0.0) min_angle += twopi; if (max_angle<=0.0) max_angle += twopi; switch (mode ) { case 1: // minimum radius value = min_radius; break; case 2: // maximum radius value = max_radius; break; case -1: // minimum angle value = min_angle; break; case -2: // maximum angle value = max_angle; break; default : // error value = -999.0; } return ( value ); } // angle_limits /*+++------------------------------------------------------------------------ NAME angle_sum --- azimuthal summation/averaging of an image SYNOPSIS void angle_sum ( float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float Off_10, float Ps_10, float Off_20, float Ps_20, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float Off_11, float Ps_11, float Off_21, float Ps_21, float I1Dummy, float I1DDummy, float Wcenter_1, float Wcenter_2, int vsum, int ave, int testbit, int * pstatus ); DESCRIPTION Azimuthal summation/averaging of an image. Before using this function the output array must have been preset with I0Dummy. NO RETURN VALUE -------------------------------------------------------------------------+*/ void angle_sum ( float * I0Data, float * E0Data, int I0Dim_1, int I0Dim_2, float Off_10, float Ps_10, float Off_20, float Ps_20, float I0Dummy, float I0DDummy, float * I1Data, float * E1Data, int I1Dim_1, int I1Dim_2, float Off_11, float Ps_11, float Off_21, float Ps_21, float I1Dummy, float I1DDummy, float Wcenter_1, float Wcenter_2, int vsum, int ave, int testbit, int * pstatus ) { float *pI0Data, *pE0Data; float I1Value, I1Sum, I1Weight, I1CircleSum, I1CircleSumWeight; float E1Value, E1Sum, E1Weight, E1CircleSum, E1CircleSumWeight; int i_1, i_2; float W_1, W_2; float f_11, f_21; float DDAngle, DAngle, Angle, Radius; int NAngle, iangle; float MinRadius, MaxRadius, MinAngle, MaxAngle; float NormAngle; float VarDDummy=DDSET(VarDummy); float factor; int cnt, varcnt; if (pstatus) *pstatus = 0; /* loop over I0Data */ /* * Detailed descriptoin by R. Wilcke * Calculate the number of input image pixels that will have to be averaged * over for one output image pixel. * * Ps_11 and Ps_21 are the input image pixel sizes in x and y direction; * Ps_10 is the output image pixel size in radial direction, it is set to * be the smaller one of the input image sizes in x and y direction; * Ps_20 is the output image pixel size in angular direction, this is an * input parameter of the routine. * * The size of an "unit" pixel is therefore Ps_11 * Ps_21 (= dx * dy) in * the input image and Ps_10 * Ps_20 (= dr * da) in the output image. * * However, dx * dy is the same area over the whole image, whereas dr * da is * smaller for small values of r and bigger for big values of r. * * The area corresponding to dr * da at a given value of r is F = r * dr * * da. * Therefore, the number of input image pixels that will fit into an "unit" * output pixel is * N = F / (dx * dy), or because of the definition of dr * N = r * da / MAX(dx,dy) * * This is therefore the number of input image pixels that will have to be * averaged over for one output pixel. The actual value used (variable NAngle * further below) is an overestimate of this, to make sure that all possible * input pixels are actually taken into account. * * DDAngle is an intermediate variable, it corresponds to the number of input * image pixels at r = 1. It will be used to calculate NAngle later. */ DDAngle = Ps_20/(MIN2(Ps_11,Ps_21)); if (testbit) printf("DDAngle = % g_deg\n", DDAngle * rad2deg); /* * Calculate the minimum and maximum radius and angle * values for the input image. */ MinRadius = angle_limits( 1, I1Dim_1, I1Dim_2, Off_11, Ps_11, Off_21, Ps_21, Wcenter_1, Wcenter_2 ); MaxRadius = angle_limits( 2, I1Dim_1, I1Dim_2, Off_11, Ps_11, Off_21, Ps_21, Wcenter_1, Wcenter_2 ); MinAngle = angle_limits( -1, I1Dim_1, I1Dim_2, Off_11, Ps_11, Off_21, Ps_21, Wcenter_1, Wcenter_2 ); MaxAngle = angle_limits( -2, I1Dim_1, I1Dim_2, Off_11, Ps_11, Off_21, Ps_21, Wcenter_1, Wcenter_2 ); if (testbit) printf("MinRadius=%g, MaxRadius=%g, MinAngle=%g_deg, MaxAngle=%g_deg\n", MinRadius, MaxRadius, MinAngle*rad2deg, MaxAngle*rad2deg ); /* * Loop over the output array. * * The outer loop goes over the radius, the inner one over the angle. * Radial values outside the requested range are skipped. * * Attention: * - all values of the output array must have been preset with the value * "I0Dummy" */ for (i_1=0;i_1 MaxRadius || Radius < MinRadius ) continue; /* number of angular intervals for averaging */ NAngle = MAX2(1,(int) (DDAngle * Radius) + 1 ); DAngle = Ps_20/(float) NAngle; if (testbit>1) printf("%d: Radius=%g, NAngle=%d, DAngle=%g_deg\n", i_1,Radius,NAngle,DAngle*rad2deg); for (i_2=0;i_2 MaxAngle || Angle < MinAngle ) { /* MinAngle and MaxAngle are normalized angles between [0..2*pi], check also the normalized angle */ NormAngle = Angle-floor(Angle/twopi)*twopi; if ( MinAngle <= MaxAngle ) { // check, whether the angle is outside [MinAngle..MaxAngle] if ( NormAngle > MaxAngle || NormAngle < MinAngle ) continue; } else { // check, whether the angle is inside [MaxAngle..MinAngle] if ( NormAngle < MaxAngle && NormAngle > MinAngle ) continue; } } /* angular averaging */ cnt = 0; varcnt = 0; I1CircleSum = 0.0; I1CircleSumWeight = 0.0; E1CircleSum = 0.0; E1CircleSumWeight = 0.0; for (iangle = 0; iangle= 0.0 ) { E1CircleSum += E1Sum; E1CircleSumWeight += E1Weight; varcnt++; } cnt++; } /* if Isum2ldwE ... */ } else { if (Ipol2ldw (I1Data,I1Dim_1,I1Dim_2,I1Dummy,I1DDummy, f_11, f_21, &I1Sum, &I1Weight)) { /* then do something with the data */ I1CircleSum += I1Sum; I1CircleSumWeight += I1Weight; cnt++; } /* if Ipol2ld ... */ } Angle += DAngle; } /* for */ if (cnt>0) { pI0Data = ABSPTR(I0Data,I0Dim_1,I0Dim_2,i_1,i_2); pE0Data = E0Data-I0Data+pI0Data; /* The following factor adjusts the size of a rectangular pixel with the size Ps_11*Ps_21 to a circular pixel with height Ps_10 and width Radius*DAngle */ factor = (Radius*DAngle*Ps_10)/(Ps_11*Ps_21); I1CircleSum *= factor; I1CircleSumWeight *= factor; E1CircleSum *= factor; E1CircleSumWeight *= factor; I1Value = I1CircleSum; if (ave) I1Value /= I1CircleSumWeight; if ( E0Data && ( varcnt==cnt ) ) { E1Value = E1CircleSum; if (ave) E1Value /= E1CircleSumWeight*E1CircleSumWeight; /* Take into account that the data was averaged in a sector */ } else E1Value = -1.0; if (vsum) { /* Multiply with number of covered pixels */ factor = I1CircleSumWeight; I1Value *= I1CircleSumWeight; if ( E1Value>=0 ) E1Value *= I1CircleSumWeight*I1CircleSumWeight; } UPDATE( *pI0Data, I1Value, I0Dummy, I0DDummy ); if ( E0Data && ( E1Value>=0.0 ) ) { UPDATE( *pE0Data, E1Value, VarDummy, VarDDummy ); } } /* end angular averaging */ } /* for i_2 ... */ } /* for i_1 ... */ } /* angle_sum */ spd-1.3.0/edfpack/poisson.h0000644000175000017500000000530211633462461012470 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME poisson.h SYNOPSIS #include "poisson.h" DESCRIPTION Header of the module "poisson.c" ***********************************************************************---*/ #ifndef _POISSON_ # define _POISSON_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif # include # include # include # include # include # include # include # include # include # include /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern double Poisson( long k, double ny ), // poisson distribution SumPoisson( long k, double ny ), // Sum(0,k,Poisson(k,ny)) RandomNoise( void ); // random noise between 0.0 and 1.0 PUBLIC extern long InvSumPoisson ( double y, double ny ), // inverted SumPoisson PoissonNoise( double ny ); // poissonian noise with mean ny PUBLIC extern void PoissonNoiseSeed( unsigned int seed ); // set random number seed #endif spd-1.3.0/edfpack/edfio.h0000644000175000017500000005102211633462462012065 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME edfio.h SYNOPSIS #include "edfio.h" DESCRIPTION Header of the module "edfio.c" HISTORY 17-Mar-1998 Peter Boesecke 16-May-1998 PB INTERNAL_BYTE_ORDER, data_sizeof 01-Jun-1998 PB set_bsl_input_byteorder 18-Apr-1999 PB all public routines start with edf_ or edfio_ 30-Apr-1999 PB new routine edf_read_data_2d_raw 23-Jun-1999 PB Restrictions (PUBLIC) 24-Jun-1999 PB module HISTORY added, restriction again only private 26-Jun-1999 PB History_Line changed to Header_Symbol_List (HSymb) 23-Jul-1999 PB call to edf_read_data_2d_raw and edf_write_data_2d_raw changed (DataValueOffset) 08-Nov-1999 PB edf_raster_normalization added 08-Nov-1999 PB in HSymb: shortlen and required added, new functions: edf_history_skip(), edf_history_take() INTERNAL_BYTE_ORDER redefined according to bytesex.h 18-Nov-1999 PB default of INTERNAL_BYTE_ORDER: HighByteFirst 25-Nov-1999 PB dec alpha (__alpha) 16-Mar-2000 PB comments revised 18-Mar-2000 PB DBClass and DBInstance 07-Apr-2000 PB V1.19 set_max_line_width 30-Apr-2000 PB V1.20 MType 01-Mai-2000 PB V1.21 30-Jul-2000 PB V1.24 edf_raster_multiplication, edf_raster_inversion 10-Nov-2000 PB V1.30 edf_write_data_2d_raw -> edf_write_data_raw edf_write_data_2d_float -> edf_write_data_float 11-Nov-2000 PB V1.31 12-Nov-2000 PB V1.32 edf_write_data_float -> edf_write_data(...,MFloat,...) V1.33 long * pDataArraySize -> size_t * pDataArraySize V1.34 edf_read_data_...(... , long Dim[], ...) ---> edf_read_data_...(... , long **pDim, ...) edf_read_data_2d_... -> edf_read_data_... edf_read_data_float --> edf_read_data(...,MFloat,...) 30-Dec-2000 PB V1.36 01-Jan-2001 PB V1.37 19-May-2001 PB V1.47 edf_dump 01-Jun-2001 PB V1.49 edf_dump, new parameter list 07-Jun-2001 PB V1.50 internal parameter functions, the parameter list of edf_dump is not finished, do not use generally 06-Jul-2001 PB V1.53 edf_search_stream 08-Jul-2001 PB V1.55 EdfMaxKeyLen etc., edf_byteorder 02-Sep-2001 PB V1.59 edf_set_datatype 13-Sep-2001 PB V1.62 history routines with history_key 25-Nov-2001 PB V1.70 keyorder routines 08-Dec-2001 PB V1.75 edf_add/delete_header_element 08-Jan-2002 PB V1.76 edf_search_header_element 09-Jan-2002 PB V1.77 argument list of edf_print_header 12-Feb-2002 PB V1.79 edf_datatype2machinetype, edf_machine_sizeof 25-Apr-2002 PB V1.80 edf_history_read_header, edf_history_write_header, edf_history_copy , edf_history_print 24-Mar-2004 PB V1.88 new parameter: EdfNDigitsFloat 12-Apr-2004 PB V1.93 edf_headersize 17-Jul-2004 PB V1.95 edf_set_minimumheadersize 24-Feb-2005 PB V2.01 INTERNAL_BYTE_ORDER replaced by edf_byteorder() 27-Feb-2005 PB V2.02 edf_write_header_string, edf_read_header_string 19-Dec-2010 PB V2.32 DCompression is now defined in cmpr.h ***************************************************************************/ #ifndef EDFIO /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static /* used to declare variables of private type */ # define PUBLIC /* used to declare variables of public type */ #endif #ifndef True # define True 1 # define False 0 #endif # include # include # include # include "cmpr.h" /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern void edf_write_data_raw ( int stream, long DataNumber, int DataChain, const long Dim[], void *pData, int DataType, long DataValueOffset, int ByteOrder, long RasterConfiguration, int * pErrorValue, int *pstatus ), edf_write_data ( int stream, long DataNumber, int DataChain, const long Dim[], void *pData, int MachineType, int * pErrorValue, int *pstatus ), edf_read_data_raw ( int stream, long DataNumber, int DataChain, long **pDim, size_t * pDataArraySize, void **ppData, int * pDataType, long * pDataValueOffset, int * pByteOrder, long * pRasterConfiguration, int * pErrorValue, int * pstatus ), edf_read_data ( int stream, long DataNumber, int DataChain, long **pDim, size_t * pDataArraySize, void **ppData, int MachineType, int * pErrorValue, int * pstatus ), edf_close_data_file ( int stream, int *pErrorValue, int *pstatus ); PUBLIC extern int edf_open_data_file ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ), edf_search_stream ( const char *fname, const char * mode, int *pErrorValue, int *pstatus ), edf_read_data_dimension ( int stream, long DataNumber, int DataChain, long **pDim, size_t * pDataArraySize, int * pErrorValue, int * pstatus ), edf_search_minmax_number ( int stream, int DataChain, long *pMinNumber, long * pMaxNumber, int *pErrorValue, int *pstatus), edf_read_header_long ( int stream, long DataNumber, int DataChain, const char * keyword, long * Value, int * pErrorValue, int * pstatus), edf_read_header_float ( int stream, long DataNumber, int DataChain, const char * keyword, float * Value, int * pErrorValue, int * pstatus ), edf_read_header_line ( int stream, long DataNumber, int DataChain, const char * keyword, char * Value, int * pErrorValue, int * pstatus ), edf_read_header_string ( int stream, long int DataNumber, int DataChain, const char * keyword, const char ** pString, int * pErrorValue, int * pstatus ), edf_write_header_long ( int stream, long DataNumber, int DataChain, const char * keyword, long Value, int * pErrorValue, int * pstatus ), edf_write_header_float ( int stream, long DataNumber, int DataChain, const char * keyword, float Value, int * pErrorValue, int * pstatus ), edf_write_header_line ( int stream, long DataNumber, int DataChain, const char * keyword, const char * Value, int * pErrorValue, int * pstatus ), edf_write_header_string ( int stream, long DataNumber, int DataChain, const char * keyword, const char * Value, int * pErrorValue, int * pstatus ), edf_delete_key ( int stream, long int DataNumber, int DataChain, const char * keyword, int * pErrorValue, int * pstatus ), edf_write_header_unit ( int stream, long DataNumber, int DataChain, const char * keyword, float Value, const char * unit, int * pErrorValue, int * pstatus ), edf_test_header ( int stream, long DataNumber, int DataChain, int *pErrorValue, int *pstatus ), edf_general_block ( int writetodisk ), edf_headersize ( int writetodisk ), edf_set_minimumheadersize ( unsigned long minimumheadersize_out ), edf_set_datatype ( int datatype_out ), edf_set_datavalueoffset ( long int datavalueoffset_out ), edf_set_datacompression ( int datacompression_out ), edf_set_bsl_input_byteorder ( int byteorder ), edf_set_max_line_width ( unsigned long width ), edf_free_data_file ( void ), edf_free_all ( void ); PUBLIC extern char *edf_report_data_error ( int ErrorValue ), *edf_dataformat_version ( void ); /*************************************************************************** * Data conversion routines * ***************************************************************************/ PUBLIC extern size_t edf_data_sizeof ( int data_type ), edf_machine_sizeof ( int mtype ); PUBLIC extern unsigned long edf_dim_product ( const long * dim ); PUBLIC extern int edf_datatype2machinetype ( int dtype ), edf_machinetype2datatype ( int mtype ), edf_string2datatype ( const char * string ), edf_string2compression ( const char * string ), edf_raster_normalization ( void * dest, const void * src, const long data_dim[], long raster_configuration, size_t item ), edf_machine2machine ( void * dest, int mtype_dest, const void * src, long value_offset, int mtype_src, unsigned long n ); PUBLIC extern long edf_raster_multiplication ( long a, long x ), edf_raster_inversion ( long x ), edf_raster_order2number ( const long order[] ); PUBLIC extern const char * edf_datatype2string ( int data_type ), * edf_compression2string ( int data_compression ); PUBLIC extern void edf_bswap ( void * dest, const void * src, size_t item, unsigned long n ), edf_showdatatypes ( int full ), edf_showmachinetypes ( int full ); /*************************************************************************** * Debug routines * ***************************************************************************/ PUBLIC extern void edfio_debug ( int debug ); PUBLIC extern int edf_print_filetable ( FILE * out, int level, int verbose ), edf_dump ( FILE * out, int stream, int format, char * chainkey[], char * blockkey[], char * keyword[] ); PUBLIC extern char *edfio_version ( void ); /*************************************************************************** * History routines * ***************************************************************************/ PUBLIC extern int edf_history_new ( const char * history_key ), edf_history_skip ( const char * history_key ), edf_history_take ( const char * history_key ), edf_history_argv ( const char * history_key, const char * substring ), edf_read_header_history ( int stream, long DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ), edf_write_header_history ( int stream, long DataNumber, int DataChain, const char * history_key, int * pErrorValue, int * pstatus ), edf_history_read_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus ), edf_history_write_header ( const char * header_key, const char * history_key, int * pErrorValue, int * pstatus ), edf_history_copy ( const char * history_key_copy, const char * history_key ), edf_history_free ( const char * history_key ), edf_history_print ( FILE * out, const char * history_key, int level, int verbose ); /*************************************************************************** * Key Order routines * ***************************************************************************/ PUBLIC extern void edf_keyorder_set_table ( const char * table[] ), edf_keyorder_print_table ( FILE * out ); /*************************************************************************** * Header routines * ***************************************************************************/ PUBLIC extern int edf_new_header ( const char * header_key ), edf_read_header ( int stream, long DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus ), edf_write_header ( int stream, long DataNumber, int DataChain, const char * header_key, int * pErrorValue, int * pstatus ), edf_first_header_element ( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ), edf_next_header_element ( const char * header_key, const char ** pkey, const char ** pvalue, int * pErrorValue, int * pstatus ), edf_search_header_element ( const char * header_key, const char * key, const char ** pvalue, int * pErrorValue, int * pstatus ), edf_add_header_element ( const char * header_key, const char * key, const char * value, int * pErrorValue, int * pstatus ), edf_delete_header_element ( const char * header_key, const char * key, int * pErrorValue, int * pstatus ), edf_free_header ( const char * header_key ), edf_print_header ( FILE * out, const char * header_key, int level, int verbose ); /*************************************************************************** * Internal Parameter Definitions * ***************************************************************************/ #define EdfMaxFiles 20 /* maximum number of file streams */ #define EdfMaxKeyLen 64 /* maximum length of keywords */ #define EdfMaxValLen 512 /* maximum length of values */ #define EdfMaxLinLen 255 /* maximum line length */ #define EdfMaxDataChains 20 /* max. number of user data chains */ #define EdfBufferSize 512 /* size of input buffer */ #define EdfMaxDimensions EdfBufferSize /* maximum number of dimensions */ #define EdfNDigitsFloat 7 /* number of significant float digits */ /*************************************************************************** * Internal Parameter Functions (return the above defined parameters) * ***************************************************************************/ PUBLIC extern unsigned long edf_maxfiles ( void ), edf_maxkeylen ( void ), edf_maxvallen ( void ), edf_maxlinlen ( void ), edf_maxdatachains ( void ), edf_buffersize ( void ), edf_maxdimensions ( void ); PUBLIC extern int edf_byteorder ( void ); /* return internal byteorder */ /*************************************************************************** * Symbolic Names of Error Values * ***************************************************************************/ # define status_error 100 # define status_success 0 /*************************************************************************** * Error Values * ***************************************************************************/ enum ErrorValues { RoutineFailed = -1, RoutineSucceeded, CouldNotMallocMemory, CouldNotFreeHeaders, CouldNotGetBinaryArray, NoMoreStreamsAvailable, InvalidStream, CouldNotOpenFile, EndOfFileDetected, CouldNotFindHeader, CouldNotFindSymbol, BadSizeDefinition, BadDataBlock, CouldNotFindKeyword, WriteDataError, ReadDataError, NoFileOpen, NotESRFDataFile, NoDataBlocksFound, ExternalData, FileIsNotWritable, FileIsNotOpened, IncompatibleOpeningModes, CouldNotCloseFile, CouldNotCloseBlock, CouldNotInsertChain, CouldNotInsertBlock, CouldNotInsertSymbol, MissingKeyDefinition, GeneralBlockNotFirst, ErrorCreatingGeneralBlock, ErrorReadingGeneralBlock, ErrorLocatingBlocks, CouldNotSetBuffer, NumberConversionFailed, DataConversionFailed, DataBufferTooSmall, MissingArrayDimensions, NotNdData, Not2dData, CouldNotWriteDimension, CouldNotReadDimension, CouldNotWriteBinary, CannotReOpenGeneralBlock, CannotOpenAsBslFile, CouldNotInsertElement, CouldNotDeleteString, CouldNotFindHeaderKey, CouldNotCreateHeader, CouldNotReadGeneralHeader, CouldNotReadHeader }; /* The following enums start with 1. 0 is used to specify an invalid value. The string tables start with "InValid" and end with (char *) NULL. */ /*************************************************************************** * Data Type Translation Tables * ***************************************************************************/ enum DType { InValidDType, Unsigned8=1, Signed8, Unsigned16, Signed16, Unsigned32, Signed32, Unsigned64, Signed64, FloatIEEE32, DoubleIEEE64, Unused11, Unused12, FloatVAX32, DoubleVAX64, FloatConvex32, DoubleConvex64, EndDType }; enum MType { InValidMType, MUnsignedChar=1, MChar, MUnsignedShort, MShort, MUnsignedInteger, MInteger, MUnsignedLong, MLong, MFloat, MDouble, EndMType }; /*************************************************************************** * Byte Order Translation Tables * ***************************************************************************/ enum BOrder { InValidBOrder, LowByteFirst=1, HighByteFirst, EndBOrder }; /*************************************************************************** * Data block classes and instances * ***************************************************************************/ enum DBClass { InValidDBClass, DBGeneral, DBImage, EndDBClass }; enum DBInstance { InValidDBInstance, DBPrimaryData, DBError, EndDBInstance }; #endif #ifndef EDFIO # define EDFIO #endif /************************************************************************---*/ spd-1.3.0/edfpack/project.c0000644000175000017500000002515111633462462012444 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME project.c --- Projection functions SYNOPSIS void project_1 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float Df_1, float f1_2, float f3_2, float dummy, float ddummy, int ave ) void project_2 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float f1_2, float f3_2, float Df_2, float dummy, float ddummy, int ave ); HISTORY 2009-10-06 V1.00 PB extracted from SaxsRoutine (Projection_1, Projection_2) without testbit 2009-11-10 V1.01 PB unused variables removed ***********************************************************************---*/ /**************************************************************************** * Include * ****************************************************************************/ # include "project.h" /*************************************************************************** * Functions * ***************************************************************************/ /*--------------------------------------------------------------------------- NAME project_1 --- Projection of image rows to a line (including variance) SYNOPSIS void project_1 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float Df_1, float f1_2, float f3_2, float dummy, float ddummy, int ave ) DESCRIPTION Averaging/Integration of rows between f1_2 and f3_2 in the 2d array data (float data[dim_1,dim_2]). The result is written to the 1d array line. The output array line is initialized with initvalue. Each element i between imin and imax of line is filled with the average/integral of the rectangle between the edges with the index coordinates (fi_1, f1_2) and (fi_1+Df_1, f3_2) in the input data array, where fi_1 starts with f1_1 for imin and is incremented by Df_1 for each element. f1_1, f3_1, f1_2 and f3_2 are index coordinates of the input data array. ARGUMENTS float *line : 1d output array float line[dim] float *varline : 1d output variance array float varline[dim] long dim : dimensions of output arrays (dim=dim_1!) long imin, imax : range of indices in output arrays float initvalue : all elements in line that could not be determined are set to initvalue (variance array values are set to VarDummy) float factor : multiplication factor for output values float *data : 2d input array float data[dim_1,dim_2] float *vardat : 2d input variance array float vardat[dim_1,dim_2] long dim_1, dim_2 : dimensions of the input array float f1_1, f3_1 : lowest and highest index 1 in the input array float Df_1 : increment of index coordinate 1 float f1_2, f3_2 : indices of integration limits float dummy, ddummy : dummy and ddummy of input array (negative values are dummy values of vardat) int ave : 0: integration, 1: average HISTORY 2005-09-17 Peter Boesecke ----------------------------------------------------------------------------*/ void project_1 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float Df_1, float f1_2, float f3_2, float dummy, float ddummy, int ave ) { const float eps = 1e-30; float sum, weight; float varsum, varweight; float f_1; long i, i0, i1; // loop int cnt; i0 = MAX2(0,imin); i1 = MIN2(dim-1,imax); /* initialize line with initvalue */ for (i=0;ieps) line[i] /= weight; else line[i] = initvalue; if (fabs(varweight)>eps) varline[i] /= varweight*varweight; else varline[i] = VarDummy; } } else { cnt = Isum2ldw ( data, dim_1, dim_2, dummy, ddummy, f_1, f1_2, f_1+Df_1, f3_2, &sum, &weight); line[i] = sum*factor; if (ave) { if (fabs(weight)>eps) line[i] /= weight; else line[i] = initvalue; } } f_1+=Df_1; } // for } /* project_1 */ /*--------------------------------------------------------------------------- NAME project_2 --- Projection of image columns to a line (including variance) SYNOPSIS void project_2 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float f1_2, float f3_2, float Df_2, float dummy, float ddummy, int ave ); DESCRIPTION Averaging/Integration of columns between f1_1 and f3_1 in the 2d array data (float data[dim_1,dim_2]). The result is written to the 1d array line. The output array line is initialized with initvalue. Each element i between imin and imax of line is filled with the average/integral of the rectangle between the edges with the index coordinates (f1_1, fi_2) and (f3_1, fi_2+Df_2) in the input data array, where fi_2 starts with f1_2 for imin and is incremented by Df_2 for each element. f1_1, f3_1, f1_2 and f3_2 are index coordinates of the input data array. ARGUMENTS float *line : 1d output array float line[dim] float *varline : 1d output variance array float varline[dim] long dim : dimension of output array (dim=dim_1!) long imin, imax : range of indices in output array float initvalue : all elements in line that could not be determined are set to initvalue, (variance array values are set to VarDummy) float factor : multiplication factor for output values float *data : 2d input array float data[dim_1,dim_2] float *vardat : 2d input variance array float vardat[dim_1,dim_2] long dim_1, dim_2 : dimensions of the input array float f1_1, f3_1 : lowest and highest index 1 in the input array float f1_2, f3_2 : indices of integration limits float Df_2 : increment of index coordinate 2 float dummy, ddummy : dummy and ddummy of input array (negative values are dummy values of vardat) int ave : 0: integration, 1: average HISTORY 2005-09-16 Peter Boesecke ----------------------------------------------------------------------------*/ void project_2 ( float *line, float *varline, int dim, int imin, int imax, float initvalue, float factor, float *data, float *vardat, int dim_1, int dim_2, float f1_1, float f3_1, float f1_2, float f3_2, float Df_2, float dummy, float ddummy, int ave ) { const float eps = 1e-30; float sum, weight; float varsum, varweight; float f_2; long i, i0, i1; // loop int cnt; i0 = MAX2(0,imin); i1 = MIN2(dim-1,imax); /* initialize line with initvalue */ for (i=0;ieps) line[i] /= weight; else line[i] = initvalue; if (fabs(varweight)>eps) varline[i] /= varweight*varweight; else varline[i] = VarDummy; } } else { cnt = Isum2ldw ( data, dim_1, dim_2, dummy, ddummy, f1_1, f_2, f3_1, f_2+Df_2, &sum, &weight); line[i] = sum*factor; if (ave) { if (fabs(weight)>eps) line[i] /= weight; else line[i] = initvalue; } } f_2+=Df_2; } // for } /* project_2 */ spd-1.3.0/edfpack/filename.h0000644000175000017500000001134111633462462012557 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME filename.h SYNOPSIS #include "filename.h" DESCRIPTION Header of the module "filename.c" This module restricts possible filenames. Directories must be separated in unix style with a slash. Backslashes are automatically converted to slashes. Filenames cannot not contain white spaces and commas. All white spaces are collapsed. Filenames can be described by filepatterns containing percent signs as placeholders for single decimal digits. All percent signs in a filename are filled from right to left with the file number (default 0). Remaining percent signs are filled with 0. Parameters are separated with commas. In this sense, the filenpattern is parameter zero of the whole pattern: ::= {,} ::= ,, ::= {} ::= | ::= '0' | '1' | ... | '9' | 'a' | 'b' | 'c' ... | 'z' | 'A' | 'B' | 'C' ... | 'Z' ::= '/' | '.' | '_' | '-' | '+' | '$' | '~' | '%' '$' and '~' are escape characters for environment parameters e.g. $source/hyp01%%%%ccd,15,30,2 The file pattern is hyp01%%%ccd, the parameters are 15, 30 and 2. The file pattern describes a sequence of file names (assuming $source is /users/data): /users/data/hyp010015ccd /users/data/hyp010017ccd /users/data/hyp010019ccd ... /users/data/hyp010029ccd ***************************************************************************/ #ifndef _FILENAME_ # define _FILENAME_ /*************************************************************************** * General Definitions * ***************************************************************************/ # ifndef PRIVATE # define PRIVATE static # define PUBLIC # endif PUBLIC extern char // get unix-type filename * filename_unix ( char * buffer, size_t buflen, const char * pattern ), // get path * filename_path ( char * buffer, size_t buflen, const char * pattern ), // get filename * filename_name ( char * buffer, size_t buflen, const char * pattern ), // get filename without extension * filename_body ( char * buffer, size_t buflen, const char * pattern ), // get extension * filename_extension ( char * buffer, size_t buflen, const char * pattern ), // get full filename * filename_full ( char * buffer, size_t buflen, const char * pattern ), // get parameter parno * filename_parameter ( char * buffer, size_t buflen, const char *pattern, int parno ), // expand pattern with number and return filename * filename_pattern ( char * buffer, size_t buflen, const char * pattern, long number ); PUBLIC extern int // return 0, if file does not exist filename_exists ( const char * filename ), // return 0, if files are equal filename_compare ( const char * filename1, const char * filename2 ), // return 0, if filename has not path filename_has_path ( const char * filename ), // return 0, if file name has no '%' pattern filename_has_pattern ( const char * filename ); PUBLIC extern const char // return version * filename_version ( void ); #endif /************************************************************************---*/ spd-1.3.0/edfpack/filename.c0000644000175000017500000006425511633462462012566 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ # define FILENAME_VERSION "filename : V1.10 Peter Boesecke 2010-12-18" /*+++------------------------------------------------------------------------ NAME filename --- filename and directory routines SYNOPSIS # include filename.h INCLUDE FILES filename.h RESTRICTIONS The maximum length of a filename or path is limited to BUFLEN which is set equal to PATH_MAX (usually defined in limits.h), or to MAX_FNAME (usually defined in stdio.h) or to 260 if none of both constants are defined. DESCRIPTION HISTORY 2001-07-03 V1.0 Peter Boesecke (replaces module SaxsGetName.inc) 2001-07-08 V1.1 PB all input and output buffers can be identical 2001-07-08 V1.2 PB filename_body, filename_extension 2002-07-26 V1.3 PB filename_pattern allows other characters between '%' 2004-03-24 V1.4 PB filename_full checks for /dev/null 2007-03-08 V1.5 PB for WIN32 (__LCC__): BUFLEN defined as PATH_MAX or MAX_FNAME filename_exist returns 1 2007-04-19 V1.6 PB -Wall compiler warnings resolved 2007-04-25 V1.7 PB filename_parameter: signed/unsigned comparison fixed 2007-06-20 V1.8 PB filename_unix: White spaces are not removed any more 2008-05-07 V1.9 PB filename_has_path added, filename_unix: env_subst included and everywhere else removed 2010-12-18 V1.10 PB filename_pattern: unnecessary calculation removed --------------------------------------------------------------------------*/ /*************************************************************************** * Private part * ***************************************************************************/ /*************************************************************************** * Include files * ***************************************************************************/ #include #include #include #ifndef WIN32 # include #endif #include #include #include "filename.h" /*************************************************************************** * Defines * ***************************************************************************/ #ifdef sun # include # define GETCWD(x,y) getwd (x) #else # ifdef WIN32 # include # define GETCWD(x,y) _getcwd(x, y) # else # define GETCWD(x,y) getcwd (x, y) # endif #endif #ifdef WIN32 # // do not know, eventually special "dirent.h" #else # include # include #endif #ifdef PATH_MAX # define BUFLEN PATH_MAX #else # ifdef MAX_FNAME # define BUFLEN MAX_FNAME # else # define BUFLEN 260 # endif #endif # ifndef MIN # define MIN( n1, n2) ( ( n1)<( n2) ? ( n1) : ( n2) ) # endif # ifndef ABS # define ABS( n1) ( ( n1)<0 ? -( n1) : ( n1) ) # endif /*************************************************************************** * Global Uninitialised Variables * ***************************************************************************/ #ifndef WIN32 static struct passwd *pwd_entry; #endif /****************************************************************************** * Private Constants * ******************************************************************************/ /* static char white_spaces[7] = { ' ', '\t', '\r', '\n', '\f', '\v', '\0' };*/ /****************************************************************************** * Private Type Defs * ******************************************************************************/ /****************************************************************************** * Private Variables * ******************************************************************************/ /****************************************************************************** * Routines * ******************************************************************************/ /*+++------------------------------------------------------------------------ NAME filename_version --- return version string SYNOPSIS const char * filename_version ( void ); DESCRIPTION RETURN VALUE Pointer to a constant character string containing the version of this module. ----------------------------------------------------------------------------*/ const char * filename_version ( void ) { return(FILENAME_VERSION); } // filename_version /*+++------------------------------------------------------------------------ NAME filename_parameter --- extract parameter string n from pattern SYNOPSIS char * filename_parameter ( char * buffer, size_t buflen, const char *pattern, int parno ); DESCRIPTION Extracts parameter string parno from pattern. Parameter strings are terminated with commas. If pattern does not contain any comma the full pattern string is returned. If parameter parno is not available (char *) NULL is returned. If pattern is a valid string parameter string 0 does always exist. parno=0 returns the filename pattern, parno=1 returns the substring between the first and the second comma, parno=3 returns the substring between the second and the third comma etc. The return value is NULL if the requested parameter cannot be found. RETURN VALUE Pointer to the filled output buffer or NULL if parameter string is not available. ----------------------------------------------------------------------------*/ char * filename_parameter ( char * buffer, size_t buflen, const char *pattern, int parno ) { int cnt; size_t len; const char * str1, * str2, * strend; char Temp[BUFLEN]; if (pattern == (char *) NULL) return ( (char *) NULL ); if (parno<0) return ( (char *) NULL ); // parameter not available // copy pattern into temporary buffer len = MIN(BUFLEN,strlen(pattern)+1)-1; (void) strncpy (Temp, pattern, len+1); Temp[len] = '\0'; strend = Temp+strlen(Temp); cnt = 0; str1 = Temp; str2 = str1-1; while ( cnt++ <= parno ) { // set str1 to start of parameter if ( str2 < strend ) { str1 = ++str2; // skip comma } else { return ( (char *) NULL ); // parameter not found } // search end of parameter if ( (str2 = strchr (str1, ',')) == (char *) NULL) { str2 = strend; } } // copy parameter len = MIN(buflen,(unsigned long) (str2-str1+1))-1; (void) strncpy (buffer, str1, len); buffer[len] = '\0'; return( buffer ); } // filename_parameter /*+++------------------------------------------------------------------------ NAME env_extract --- extract environment parameter SYNOPSIS char * env_extract ( char * buffer, size_t buflen, const char ** pps ); DESCRIPTION Extract environment variables and copy to buffer. *pps must point to the beginning of an environment parameter, eventually in curly braces. RETURN VALUE Pointer to the filled output buffer or NULL in case of an error. *ps is incremented and points after the end of the environment parameter or to the error position. ----------------------------------------------------------------------------*/ char * env_extract ( char * buffer, size_t buflen, const char ** pps ) { size_t cnt; int run=1; int parcnt; // counts curly braces char *pb; if (**pps=='{') run=1; else run=2; // stop only after '}' if start is '{' for (cnt=0, pb=buffer, parcnt=0; (cntpw_dir)) ) { return ( (char *) NULL ); // no entry } len = MIN(buflen,strlen(str)+1)-1; (void) strncpy (pb, str, len+1); pb += len; cnt += len; break; #endif case '$': ps++; str=env_extract ( EnvStr, BUFLEN, &ps ); if (!str) return ( (char *) NULL ); if (strlen(str)==0) { *pb++='$'; cnt++; } else { str = getenv(str); if (!str) return ( (char *) NULL ); // no entry len = MIN(buflen,strlen(str)+1)-1; (void) strncpy (pb, str, len+1); pb += len; cnt += len; } break; case '{': str=env_extract ( EnvStr, BUFLEN, &ps ); if (!str) return ( (char *) NULL ); len = MIN(buflen,strlen(str)+1)-1; (void) strncpy (pb, str, len+1); pb += len; cnt += len; break; case '}': return ( (char *) NULL ); // invalid break; default : *pb++ = *ps++; cnt++; } } // for *pb = '\0'; // terminate string return( buffer ); } // env_subst /*+++------------------------------------------------------------------------ NAME filename_unix --- return unix-type file pattern SYNOPSIS char * filename_unix ( char * buffer, size_t buflen, const char * pattern ); DESCRIPTION Substitute environment variables, separate file pattern from parameters, convert all back-slashes to slashes (pattern and buffer can be identical). RETURN VALUE unix type file pattern or NULL in case of an error ----------------------------------------------------------------------------*/ char * filename_unix ( char * buffer, size_t buflen, const char * pattern ) { const char * ps; char * pb, EnvPattern[BUFLEN], FilePattern[BUFLEN]; size_t cnt; if (pattern == (char *) NULL) return ( (char *) NULL ); // Substitute Environment Variables ps = env_subst( EnvPattern, BUFLEN, pattern ); if (ps == (char *) NULL) return ( (char *) NULL ); // Extract FilePattern ps = filename_parameter ( FilePattern, BUFLEN, EnvPattern, 0 ); if (ps == (char *) NULL) return ( (char *) NULL ); for (cnt=0, pb=buffer, ps=FilePattern; (cnt=start; pb-- ) { if (*pb=='%') { if ( (str>=Temp)&&(*str!=' ') ) { *pb=*str--; } else { *pb='0'; } } } pb++; // if number is negative write sign if (number<0) *pb='-'; return( buffer ); } // filename_pattern /*+++------------------------------------------------------------------------ NAME filename_exists --- return 0, if file does not exist SYNOPSIS int filename_exists ( const char * filename ); DESCRIPTION This function tests to see if the named file exists (True) or not (False). The Argument is first tested for a value as an environment variable and this value is substituted (if appropriate). The argument is then tested for it's existence. RETURN VALUE Returns 0 if file does not exist ----------------------------------------------------------------------------*/ int filename_exists ( const char * filename ) { #ifndef WIN32 int Found = 0; DIR *dirp; struct dirent *dp; char *Name, *str, Path[BUFLEN], Temp[BUFLEN]; str = filename_unix ( Temp, BUFLEN, filename ); if (str == (char *) NULL) return ( 0 ); if ((str = strrchr ( Temp, '/')) == (char *) NULL) { (void) strcpy (Path, "."); Name = Temp; } else { str++; (void) strncpy(Path,Temp,str-Temp); Path[str-Temp]='\0'; Name = str; } if ((dirp = opendir (Path)) != (DIR *) NULL) { while ((dp = readdir (dirp)) != (struct dirent *) NULL) { if (! strcmp (dp->d_name, Name)) { Found = 1; break; } } (void) closedir(dirp); } return ( Found ); #else // could probably be constructed with // char **findfiles(char *dir,int flags=0); return ( 1 ); #endif } // filename_exists /*+++------------------------------------------------------------------------ NAME filename_compare --- return 0, if files are equal SYNOPSIS int filename_compare ( const char * filename1, const char * filename2 ); DESCRIPTION Expands both filenames with filename_full and compares the strings with strcmp. The result of strcmp is returned. Both filenames must be correct. If one of the filenames is invalid it is replaced by an empty string. RETURN VALUE 0, if files are equal or if at least one of the filenames are invalid. ----------------------------------------------------------------------------*/ int filename_compare ( const char * filename1, const char * filename2 ) { char *str1, *str2; char FileName1[BUFLEN], FileName2[BUFLEN]; str1 = filename_full ( FileName1, BUFLEN, filename1 ); if (str1==(char*) NULL) str1=""; str2 = filename_full ( FileName2, BUFLEN, filename2 ); if (str2==(char*) NULL) str2=""; return ( strcmp(str1, str2) ); } // filename_compare spd-1.3.0/edfpack/isotime.h0000644000175000017500000000770611633462461012461 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2005-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /*+++*********************************************************************** NAME isotime.h SYNOPSIS #include "isotime.h" DESCRIPTION Header of the module "isotime.c" ***********************************************************************---*/ #ifndef _ISOTIME_ # define _ISOTIME_ /*************************************************************************** * General Definitions * ***************************************************************************/ #ifndef PRIVATE # define PRIVATE static // used to declare variables of private type #endif #ifndef PUBLIC # define PUBLIC // used to declare variables of public type #endif /**************************************************************************** * Include * ****************************************************************************/ # include # include # include # include # include # include # include # include # include # include /****************************************************************************** * Public Definitions * ******************************************************************************/ # define EPOCHLEN 64 // sssssss...sssssssss.uuuuuu # define ISOTIMELEN 64 // sssssss...sssssssss.uuuuuu /****************************************************************************** * Public Type Defs * ******************************************************************************/ typedef struct isotime_epoch { int status; long int sec; // integer part (in seconds since "1970-01-01 00:00:00") double fract; // decimal fraction (0<=fraction<1) long int offset; // offset from GMT } IsotimeEpoch; /*===========================================================================*/ /*************************************************************************** * Functions * ***************************************************************************/ PUBLIC extern IsotimeEpoch isotime2epoch (const char *isotime_s); IsotimeEpoch string2epoch (const char *string); IsotimeEpoch setoffset2epoch (IsotimeEpoch epoch, const char *offset_s); IsotimeEpoch addoffset2epoch (IsotimeEpoch epoch, const char *offset_s); const char * epoch2isotime (char buffer[], size_t buflen, IsotimeEpoch epoch); const char * epoch2string (char buffer[], size_t buflen, IsotimeEpoch epoch); const char * isotime_version (void); void isotime_debug (int debug); #endif spd-1.3.0/install-sh0000755000175000017500000003253711643121541011236 00000000000000#!/bin/sh # install - install a program, script, or datafile scriptversion=2009-04-28.21; # UTC # This originates from X11R5 (mit/util/scripts/install.sh), which was # later released in X11R6 (xc/config/util/install.sh) with the # following copyright and license. # # Copyright (C) 1994 X Consortium # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to # deal in the Software without restriction, including without limitation the # rights to use, copy, modify, merge, publish, distribute, sublicense, and/or # sell copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in # all copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN # AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC- # TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. # # Except as contained in this notice, the name of the X Consortium shall not # be used in advertising or otherwise to promote the sale, use or other deal- # ings in this Software without prior written authorization from the X Consor- # tium. # # # FSF changes to this file are in the public domain. # # Calling this script install-sh is preferred over install.sh, to prevent # `make' implicit rules from creating a file called install from it # when there is no Makefile. # # This script is compatible with the BSD install script, but was written # from scratch. nl=' ' IFS=" "" $nl" # set DOITPROG to echo to test this script # Don't use :- since 4.3BSD and earlier shells don't like it. doit=${DOITPROG-} if test -z "$doit"; then doit_exec=exec else doit_exec=$doit fi # Put in absolute file names if you don't have them in your path; # or use environment vars. chgrpprog=${CHGRPPROG-chgrp} chmodprog=${CHMODPROG-chmod} chownprog=${CHOWNPROG-chown} cmpprog=${CMPPROG-cmp} cpprog=${CPPROG-cp} mkdirprog=${MKDIRPROG-mkdir} mvprog=${MVPROG-mv} rmprog=${RMPROG-rm} stripprog=${STRIPPROG-strip} posix_glob='?' initialize_posix_glob=' test "$posix_glob" != "?" || { if (set -f) 2>/dev/null; then posix_glob= else posix_glob=: fi } ' posix_mkdir= # Desired mode of installed file. mode=0755 chgrpcmd= chmodcmd=$chmodprog chowncmd= mvcmd=$mvprog rmcmd="$rmprog -f" stripcmd= src= dst= dir_arg= dst_arg= copy_on_change=false no_target_directory= usage="\ Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE or: $0 [OPTION]... SRCFILES... DIRECTORY or: $0 [OPTION]... -t DIRECTORY SRCFILES... or: $0 [OPTION]... -d DIRECTORIES... In the 1st form, copy SRCFILE to DSTFILE. In the 2nd and 3rd, copy all SRCFILES to DIRECTORY. In the 4th, create DIRECTORIES. Options: --help display this help and exit. --version display version info and exit. -c (ignored) -C install only if different (preserve the last data modification time) -d create directories instead of installing files. -g GROUP $chgrpprog installed files to GROUP. -m MODE $chmodprog installed files to MODE. -o USER $chownprog installed files to USER. -s $stripprog installed files. -t DIRECTORY install into DIRECTORY. -T report an error if DSTFILE is a directory. Environment variables override the default commands: CHGRPPROG CHMODPROG CHOWNPROG CMPPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG " while test $# -ne 0; do case $1 in -c) ;; -C) copy_on_change=true;; -d) dir_arg=true;; -g) chgrpcmd="$chgrpprog $2" shift;; --help) echo "$usage"; exit $?;; -m) mode=$2 case $mode in *' '* | *' '* | *' '* | *'*'* | *'?'* | *'['*) echo "$0: invalid mode: $mode" >&2 exit 1;; esac shift;; -o) chowncmd="$chownprog $2" shift;; -s) stripcmd=$stripprog;; -t) dst_arg=$2 shift;; -T) no_target_directory=true;; --version) echo "$0 $scriptversion"; exit $?;; --) shift break;; -*) echo "$0: invalid option: $1" >&2 exit 1;; *) break;; esac shift done if test $# -ne 0 && test -z "$dir_arg$dst_arg"; then # When -d is used, all remaining arguments are directories to create. # When -t is used, the destination is already specified. # Otherwise, the last argument is the destination. Remove it from $@. for arg do if test -n "$dst_arg"; then # $@ is not empty: it contains at least $arg. set fnord "$@" "$dst_arg" shift # fnord fi shift # arg dst_arg=$arg done fi if test $# -eq 0; then if test -z "$dir_arg"; then echo "$0: no input file specified." >&2 exit 1 fi # It's OK to call `install-sh -d' without argument. # This can happen when creating conditional directories. exit 0 fi if test -z "$dir_arg"; then trap '(exit $?); exit' 1 2 13 15 # Set umask so as not to create temps with too-generous modes. # However, 'strip' requires both read and write access to temps. case $mode in # Optimize common cases. *644) cp_umask=133;; *755) cp_umask=22;; *[0-7]) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw='% 200' fi cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;; *) if test -z "$stripcmd"; then u_plus_rw= else u_plus_rw=,u+rw fi cp_umask=$mode$u_plus_rw;; esac fi for src do # Protect names starting with `-'. case $src in -*) src=./$src;; esac if test -n "$dir_arg"; then dst=$src dstdir=$dst test -d "$dstdir" dstdir_status=$? else # Waiting for this to be detected by the "$cpprog $src $dsttmp" command # might cause directories to be created, which would be especially bad # if $src (and thus $dsttmp) contains '*'. if test ! -f "$src" && test ! -d "$src"; then echo "$0: $src does not exist." >&2 exit 1 fi if test -z "$dst_arg"; then echo "$0: no destination specified." >&2 exit 1 fi dst=$dst_arg # Protect names starting with `-'. case $dst in -*) dst=./$dst;; esac # If destination is a directory, append the input filename; won't work # if double slashes aren't ignored. if test -d "$dst"; then if test -n "$no_target_directory"; then echo "$0: $dst_arg: Is a directory" >&2 exit 1 fi dstdir=$dst dst=$dstdir/`basename "$src"` dstdir_status=0 else # Prefer dirname, but fall back on a substitute if dirname fails. dstdir=` (dirname "$dst") 2>/dev/null || expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$dst" : 'X\(//\)[^/]' \| \ X"$dst" : 'X\(//\)$' \| \ X"$dst" : 'X\(/\)' \| . 2>/dev/null || echo X"$dst" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q' ` test -d "$dstdir" dstdir_status=$? fi fi obsolete_mkdir_used=false if test $dstdir_status != 0; then case $posix_mkdir in '') # Create intermediate dirs using mode 755 as modified by the umask. # This is like FreeBSD 'install' as of 1997-10-28. umask=`umask` case $stripcmd.$umask in # Optimize common cases. *[2367][2367]) mkdir_umask=$umask;; .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;; *[0-7]) mkdir_umask=`expr $umask + 22 \ - $umask % 100 % 40 + $umask % 20 \ - $umask % 10 % 4 + $umask % 2 `;; *) mkdir_umask=$umask,go-w;; esac # With -d, create the new directory with the user-specified mode. # Otherwise, rely on $mkdir_umask. if test -n "$dir_arg"; then mkdir_mode=-m$mode else mkdir_mode= fi posix_mkdir=false case $umask in *[123567][0-7][0-7]) # POSIX mkdir -p sets u+wx bits regardless of umask, which # is incompatible with FreeBSD 'install' when (umask & 300) != 0. ;; *) tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$ trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0 if (umask $mkdir_umask && exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1 then if test -z "$dir_arg" || { # Check for POSIX incompatibilities with -m. # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or # other-writeable bit of parent directory when it shouldn't. # FreeBSD 6.1 mkdir -m -p sets mode of existing directory. ls_ld_tmpdir=`ls -ld "$tmpdir"` case $ls_ld_tmpdir in d????-?r-*) different_mode=700;; d????-?--*) different_mode=755;; *) false;; esac && $mkdirprog -m$different_mode -p -- "$tmpdir" && { ls_ld_tmpdir_1=`ls -ld "$tmpdir"` test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1" } } then posix_mkdir=: fi rmdir "$tmpdir/d" "$tmpdir" else # Remove any dirs left behind by ancient mkdir implementations. rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null fi trap '' 0;; esac;; esac if $posix_mkdir && ( umask $mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir" ) then : else # The umask is ridiculous, or mkdir does not conform to POSIX, # or it failed possibly due to a race condition. Create the # directory the slow way, step by step, checking for races as we go. case $dstdir in /*) prefix='/';; -*) prefix='./';; *) prefix='';; esac eval "$initialize_posix_glob" oIFS=$IFS IFS=/ $posix_glob set -f set fnord $dstdir shift $posix_glob set +f IFS=$oIFS prefixes= for d do test -z "$d" && continue prefix=$prefix$d if test -d "$prefix"; then prefixes= else if $posix_mkdir; then (umask=$mkdir_umask && $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break # Don't fail if two instances are running concurrently. test -d "$prefix" || exit 1 else case $prefix in *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;; *) qprefix=$prefix;; esac prefixes="$prefixes '$qprefix'" fi fi prefix=$prefix/ done if test -n "$prefixes"; then # Don't fail if two instances are running concurrently. (umask $mkdir_umask && eval "\$doit_exec \$mkdirprog $prefixes") || test -d "$dstdir" || exit 1 obsolete_mkdir_used=true fi fi fi if test -n "$dir_arg"; then { test -z "$chowncmd" || $doit $chowncmd "$dst"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } && { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false || test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1 else # Make a couple of temp file names in the proper directory. dsttmp=$dstdir/_inst.$$_ rmtmp=$dstdir/_rm.$$_ # Trap to clean up those temp files at exit. trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0 # Copy the file name to the temp name. (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") && # and set any options; do chmod last to preserve setuid bits. # # If any of these fail, we abort the whole thing. If we want to # ignore errors from any of these, just make sure not to ignore # errors from the above "$doit $cpprog $src $dsttmp" command. # { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } && # If -C, don't bother to copy if it wouldn't change the file. if $copy_on_change && old=`LC_ALL=C ls -dlL "$dst" 2>/dev/null` && new=`LC_ALL=C ls -dlL "$dsttmp" 2>/dev/null` && eval "$initialize_posix_glob" && $posix_glob set -f && set X $old && old=:$2:$4:$5:$6 && set X $new && new=:$2:$4:$5:$6 && $posix_glob set +f && test "$old" = "$new" && $cmpprog "$dst" "$dsttmp" >/dev/null 2>&1 then rm -f "$dsttmp" else # Rename the file to the real destination. $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null || # The rename failed, perhaps because mv can't rename something else # to itself, or perhaps because mv is so ancient that it does not # support -f. { # Now remove or move aside any old file at destination location. # We try this two ways since rm can't unlink itself on some # systems and the destination file might be busy for other # reasons. In this case, the final cleanup might fail but the new # file should still install successfully. { test ! -f "$dst" || $doit $rmcmd -f "$dst" 2>/dev/null || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; } } || { echo "$0: cannot unlink or rename $dst" >&2 (exit 1); exit 1 } } && # Now rename the file to the real destination. $doit $mvcmd "$dsttmp" "$dst" } fi || exit 1 trap '' 0 fi done # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: spd-1.3.0/depcomp0000755000175000017500000004426711643121541010612 00000000000000#! /bin/sh # depcomp - compile a program generating dependencies as side-effects scriptversion=2009-04-28.21; # UTC # Copyright (C) 1999, 2000, 2003, 2004, 2005, 2006, 2007, 2009 Free # Software Foundation, Inc. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. # Originally written by Alexandre Oliva . case $1 in '') echo "$0: No command. Try \`$0 --help' for more information." 1>&2 exit 1; ;; -h | --h*) cat <<\EOF Usage: depcomp [--help] [--version] PROGRAM [ARGS] Run PROGRAMS ARGS to compile a file, generating dependencies as side-effects. Environment variables: depmode Dependency tracking mode. source Source file read by `PROGRAMS ARGS'. object Object file output by `PROGRAMS ARGS'. DEPDIR directory where to store dependencies. depfile Dependency file to output. tmpdepfile Temporary file to use when outputing dependencies. libtool Whether libtool is used (yes/no). Report bugs to . EOF exit $? ;; -v | --v*) echo "depcomp $scriptversion" exit $? ;; esac if test -z "$depmode" || test -z "$source" || test -z "$object"; then echo "depcomp: Variables source, object and depmode must be set" 1>&2 exit 1 fi # Dependencies for sub/bar.o or sub/bar.obj go into sub/.deps/bar.Po. depfile=${depfile-`echo "$object" | sed 's|[^\\/]*$|'${DEPDIR-.deps}'/&|;s|\.\([^.]*\)$|.P\1|;s|Pobj$|Po|'`} tmpdepfile=${tmpdepfile-`echo "$depfile" | sed 's/\.\([^.]*\)$/.T\1/'`} rm -f "$tmpdepfile" # Some modes work just like other modes, but use different flags. We # parameterize here, but still list the modes in the big case below, # to make depend.m4 easier to write. Note that we *cannot* use a case # here, because this file can only contain one case statement. if test "$depmode" = hp; then # HP compiler uses -M and no extra arg. gccflag=-M depmode=gcc fi if test "$depmode" = dashXmstdout; then # This is just like dashmstdout with a different argument. dashmflag=-xM depmode=dashmstdout fi cygpath_u="cygpath -u -f -" if test "$depmode" = msvcmsys; then # This is just like msvisualcpp but w/o cygpath translation. # Just convert the backslash-escaped backslashes to single forward # slashes to satisfy depend.m4 cygpath_u="sed s,\\\\\\\\,/,g" depmode=msvisualcpp fi case "$depmode" in gcc3) ## gcc 3 implements dependency tracking that does exactly what ## we want. Yay! Note: for some reason libtool 1.4 doesn't like ## it if -MD -MP comes after the -MF stuff. Hmm. ## Unfortunately, FreeBSD c89 acceptance of flags depends upon ## the command line argument order; so add the flags where they ## appear in depend2.am. Note that the slowdown incurred here ## affects only configure: in makefiles, %FASTDEP% shortcuts this. for arg do case $arg in -c) set fnord "$@" -MT "$object" -MD -MP -MF "$tmpdepfile" "$arg" ;; *) set fnord "$@" "$arg" ;; esac shift # fnord shift # $arg done "$@" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi mv "$tmpdepfile" "$depfile" ;; gcc) ## There are various ways to get dependency output from gcc. Here's ## why we pick this rather obscure method: ## - Don't want to use -MD because we'd like the dependencies to end ## up in a subdir. Having to rename by hand is ugly. ## (We might end up doing this anyway to support other compilers.) ## - The DEPENDENCIES_OUTPUT environment variable makes gcc act like ## -MM, not -M (despite what the docs say). ## - Using -M directly means running the compiler twice (even worse ## than renaming). if test -z "$gccflag"; then gccflag=-MD, fi "$@" -Wp,"$gccflag$tmpdepfile" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" echo "$object : \\" > "$depfile" alpha=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ## The second -e expression handles DOS-style file names with drive letters. sed -e 's/^[^:]*: / /' \ -e 's/^['$alpha']:\/[^:]*: / /' < "$tmpdepfile" >> "$depfile" ## This next piece of magic avoids the `deleted header file' problem. ## The problem is that when a header file which appears in a .P file ## is deleted, the dependency causes make to die (because there is ## typically no way to rebuild the header). We avoid this by adding ## dummy dependencies for each header file. Too bad gcc doesn't do ## this for us directly. tr ' ' ' ' < "$tmpdepfile" | ## Some versions of gcc put a space before the `:'. On the theory ## that the space means something, we add a space to the output as ## well. ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; sgi) if test "$libtool" = yes; then "$@" "-Wp,-MDupdate,$tmpdepfile" else "$@" -MDupdate "$tmpdepfile" fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" if test -f "$tmpdepfile"; then # yes, the sourcefile depend on other files echo "$object : \\" > "$depfile" # Clip off the initial element (the dependent). Don't try to be # clever and replace this with sed code, as IRIX sed won't handle # lines with more than a fixed number of characters (4096 in # IRIX 6.2 sed, 8192 in IRIX 6.5). We also remove comment lines; # the IRIX cc adds comments like `#:fec' to the end of the # dependency line. tr ' ' ' ' < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' | \ tr ' ' ' ' >> "$depfile" echo >> "$depfile" # The second pass generates a dummy entry for each header file. tr ' ' ' ' < "$tmpdepfile" \ | sed -e 's/^.*\.o://' -e 's/#.*$//' -e '/^$/ d' -e 's/$/:/' \ >> "$depfile" else # The sourcefile does not contain any dependencies, so just # store a dummy comment line, to avoid errors with the Makefile # "include basename.Plo" scheme. echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; aix) # The C for AIX Compiler uses -M and outputs the dependencies # in a .u file. In older versions, this file always lives in the # current directory. Also, the AIX compiler puts `$object:' at the # start of each line; $object doesn't have directory information. # Version 6 uses the directory in both cases. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then tmpdepfile1=$dir$base.u tmpdepfile2=$base.u tmpdepfile3=$dir.libs/$base.u "$@" -Wc,-M else tmpdepfile1=$dir$base.u tmpdepfile2=$dir$base.u tmpdepfile3=$dir$base.u "$@" -M fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then # Each line is of the form `foo.o: dependent.h'. # Do two passes, one to just change these to # `$object: dependent.h' and one to simply `dependent.h:'. sed -e "s,^.*\.[a-z]*:,$object:," < "$tmpdepfile" > "$depfile" # That's a tab and a space in the []. sed -e 's,^.*\.[a-z]*:[ ]*,,' -e 's,$,:,' < "$tmpdepfile" >> "$depfile" else # The sourcefile does not contain any dependencies, so just # store a dummy comment line, to avoid errors with the Makefile # "include basename.Plo" scheme. echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; icc) # Intel's C compiler understands `-MD -MF file'. However on # icc -MD -MF foo.d -c -o sub/foo.o sub/foo.c # ICC 7.0 will fill foo.d with something like # foo.o: sub/foo.c # foo.o: sub/foo.h # which is wrong. We want: # sub/foo.o: sub/foo.c # sub/foo.o: sub/foo.h # sub/foo.c: # sub/foo.h: # ICC 7.1 will output # foo.o: sub/foo.c sub/foo.h # and will wrap long lines using \ : # foo.o: sub/foo.c ... \ # sub/foo.h ... \ # ... "$@" -MD -MF "$tmpdepfile" stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile" exit $stat fi rm -f "$depfile" # Each line is of the form `foo.o: dependent.h', # or `foo.o: dep1.h dep2.h \', or ` dep3.h dep4.h \'. # Do two passes, one to just change these to # `$object: dependent.h' and one to simply `dependent.h:'. sed "s,^[^:]*:,$object :," < "$tmpdepfile" > "$depfile" # Some versions of the HPUX 10.20 sed can't process this invocation # correctly. Breaking it into two sed invocations is a workaround. sed 's,^[^:]*: \(.*\)$,\1,;s/^\\$//;/^$/d;/:$/d' < "$tmpdepfile" | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; hp2) # The "hp" stanza above does not work with aCC (C++) and HP's ia64 # compilers, which have integrated preprocessors. The correct option # to use with these is +Maked; it writes dependencies to a file named # 'foo.d', which lands next to the object file, wherever that # happens to be. # Much of this is similar to the tru64 case; see comments there. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then tmpdepfile1=$dir$base.d tmpdepfile2=$dir.libs/$base.d "$@" -Wc,+Maked else tmpdepfile1=$dir$base.d tmpdepfile2=$dir$base.d "$@" +Maked fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then sed -e "s,^.*\.[a-z]*:,$object:," "$tmpdepfile" > "$depfile" # Add `dependent.h:' lines. sed -ne '2,${ s/^ *// s/ \\*$// s/$/:/ p }' "$tmpdepfile" >> "$depfile" else echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" "$tmpdepfile2" ;; tru64) # The Tru64 compiler uses -MD to generate dependencies as a side # effect. `cc -MD -o foo.o ...' puts the dependencies into `foo.o.d'. # At least on Alpha/Redhat 6.1, Compaq CCC V6.2-504 seems to put # dependencies in `foo.d' instead, so we check for that too. # Subdirectories are respected. dir=`echo "$object" | sed -e 's|/[^/]*$|/|'` test "x$dir" = "x$object" && dir= base=`echo "$object" | sed -e 's|^.*/||' -e 's/\.o$//' -e 's/\.lo$//'` if test "$libtool" = yes; then # With Tru64 cc, shared objects can also be used to make a # static library. This mechanism is used in libtool 1.4 series to # handle both shared and static libraries in a single compilation. # With libtool 1.4, dependencies were output in $dir.libs/$base.lo.d. # # With libtool 1.5 this exception was removed, and libtool now # generates 2 separate objects for the 2 libraries. These two # compilations output dependencies in $dir.libs/$base.o.d and # in $dir$base.o.d. We have to check for both files, because # one of the two compilations can be disabled. We should prefer # $dir$base.o.d over $dir.libs/$base.o.d because the latter is # automatically cleaned when .libs/ is deleted, while ignoring # the former would cause a distcleancheck panic. tmpdepfile1=$dir.libs/$base.lo.d # libtool 1.4 tmpdepfile2=$dir$base.o.d # libtool 1.5 tmpdepfile3=$dir.libs/$base.o.d # libtool 1.5 tmpdepfile4=$dir.libs/$base.d # Compaq CCC V6.2-504 "$@" -Wc,-MD else tmpdepfile1=$dir$base.o.d tmpdepfile2=$dir$base.d tmpdepfile3=$dir$base.d tmpdepfile4=$dir$base.d "$@" -MD fi stat=$? if test $stat -eq 0; then : else rm -f "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" "$tmpdepfile4" exit $stat fi for tmpdepfile in "$tmpdepfile1" "$tmpdepfile2" "$tmpdepfile3" "$tmpdepfile4" do test -f "$tmpdepfile" && break done if test -f "$tmpdepfile"; then sed -e "s,^.*\.[a-z]*:,$object:," < "$tmpdepfile" > "$depfile" # That's a tab and a space in the []. sed -e 's,^.*\.[a-z]*:[ ]*,,' -e 's,$,:,' < "$tmpdepfile" >> "$depfile" else echo "#dummy" > "$depfile" fi rm -f "$tmpdepfile" ;; #nosideeffect) # This comment above is used by automake to tell side-effect # dependency tracking mechanisms from slower ones. dashmstdout) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout, regardless of -o. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi # Remove `-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done test -z "$dashmflag" && dashmflag=-M # Require at least two characters before searching for `:' # in the target name. This is to cope with DOS-style filenames: # a dependency such as `c:/foo/bar' could be seen as target `c' otherwise. "$@" $dashmflag | sed 's:^[ ]*[^: ][^:][^:]*\:[ ]*:'"$object"'\: :' > "$tmpdepfile" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" tr ' ' ' ' < "$tmpdepfile" | \ ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; dashXmstdout) # This case only exists to satisfy depend.m4. It is never actually # run, as this mode is specially recognized in the preamble. exit 1 ;; makedepend) "$@" || exit $? # Remove any Libtool call if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi # X makedepend shift cleared=no eat=no for arg do case $cleared in no) set ""; shift cleared=yes ;; esac if test $eat = yes; then eat=no continue fi case "$arg" in -D*|-I*) set fnord "$@" "$arg"; shift ;; # Strip any option that makedepend may not understand. Remove # the object too, otherwise makedepend will parse it as a source file. -arch) eat=yes ;; -*|$object) ;; *) set fnord "$@" "$arg"; shift ;; esac done obj_suffix=`echo "$object" | sed 's/^.*\././'` touch "$tmpdepfile" ${MAKEDEPEND-makedepend} -o"$obj_suffix" -f"$tmpdepfile" "$@" rm -f "$depfile" cat < "$tmpdepfile" > "$depfile" sed '1,2d' "$tmpdepfile" | tr ' ' ' ' | \ ## Some versions of the HPUX 10.20 sed can't process this invocation ## correctly. Breaking it into two sed invocations is a workaround. sed -e 's/^\\$//' -e '/^$/d' -e '/:$/d' | sed -e 's/$/ :/' >> "$depfile" rm -f "$tmpdepfile" "$tmpdepfile".bak ;; cpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi # Remove `-o $object'. IFS=" " for arg do case $arg in -o) shift ;; $object) shift ;; *) set fnord "$@" "$arg" shift # fnord shift # $arg ;; esac done "$@" -E | sed -n -e '/^# [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' \ -e '/^#line [0-9][0-9]* "\([^"]*\)".*/ s:: \1 \\:p' | sed '$ s: \\$::' > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" cat < "$tmpdepfile" >> "$depfile" sed < "$tmpdepfile" '/^$/d;s/^ //;s/ \\$//;s/$/ :/' >> "$depfile" rm -f "$tmpdepfile" ;; msvisualcpp) # Important note: in order to support this mode, a compiler *must* # always write the preprocessed file to stdout. "$@" || exit $? # Remove the call to Libtool. if test "$libtool" = yes; then while test "X$1" != 'X--mode=compile'; do shift done shift fi IFS=" " for arg do case "$arg" in -o) shift ;; $object) shift ;; "-Gm"|"/Gm"|"-Gi"|"/Gi"|"-ZI"|"/ZI") set fnord "$@" shift shift ;; *) set fnord "$@" "$arg" shift shift ;; esac done "$@" -E 2>/dev/null | sed -n '/^#line [0-9][0-9]* "\([^"]*\)"/ s::\1:p' | $cygpath_u | sort -u > "$tmpdepfile" rm -f "$depfile" echo "$object : \\" > "$depfile" sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s:: \1 \\:p' >> "$depfile" echo " " >> "$depfile" sed < "$tmpdepfile" -n -e 's% %\\ %g' -e '/^\(.*\)$/ s::\1\::p' >> "$depfile" rm -f "$tmpdepfile" ;; msvcmsys) # This case exists only to let depend.m4 do its work. It works by # looking at the text of this script. This case will never be run, # since it is checked for above. exit 1 ;; none) exec "$@" ;; *) echo "Unknown depmode $depmode" 1>&2 exit 1 ;; esac exit 0 # Local Variables: # mode: shell-script # sh-indentation: 2 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: spd-1.3.0/Makefile.in0000644000175000017500000005206611650556154011310 00000000000000# Makefile.in generated by automake 1.11.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, # 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, # Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : subdir = . DIST_COMMON = README $(am__configure_deps) $(srcdir)/Makefile.am \ $(srcdir)/Makefile.in $(srcdir)/config.h.in \ $(top_srcdir)/configure AUTHORS COPYING ChangeLog INSTALL NEWS \ depcomp install-sh missing ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \ configure.lineno config.status.lineno mkinstalldirs = $(install_sh) -d CONFIG_HEADER = config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = SOURCES = DIST_SOURCES = RECURSIVE_TARGETS = all-recursive check-recursive dvi-recursive \ html-recursive info-recursive install-data-recursive \ install-dvi-recursive install-exec-recursive \ install-html-recursive install-info-recursive \ install-pdf-recursive install-ps-recursive install-recursive \ installcheck-recursive installdirs-recursive pdf-recursive \ ps-recursive uninstall-recursive RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \ distclean-recursive maintainer-clean-recursive AM_RECURSIVE_TARGETS = $(RECURSIVE_TARGETS:-recursive=) \ $(RECURSIVE_CLEAN_TARGETS:-recursive=) tags TAGS ctags CTAGS \ distdir dist dist-all distcheck ETAGS = etags CTAGS = ctags DIST_SUBDIRS = $(SUBDIRS) DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) distdir = $(PACKAGE)-$(VERSION) top_distdir = $(distdir) am__remove_distdir = \ { test ! -d "$(distdir)" \ || { find "$(distdir)" -type d ! -perm -200 -exec chmod u+w {} ';' \ && rm -fr "$(distdir)"; }; } am__relativize = \ dir0=`pwd`; \ sed_first='s,^\([^/]*\)/.*$$,\1,'; \ sed_rest='s,^[^/]*/*,,'; \ sed_last='s,^.*/\([^/]*\)$$,\1,'; \ sed_butlast='s,/*[^/]*$$,,'; \ while test -n "$$dir1"; do \ first=`echo "$$dir1" | sed -e "$$sed_first"`; \ if test "$$first" != "."; then \ if test "$$first" = ".."; then \ dir2=`echo "$$dir0" | sed -e "$$sed_last"`/"$$dir2"; \ dir0=`echo "$$dir0" | sed -e "$$sed_butlast"`; \ else \ first2=`echo "$$dir2" | sed -e "$$sed_first"`; \ if test "$$first2" = "$$first"; then \ dir2=`echo "$$dir2" | sed -e "$$sed_rest"`; \ else \ dir2="../$$dir2"; \ fi; \ dir0="$$dir0"/"$$first"; \ fi; \ fi; \ dir1=`echo "$$dir1" | sed -e "$$sed_rest"`; \ done; \ reldir="$$dir2" DIST_ARCHIVES = $(distdir).tar.gz GZIP_ENV = --best distuninstallcheck_listfiles = find . -type f -print distcleancheck_listfiles = find . -type f -print ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ F77 = @F77@ FFLAGS = @FFLAGS@ FLIBS = @FLIBS@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ OBJEXT = @OBJEXT@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ POW_LIB = @POW_LIB@ RANLIB = @RANLIB@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ ac_ct_F77 = @ac_ct_F77@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build_alias = @build_alias@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host_alias = @host_alias@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ SUBDIRS = fitpack edfpack src man all: config.h $(MAKE) $(AM_MAKEFLAGS) all-recursive .SUFFIXES: am--refresh: @: $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ echo ' cd $(srcdir) && $(AUTOMAKE) --gnu'; \ $(am__cd) $(srcdir) && $(AUTOMAKE) --gnu \ && exit 0; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ echo ' $(SHELL) ./config.status'; \ $(SHELL) ./config.status;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) $(SHELL) ./config.status --recheck $(top_srcdir)/configure: $(am__configure_deps) $(am__cd) $(srcdir) && $(AUTOCONF) $(ACLOCAL_M4): $(am__aclocal_m4_deps) $(am__cd) $(srcdir) && $(ACLOCAL) $(ACLOCAL_AMFLAGS) $(am__aclocal_m4_deps): config.h: stamp-h1 @if test ! -f $@; then \ rm -f stamp-h1; \ $(MAKE) $(AM_MAKEFLAGS) stamp-h1; \ else :; fi stamp-h1: $(srcdir)/config.h.in $(top_builddir)/config.status @rm -f stamp-h1 cd $(top_builddir) && $(SHELL) ./config.status config.h $(srcdir)/config.h.in: $(am__configure_deps) ($(am__cd) $(top_srcdir) && $(AUTOHEADER)) rm -f stamp-h1 touch $@ distclean-hdr: -rm -f config.h stamp-h1 # This directory's subdirectories are mostly independent; you can cd # into them and run `make' without going through this Makefile. # To change the values of `make' variables: instead of editing Makefiles, # (1) if the variable is set in `config.status', edit `config.status' # (which will cause the Makefiles to be regenerated when you run `make'); # (2) otherwise, pass the desired values on the `make' command line. $(RECURSIVE_TARGETS): @fail= failcom='exit 1'; \ for f in x $$MAKEFLAGS; do \ case $$f in \ *=* | --[!k]*);; \ *k*) failcom='fail=yes';; \ esac; \ done; \ dot_seen=no; \ target=`echo $@ | sed s/-recursive//`; \ list='$(SUBDIRS)'; for subdir in $$list; do \ echo "Making $$target in $$subdir"; \ if test "$$subdir" = "."; then \ dot_seen=yes; \ local_target="$$target-am"; \ else \ local_target="$$target"; \ fi; \ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ || eval $$failcom; \ done; \ if test "$$dot_seen" = "no"; then \ $(MAKE) $(AM_MAKEFLAGS) "$$target-am" || exit 1; \ fi; test -z "$$fail" $(RECURSIVE_CLEAN_TARGETS): @fail= failcom='exit 1'; \ for f in x $$MAKEFLAGS; do \ case $$f in \ *=* | --[!k]*);; \ *k*) failcom='fail=yes';; \ esac; \ done; \ dot_seen=no; \ case "$@" in \ distclean-* | maintainer-clean-*) list='$(DIST_SUBDIRS)' ;; \ *) list='$(SUBDIRS)' ;; \ esac; \ rev=''; for subdir in $$list; do \ if test "$$subdir" = "."; then :; else \ rev="$$subdir $$rev"; \ fi; \ done; \ rev="$$rev ."; \ target=`echo $@ | sed s/-recursive//`; \ for subdir in $$rev; do \ echo "Making $$target in $$subdir"; \ if test "$$subdir" = "."; then \ local_target="$$target-am"; \ else \ local_target="$$target"; \ fi; \ ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) $$local_target) \ || eval $$failcom; \ done && test -z "$$fail" tags-recursive: list='$(SUBDIRS)'; for subdir in $$list; do \ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) tags); \ done ctags-recursive: list='$(SUBDIRS)'; for subdir in $$list; do \ test "$$subdir" = . || ($(am__cd) $$subdir && $(MAKE) $(AM_MAKEFLAGS) ctags); \ done ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ mkid -fID $$unique tags: TAGS TAGS: tags-recursive $(HEADERS) $(SOURCES) config.h.in $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) set x; \ here=`pwd`; \ if ($(ETAGS) --etags-include --version) >/dev/null 2>&1; then \ include_option=--etags-include; \ empty_fix=.; \ else \ include_option=--include; \ empty_fix=; \ fi; \ list='$(SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ test ! -f $$subdir/TAGS || \ set "$$@" "$$include_option=$$here/$$subdir/TAGS"; \ fi; \ done; \ list='$(SOURCES) $(HEADERS) config.h.in $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: CTAGS CTAGS: ctags-recursive $(HEADERS) $(SOURCES) config.h.in $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) list='$(SOURCES) $(HEADERS) config.h.in $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) $(am__remove_distdir) test -d "$(distdir)" || mkdir "$(distdir)" @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ test -d "$(distdir)/$$subdir" \ || $(MKDIR_P) "$(distdir)/$$subdir" \ || exit 1; \ fi; \ done @list='$(DIST_SUBDIRS)'; for subdir in $$list; do \ if test "$$subdir" = .; then :; else \ dir1=$$subdir; dir2="$(distdir)/$$subdir"; \ $(am__relativize); \ new_distdir=$$reldir; \ dir1=$$subdir; dir2="$(top_distdir)"; \ $(am__relativize); \ new_top_distdir=$$reldir; \ echo " (cd $$subdir && $(MAKE) $(AM_MAKEFLAGS) top_distdir="$$new_top_distdir" distdir="$$new_distdir" \\"; \ echo " am__remove_distdir=: am__skip_length_check=: am__skip_mode_fix=: distdir)"; \ ($(am__cd) $$subdir && \ $(MAKE) $(AM_MAKEFLAGS) \ top_distdir="$$new_top_distdir" \ distdir="$$new_distdir" \ am__remove_distdir=: \ am__skip_length_check=: \ am__skip_mode_fix=: \ distdir) \ || exit 1; \ fi; \ done -test -n "$(am__skip_mode_fix)" \ || find "$(distdir)" -type d ! -perm -755 \ -exec chmod u+rwx,go+rx {} \; -o \ ! -type d ! -perm -444 -links 1 -exec chmod a+r {} \; -o \ ! -type d ! -perm -400 -exec chmod a+r {} \; -o \ ! -type d ! -perm -444 -exec $(install_sh) -c -m a+r {} {} \; \ || chmod -R a+r "$(distdir)" dist-gzip: distdir tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz $(am__remove_distdir) dist-bzip2: distdir tardir=$(distdir) && $(am__tar) | bzip2 -9 -c >$(distdir).tar.bz2 $(am__remove_distdir) dist-lzma: distdir tardir=$(distdir) && $(am__tar) | lzma -9 -c >$(distdir).tar.lzma $(am__remove_distdir) dist-xz: distdir tardir=$(distdir) && $(am__tar) | xz -c >$(distdir).tar.xz $(am__remove_distdir) dist-tarZ: distdir tardir=$(distdir) && $(am__tar) | compress -c >$(distdir).tar.Z $(am__remove_distdir) dist-shar: distdir shar $(distdir) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).shar.gz $(am__remove_distdir) dist-zip: distdir -rm -f $(distdir).zip zip -rq $(distdir).zip $(distdir) $(am__remove_distdir) dist dist-all: distdir tardir=$(distdir) && $(am__tar) | GZIP=$(GZIP_ENV) gzip -c >$(distdir).tar.gz $(am__remove_distdir) # This target untars the dist file and tries a VPATH configuration. Then # it guarantees that the distribution is self-contained by making another # tarfile. distcheck: dist case '$(DIST_ARCHIVES)' in \ *.tar.gz*) \ GZIP=$(GZIP_ENV) gzip -dc $(distdir).tar.gz | $(am__untar) ;;\ *.tar.bz2*) \ bzip2 -dc $(distdir).tar.bz2 | $(am__untar) ;;\ *.tar.lzma*) \ lzma -dc $(distdir).tar.lzma | $(am__untar) ;;\ *.tar.xz*) \ xz -dc $(distdir).tar.xz | $(am__untar) ;;\ *.tar.Z*) \ uncompress -c $(distdir).tar.Z | $(am__untar) ;;\ *.shar.gz*) \ GZIP=$(GZIP_ENV) gzip -dc $(distdir).shar.gz | unshar ;;\ *.zip*) \ unzip $(distdir).zip ;;\ esac chmod -R a-w $(distdir); chmod a+w $(distdir) mkdir $(distdir)/_build mkdir $(distdir)/_inst chmod a-w $(distdir) test -d $(distdir)/_build || exit 0; \ dc_install_base=`$(am__cd) $(distdir)/_inst && pwd | sed -e 's,^[^:\\/]:[\\/],/,'` \ && dc_destdir="$${TMPDIR-/tmp}/am-dc-$$$$/" \ && am__cwd=`pwd` \ && $(am__cd) $(distdir)/_build \ && ../configure --srcdir=.. --prefix="$$dc_install_base" \ $(DISTCHECK_CONFIGURE_FLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) \ && $(MAKE) $(AM_MAKEFLAGS) dvi \ && $(MAKE) $(AM_MAKEFLAGS) check \ && $(MAKE) $(AM_MAKEFLAGS) install \ && $(MAKE) $(AM_MAKEFLAGS) installcheck \ && $(MAKE) $(AM_MAKEFLAGS) uninstall \ && $(MAKE) $(AM_MAKEFLAGS) distuninstallcheck_dir="$$dc_install_base" \ distuninstallcheck \ && chmod -R a-w "$$dc_install_base" \ && ({ \ (cd ../.. && umask 077 && mkdir "$$dc_destdir") \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" install \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" uninstall \ && $(MAKE) $(AM_MAKEFLAGS) DESTDIR="$$dc_destdir" \ distuninstallcheck_dir="$$dc_destdir" distuninstallcheck; \ } || { rm -rf "$$dc_destdir"; exit 1; }) \ && rm -rf "$$dc_destdir" \ && $(MAKE) $(AM_MAKEFLAGS) dist \ && rm -rf $(DIST_ARCHIVES) \ && $(MAKE) $(AM_MAKEFLAGS) distcleancheck \ && cd "$$am__cwd" \ || exit 1 $(am__remove_distdir) @(echo "$(distdir) archives ready for distribution: "; \ list='$(DIST_ARCHIVES)'; for i in $$list; do echo $$i; done) | \ sed -e 1h -e 1s/./=/g -e 1p -e 1x -e '$$p' -e '$$x' distuninstallcheck: @$(am__cd) '$(distuninstallcheck_dir)' \ && test `$(distuninstallcheck_listfiles) | wc -l` -le 1 \ || { echo "ERROR: files left after uninstall:" ; \ if test -n "$(DESTDIR)"; then \ echo " (check DESTDIR support)"; \ fi ; \ $(distuninstallcheck_listfiles) ; \ exit 1; } >&2 distcleancheck: distclean @if test '$(srcdir)' = . ; then \ echo "ERROR: distcleancheck can only run from a VPATH build" ; \ exit 1 ; \ fi @test `$(distcleancheck_listfiles) | wc -l` -eq 0 \ || { echo "ERROR: files left in build directory after distclean:" ; \ $(distcleancheck_listfiles) ; \ exit 1; } >&2 check-am: all-am check: check-recursive all-am: Makefile config.h installdirs: installdirs-recursive installdirs-am: install: install-recursive install-exec: install-exec-recursive install-data: install-data-recursive uninstall: uninstall-recursive install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-recursive install-strip: $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ `test -z '$(STRIP)' || \ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-recursive clean-am: clean-generic mostlyclean-am distclean: distclean-recursive -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -f Makefile distclean-am: clean-am distclean-generic distclean-hdr distclean-tags dvi: dvi-recursive dvi-am: html: html-recursive html-am: info: info-recursive info-am: install-data-am: install-dvi: install-dvi-recursive install-dvi-am: install-exec-am: install-html: install-html-recursive install-html-am: install-info: install-info-recursive install-info-am: install-man: install-pdf: install-pdf-recursive install-pdf-am: install-ps: install-ps-recursive install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-recursive -rm -f $(am__CONFIG_DISTCLEAN_FILES) -rm -rf $(top_srcdir)/autom4te.cache -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-recursive mostlyclean-am: mostlyclean-generic pdf: pdf-recursive pdf-am: ps: ps-recursive ps-am: uninstall-am: .MAKE: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) all \ ctags-recursive install-am install-strip tags-recursive .PHONY: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) CTAGS GTAGS \ all all-am am--refresh check check-am clean clean-generic \ ctags ctags-recursive dist dist-all dist-bzip2 dist-gzip \ dist-lzma dist-shar dist-tarZ dist-xz dist-zip distcheck \ distclean distclean-generic distclean-hdr distclean-tags \ distcleancheck distdir distuninstallcheck dvi dvi-am html \ html-am info info-am install install-am install-data \ install-data-am install-dvi install-dvi-am install-exec \ install-exec-am install-html install-html-am install-info \ install-info-am install-man install-pdf install-pdf-am \ install-ps install-ps-am install-strip installcheck \ installcheck-am installdirs installdirs-am maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-generic pdf \ pdf-am ps ps-am tags tags-recursive uninstall uninstall-am # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: spd-1.3.0/COPYING0000644000175000017500000000216311643121541010255 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2001-2011 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * J. Kieffer (kieffer@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ spd-1.3.0/configure0000755000175000017500000061455111650556153011154 00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.68 for spd 1.3.0. # # Report bugs to . # # # Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, # 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software # Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : else exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null; then : as_have_required=yes else as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir/$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : CONFIG_SHELL=$as_shell as_have_required=yes if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : break 2 fi fi done;; esac as_found=false done $as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : CONFIG_SHELL=$SHELL as_have_required=yes fi; } IFS=$as_save_IFS if test "x$CONFIG_SHELL" != x; then : # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV export CONFIG_SHELL case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} fi if test x$as_have_required = xno; then : $as_echo "$0: This script requires a shell more modern than all" $as_echo "$0: the shells that I found on your system." if test x${ZSH_VERSION+set} = xset ; then $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" $as_echo "$0: be upgraded to zsh 4.3.4 or later." else $as_echo "$0: Please tell bug-autoconf@gnu.org and $0: Jerome.Kieffer@esrf.fr about your system, including any $0: error possibly output before this message. Then install $0: a modern shell, or manually run the script under such a $0: shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='spd' PACKAGE_TARNAME='spd' PACKAGE_VERSION='1.3.0' PACKAGE_STRING='spd 1.3.0' PACKAGE_BUGREPORT='Jerome.Kieffer@esrf.fr' PACKAGE_URL='' ac_unique_file="." # Factoring default headers for most tests. ac_includes_default="\ #include #ifdef HAVE_SYS_TYPES_H # include #endif #ifdef HAVE_SYS_STAT_H # include #endif #ifdef STDC_HEADERS # include # include #else # ifdef HAVE_STDLIB_H # include # endif #endif #ifdef HAVE_STRING_H # if !defined STDC_HEADERS && defined HAVE_MEMORY_H # include # endif # include #endif #ifdef HAVE_STRINGS_H # include #endif #ifdef HAVE_INTTYPES_H # include #endif #ifdef HAVE_STDINT_H # include #endif #ifdef HAVE_UNISTD_H # include #endif" ac_subst_vars='am__EXEEXT_FALSE am__EXEEXT_TRUE LTLIBOBJS POW_LIB LIBOBJS EGREP GREP CPP RANLIB am__fastdepCC_FALSE am__fastdepCC_TRUE CCDEPMODE AMDEPBACKSLASH AMDEP_FALSE AMDEP_TRUE am__quote am__include DEPDIR ac_ct_CC CPPFLAGS CFLAGS CC FLIBS OBJEXT EXEEXT ac_ct_F77 LDFLAGS FFLAGS F77 am__untar am__tar AMTAR am__leading_dot SET_MAKE AWK mkdir_p MKDIR_P INSTALL_STRIP_PROGRAM STRIP install_sh MAKEINFO AUTOHEADER AUTOMAKE AUTOCONF ACLOCAL VERSION PACKAGE CYGPATH_W am__isrc INSTALL_DATA INSTALL_SCRIPT INSTALL_PROGRAM target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_dependency_tracking with_zlib_include_dir with_zlib_lib_dir ' ac_precious_vars='build_alias host_alias target_alias F77 FFLAGS LDFLAGS LIBS CC CFLAGS CPPFLAGS CPP' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac # Accept the important Cygnus configure options, so we can diagnose typos. case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: $ac_useropt" ac_useropt_orig=$ac_useropt ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. If a cross compiler is detected then cross compile mode will be used" >&2 elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures spd 1.3.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/spd] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF Program names: --program-prefix=PREFIX prepend PREFIX to installed program names --program-suffix=SUFFIX append SUFFIX to installed program names --program-transform-name=PROGRAM run sed PROGRAM on installed program names _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of spd 1.3.0:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --disable-dependency-tracking speeds up one-time build --enable-dependency-tracking do not reject slow dependency extractors Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) --with-zlib-include-dir=DIR location of Zlib headers --with-zlib-lib-dir=DIR location of Zlib library binary Some influential environment variables: F77 Fortran 77 compiler command FFLAGS Fortran 77 compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CC C compiler command CFLAGS C compiler flags CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to . _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for guested configure. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF spd configure 1.3.0 generated by GNU Autoconf 2.68 Copyright (C) 2010 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_f77_try_compile LINENO # ---------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_f77_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_f77_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_f77_try_compile # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists, giving a warning if it cannot be compiled using # the include files in INCLUDES and setting the cache variable VAR # accordingly. ac_fn_c_check_header_mongrel () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if eval \${$3+:} false; then : { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } else # Is the header compilable? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5 $as_echo_n "checking $2 usability... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_header_compiler=yes else ac_header_compiler=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5 $as_echo "$ac_header_compiler" >&6; } # Is the header present? { $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5 $as_echo_n "checking $2 presence... " >&6; } cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include <$2> _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : ac_header_preproc=yes else ac_header_preproc=no fi rm -f conftest.err conftest.i conftest.$ac_ext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 $as_echo "$ac_header_preproc" >&6; } # So? What about this header? case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #(( yes:no: ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5 $as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ;; no:yes:* ) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5 $as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5 $as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5 $as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5 $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} ( $as_echo "## ------------------------------------- ## ## Report this to Jerome.Kieffer@esrf.fr ## ## ------------------------------------- ##" ) | sed "s/^/$as_me: WARNING: /" >&2 ;; esac { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=\$ac_header_compiler" fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_mongrel # ac_fn_c_try_run LINENO # ---------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. Assumes # that executables *can* be run. ac_fn_c_try_run () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then : ac_retval=0 else $as_echo "$as_me: program exited with status $ac_status" >&5 $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_run # ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES # ------------------------------------------------------- # Tests whether HEADER exists and can be compiled using the include files in # INCLUDES, setting the cache variable VAR accordingly. ac_fn_c_check_header_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> _ACEOF if ac_fn_c_try_compile "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_header_compile # ac_fn_c_try_link LINENO # ----------------------- # Try to link conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_link () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest$ac_exeext if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest$ac_exeext && { test "$cross_compiling" = yes || $as_test_x conftest$ac_exeext }; then : ac_retval=0 else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would # interfere with the next link command; also delete a directory that is # left behind by Apple's compiler. We do this before executing the actions. rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_link # ac_fn_c_check_type LINENO TYPE VAR INCLUDES # ------------------------------------------- # Tests whether TYPE exists after having included INCLUDES, setting cache # variable VAR accordingly. ac_fn_c_check_type () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof ($2)) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int main () { if (sizeof (($2))) return 0; ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_type # ac_fn_c_check_func LINENO FUNC VAR # ---------------------------------- # Tests whether FUNC exists, setting the cache variable VAR accordingly ac_fn_c_check_func () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 $as_echo_n "checking for $2... " >&6; } if eval \${$3+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, which can conflict with char $2 (); below. Prefer to if __STDC__ is defined, since exists even on freestanding compilers. */ #ifdef __STDC__ # include #else # include #endif #undef $2 /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char $2 (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ #if defined __stub_$2 || defined __stub___$2 choke me #endif int main () { return $2 (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : eval "$3=yes" else eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 $as_echo "$ac_res" >&6; } eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # ac_fn_c_check_func cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by spd $as_me 1.3.0, which was generated by GNU Autoconf 2.68. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. $as_echo "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Save into config.log some information that might help in debugging. { echo $as_echo "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo $as_echo "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then $as_echo "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac $as_echo "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then $as_echo "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && $as_echo "$as_me: caught signal $ac_signal" $as_echo "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h $as_echo "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. cat >>confdefs.h <<_ACEOF #define PACKAGE_NAME "$PACKAGE_NAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_TARNAME "$PACKAGE_TARNAME" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_VERSION "$PACKAGE_VERSION" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_STRING "$PACKAGE_STRING" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" _ACEOF cat >>confdefs.h <<_ACEOF #define PACKAGE_URL "$PACKAGE_URL" _ACEOF # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. ac_site_file1=NONE ac_site_file2=NONE if test -n "$CONFIG_SITE"; then # We do not want a PATH search for config.site. case $CONFIG_SITE in #(( -*) ac_site_file1=./$CONFIG_SITE;; */*) ac_site_file1=$CONFIG_SITE;; *) ac_site_file1=./$CONFIG_SITE;; esac elif test "x$prefix" != xNONE; then ac_site_file1=$prefix/share/config.site ac_site_file2=$prefix/etc/config.site else ac_site_file1=$ac_default_prefix/share/config.site ac_site_file2=$ac_default_prefix/etc/config.site fi for ac_site_file in "$ac_site_file1" "$ac_site_file2" do test "x$ac_site_file" = xNONE && continue if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 $as_echo "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 $as_echo "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 $as_echo "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 $as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 $as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 $as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 $as_echo "$as_me: former value: \`$ac_old_val'" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 $as_echo "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu am__api_version='1.11' ac_aux_dir= for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do if test -f "$ac_dir/install-sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install-sh -c" break elif test -f "$ac_dir/install.sh"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/install.sh -c" break elif test -f "$ac_dir/shtool"; then ac_aux_dir=$ac_dir ac_install_sh="$ac_aux_dir/shtool install -c" break fi done if test -z "$ac_aux_dir"; then as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 fi # These three variables are undocumented and unsupported, # and are intended to be withdrawn in a future Autoconf release. # They can cause serious problems if a builder's source tree is in a directory # whose full name contains unusual characters. ac_config_guess="$SHELL $ac_aux_dir/config.guess" # Please don't use this var. ac_config_sub="$SHELL $ac_aux_dir/config.sub" # Please don't use this var. ac_configure="$SHELL $ac_aux_dir/configure" # Please don't use this var. # Find a good install program. We prefer a C program (faster), # so one script is as good as another. But avoid the broken or # incompatible versions: # SysV /etc/install, /usr/sbin/install # SunOS /usr/etc/install # IRIX /sbin/install # AIX /bin/install # AmigaOS /C/install, which installs bootblocks on floppy discs # AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag # AFS /usr/afsws/bin/install, which mishandles nonexistent args # SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" # OS/2's system install, which has a completely different semantic # ./install, which can be erroneously created by make from ./install.sh. # Reject install programs that cannot install multiple files. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 $as_echo_n "checking for a BSD-compatible install... " >&6; } if test -z "$INSTALL"; then if ${ac_cv_path_install+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. # Account for people who put trailing slashes in PATH elements. case $as_dir/ in #(( ./ | .// | /[cC]/* | \ /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ ?:[\\/]os2[\\/]install[\\/]* | ?:[\\/]OS2[\\/]INSTALL[\\/]* | \ /usr/ucb/* ) ;; *) # OSF1 and SCO ODT 3.0 have their own names for install. # Don't use installbsd from OSF since it installs stuff as root # by default. for ac_prog in ginstall scoinst install; do for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; }; then if test $ac_prog = install && grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # AIX install. It has an incompatible calling convention. : elif test $ac_prog = install && grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then # program-specific install script used by HP pwplus--don't use. : else rm -rf conftest.one conftest.two conftest.dir echo one > conftest.one echo two > conftest.two mkdir conftest.dir if "$as_dir/$ac_prog$ac_exec_ext" -c conftest.one conftest.two "`pwd`/conftest.dir" && test -s conftest.one && test -s conftest.two && test -s conftest.dir/conftest.one && test -s conftest.dir/conftest.two then ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" break 3 fi fi fi done done ;; esac done IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir fi if test "${ac_cv_path_install+set}" = set; then INSTALL=$ac_cv_path_install else # As a last resort, use the slow shell script. Don't cache a # value for INSTALL within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. INSTALL=$ac_install_sh fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $INSTALL" >&5 $as_echo "$INSTALL" >&6; } # Use test -z because SunOS4 sh mishandles braces in ${var-val}. # It thinks the first close brace ends the variable substitution. test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether build environment is sane" >&5 $as_echo_n "checking whether build environment is sane... " >&6; } # Just in case sleep 1 echo timestamp > conftest.file # Reject unsafe characters in $srcdir or the absolute working directory # name. Accept space and tab only in the latter. am_lf=' ' case `pwd` in *[\\\"\#\$\&\'\`$am_lf]*) as_fn_error $? "unsafe absolute working directory name" "$LINENO" 5;; esac case $srcdir in *[\\\"\#\$\&\'\`$am_lf\ \ ]*) as_fn_error $? "unsafe srcdir value: \`$srcdir'" "$LINENO" 5;; esac # Do `set' in a subshell so we don't clobber the current shell's # arguments. Must try -L first in case configure is actually a # symlink; some systems play weird games with the mod time of symlinks # (eg FreeBSD returns the mod time of the symlink's containing # directory). if ( set X `ls -Lt "$srcdir/configure" conftest.file 2> /dev/null` if test "$*" = "X"; then # -L didn't work. set X `ls -t "$srcdir/configure" conftest.file` fi rm -f conftest.file if test "$*" != "X $srcdir/configure conftest.file" \ && test "$*" != "X conftest.file $srcdir/configure"; then # If neither matched, then we have a broken ls. This can happen # if, for instance, CONFIG_SHELL is bash and it inherits a # broken ls alias from the environment. This has actually # happened. Such a system could not be considered "sane". as_fn_error $? "ls -t appears to fail. Make sure there is not a broken alias in your environment" "$LINENO" 5 fi test "$2" = conftest.file ) then # Ok. : else as_fn_error $? "newly created file is older than distributed files! Check your system clock" "$LINENO" 5 fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } test "$program_prefix" != NONE && program_transform_name="s&^&$program_prefix&;$program_transform_name" # Use a double $ so make ignores it. test "$program_suffix" != NONE && program_transform_name="s&\$&$program_suffix&;$program_transform_name" # Double any \ or $. # By default was `s,x,x', remove it if useless. ac_script='s/[\\$]/&&/g;s/;s,x,x,$//' program_transform_name=`$as_echo "$program_transform_name" | sed "$ac_script"` # expand $ac_aux_dir to an absolute path am_aux_dir=`cd $ac_aux_dir && pwd` if test x"${MISSING+set}" != xset; then case $am_aux_dir in *\ * | *\ *) MISSING="\${SHELL} \"$am_aux_dir/missing\"" ;; *) MISSING="\${SHELL} $am_aux_dir/missing" ;; esac fi # Use eval to expand $SHELL if eval "$MISSING --run true"; then am_missing_run="$MISSING --run " else am_missing_run= { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: \`missing' script is too old or missing" >&5 $as_echo "$as_me: WARNING: \`missing' script is too old or missing" >&2;} fi if test x"${install_sh}" != xset; then case $am_aux_dir in *\ * | *\ *) install_sh="\${SHELL} '$am_aux_dir/install-sh'" ;; *) install_sh="\${SHELL} $am_aux_dir/install-sh" esac fi # Installed binaries are usually stripped using `strip' when the user # run `make install-strip'. However `strip' might not be the right # tool to use in cross-compilation environments, therefore Automake # will honor the `STRIP' environment variable to overrule this program. if test "$cross_compiling" != no; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}strip", so it can be a program name with args. set dummy ${ac_tool_prefix}strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_STRIP="${ac_tool_prefix}strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $STRIP" >&5 $as_echo "$STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_STRIP"; then ac_ct_STRIP=$STRIP # Extract the first word of "strip", so it can be a program name with args. set dummy strip; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_STRIP+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_STRIP="strip" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_STRIP" >&5 $as_echo "$ac_ct_STRIP" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_STRIP" = x; then STRIP=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac STRIP=$ac_ct_STRIP fi else STRIP="$ac_cv_prog_STRIP" fi fi INSTALL_STRIP_PROGRAM="\$(install_sh) -c -s" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a thread-safe mkdir -p" >&5 $as_echo_n "checking for a thread-safe mkdir -p... " >&6; } if test -z "$MKDIR_P"; then if ${ac_cv_path_mkdir+:} false; then : $as_echo_n "(cached) " >&6 else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/opt/sfw/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in mkdir gmkdir; do for ac_exec_ext in '' $ac_executable_extensions; do { test -f "$as_dir/$ac_prog$ac_exec_ext" && $as_test_x "$as_dir/$ac_prog$ac_exec_ext"; } || continue case `"$as_dir/$ac_prog$ac_exec_ext" --version 2>&1` in #( 'mkdir (GNU coreutils) '* | \ 'mkdir (coreutils) '* | \ 'mkdir (fileutils) '4.1*) ac_cv_path_mkdir=$as_dir/$ac_prog$ac_exec_ext break 3;; esac done done done IFS=$as_save_IFS fi test -d ./--version && rmdir ./--version if test "${ac_cv_path_mkdir+set}" = set; then MKDIR_P="$ac_cv_path_mkdir -p" else # As a last resort, use the slow shell script. Don't cache a # value for MKDIR_P within a source directory, because that will # break other packages using the cache if that directory is # removed, or if the value is a relative name. MKDIR_P="$ac_install_sh -d" fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $MKDIR_P" >&5 $as_echo "$MKDIR_P" >&6; } mkdir_p="$MKDIR_P" case $mkdir_p in [\\/$]* | ?:[\\/]*) ;; */*) mkdir_p="\$(top_builddir)/$mkdir_p" ;; esac for ac_prog in gawk mawk nawk awk do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_AWK+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$AWK"; then ac_cv_prog_AWK="$AWK" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_AWK="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AWK" >&5 $as_echo "$AWK" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$AWK" && break done { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi rm -rf .tst 2>/dev/null mkdir .tst 2>/dev/null if test -d .tst; then am__leading_dot=. else am__leading_dot=_ fi rmdir .tst 2>/dev/null if test "`cd $srcdir && pwd`" != "`pwd`"; then # Use -I$(srcdir) only when $(srcdir) != ., so that make's output # is not polluted with repeated "-I." am__isrc=' -I$(srcdir)' # test to see if srcdir already configured if test -f $srcdir/config.status; then as_fn_error $? "source directory already configured; run \"make distclean\" there first" "$LINENO" 5 fi fi # test whether we have cygpath if test -z "$CYGPATH_W"; then if (cygpath --version) >/dev/null 2>/dev/null; then CYGPATH_W='cygpath -w' else CYGPATH_W=echo fi fi # Define the identity of the package. PACKAGE='spd' VERSION='1.3.0' cat >>confdefs.h <<_ACEOF #define PACKAGE "$PACKAGE" _ACEOF cat >>confdefs.h <<_ACEOF #define VERSION "$VERSION" _ACEOF # Some tools Automake needs. ACLOCAL=${ACLOCAL-"${am_missing_run}aclocal-${am__api_version}"} AUTOCONF=${AUTOCONF-"${am_missing_run}autoconf"} AUTOMAKE=${AUTOMAKE-"${am_missing_run}automake-${am__api_version}"} AUTOHEADER=${AUTOHEADER-"${am_missing_run}autoheader"} MAKEINFO=${MAKEINFO-"${am_missing_run}makeinfo"} # We need awk for the "check" target. The system "awk" is bad on # some platforms. # Always define AMTAR for backward compatibility. AMTAR=${AMTAR-"${am_missing_run}tar"} am__tar='${AMTAR} chof - "$$tardir"'; am__untar='${AMTAR} xf -' ac_config_headers="$ac_config_headers config.h" ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu if test -n "$ac_tool_prefix"; then for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_F77+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$F77"; then ac_cv_prog_F77="$F77" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_F77="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi F77=$ac_cv_prog_F77 if test -n "$F77"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $F77" >&5 $as_echo "$F77" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$F77" && break done fi if test -z "$F77"; then ac_ct_F77=$F77 for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_F77+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_F77"; then ac_cv_prog_ac_ct_F77="$ac_ct_F77" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_F77="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_F77=$ac_cv_prog_ac_ct_F77 if test -n "$ac_ct_F77"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_F77" >&5 $as_echo "$ac_ct_F77" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_F77" && break done if test "x$ac_ct_F77" = x; then F77="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac F77=$ac_ct_F77 fi fi # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done rm -f a.out cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the Fortran 77 compiler works" >&5 $as_echo_n "checking whether the Fortran 77 compiler works... " >&6; } ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else ac_file='' fi if test -z "$ac_file"; then : { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "Fortran 77 compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 compiler default output file name" >&5 $as_echo_n "checking for Fortran 77 compiler default output file name... " >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 $as_echo "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 $as_echo_n "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 $as_echo "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat > conftest.$ac_ext <<_ACEOF program main open(unit=9,file='conftest.out') close(unit=9) end _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 $as_echo_n "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot run Fortran 77 compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 $as_echo "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 $as_echo_n "checking for suffix of object files... " >&6; } if ${ac_cv_objext+:} false; then : $as_echo_n "(cached) " >&6 else cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_echo "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 $as_echo "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT # If we don't use `.F' as extension, the preprocessor is not run on the # input file. (Note that this only needs to work for GNU compilers.) ac_save_ext=$ac_ext ac_ext=F { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran 77 compiler" >&5 $as_echo_n "checking whether we are using the GNU Fortran 77 compiler... " >&6; } if ${ac_cv_f77_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat > conftest.$ac_ext <<_ACEOF program main #ifndef __GNUC__ choke me #endif end _ACEOF if ac_fn_f77_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_f77_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_compiler_gnu" >&5 $as_echo "$ac_cv_f77_compiler_gnu" >&6; } ac_ext=$ac_save_ext ac_test_FFLAGS=${FFLAGS+set} ac_save_FFLAGS=$FFLAGS FFLAGS= { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $F77 accepts -g" >&5 $as_echo_n "checking whether $F77 accepts -g... " >&6; } if ${ac_cv_prog_f77_g+:} false; then : $as_echo_n "(cached) " >&6 else FFLAGS=-g cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF if ac_fn_f77_try_compile "$LINENO"; then : ac_cv_prog_f77_g=yes else ac_cv_prog_f77_g=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_f77_g" >&5 $as_echo "$ac_cv_prog_f77_g" >&6; } if test "$ac_test_FFLAGS" = set; then FFLAGS=$ac_save_FFLAGS elif test $ac_cv_prog_f77_g = yes; then if test "x$ac_cv_f77_compiler_gnu" = xyes; then FFLAGS="-g -O2" else FFLAGS="-g" fi else if test "x$ac_cv_f77_compiler_gnu" = xyes; then FFLAGS="-O2" else FFLAGS= fi fi if test $ac_compiler_gnu = yes; then G77=yes else G77= fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to get verbose linking output from $F77" >&5 $as_echo_n "checking how to get verbose linking output from $F77... " >&6; } if ${ac_cv_prog_f77_v+:} false; then : $as_echo_n "(cached) " >&6 else cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF if ac_fn_f77_try_compile "$LINENO"; then : ac_cv_prog_f77_v= # Try some options frequently used verbose output for ac_verb in -v -verbose --verbose -V -\#\#\#; do cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF # Compile and link our simple test program by passing a flag (argument # 1 to this macro) to the Fortran compiler in order to get # "verbose" output that we can then parse for the Fortran linker # flags. ac_save_FFLAGS=$FFLAGS FFLAGS="$FFLAGS $ac_verb" eval "set x $ac_link" shift $as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5 # gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, # LIBRARY_PATH; skip all such settings. ac_f77_v_output=`eval $ac_link 5>&1 2>&1 | sed '/^Driving:/d; /^Configured with:/d; '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` $as_echo "$ac_f77_v_output" >&5 FFLAGS=$ac_save_FFLAGS rm -rf conftest* # On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where # /foo, /bar, and /baz are search directories for the Fortran linker. # Here, we change these into -L/foo -L/bar -L/baz (and put it first): ac_f77_v_output="`echo $ac_f77_v_output | grep 'LPATH is:' | sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_f77_v_output" # FIXME: we keep getting bitten by quoted arguments; a more general fix # that detects unbalanced quotes in FLIBS should be implemented # and (ugh) tested at some point. case $ac_f77_v_output in # If we are using xlf then replace all the commas with spaces. *xlfentry*) ac_f77_v_output=`echo $ac_f77_v_output | sed 's/,/ /g'` ;; # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted # $LIBS confuse us, and the libraries appear later in the output anyway). *mGLOB_options_string*) ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; # Portland Group compiler has singly- or doubly-quoted -cmdline argument # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". *-cmdline\ * | *-ignore\ * | *-def\ *) ac_f77_v_output=`echo $ac_f77_v_output | sed "\ s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; # If we are using Cray Fortran then delete quotes. *cft90*) ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"//g'` ;; esac # look for -l* and *.a constructs in the output for ac_arg in $ac_f77_v_output; do case $ac_arg in [\\/]*.a | ?:[\\/]*.a | -[lLRu]*) ac_cv_prog_f77_v=$ac_verb break 2 ;; esac done done if test -z "$ac_cv_prog_f77_v"; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot determine how to obtain linking information from $F77" >&5 $as_echo "$as_me: WARNING: cannot determine how to obtain linking information from $F77" >&2;} fi else { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: compilation failed" >&5 $as_echo "$as_me: WARNING: compilation failed" >&2;} fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_f77_v" >&5 $as_echo "$ac_cv_prog_f77_v" >&6; } { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 libraries of $F77" >&5 $as_echo_n "checking for Fortran 77 libraries of $F77... " >&6; } if ${ac_cv_f77_libs+:} false; then : $as_echo_n "(cached) " >&6 else if test "x$FLIBS" != "x"; then ac_cv_f77_libs="$FLIBS" # Let the user override the test. else cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF # Compile and link our simple test program by passing a flag (argument # 1 to this macro) to the Fortran compiler in order to get # "verbose" output that we can then parse for the Fortran linker # flags. ac_save_FFLAGS=$FFLAGS FFLAGS="$FFLAGS $ac_cv_prog_f77_v" eval "set x $ac_link" shift $as_echo "$as_me:${as_lineno-$LINENO}: $*" >&5 # gfortran 4.3 outputs lines setting COLLECT_GCC_OPTIONS, COMPILER_PATH, # LIBRARY_PATH; skip all such settings. ac_f77_v_output=`eval $ac_link 5>&1 2>&1 | sed '/^Driving:/d; /^Configured with:/d; '"/^[_$as_cr_Letters][_$as_cr_alnum]*=/d"` $as_echo "$ac_f77_v_output" >&5 FFLAGS=$ac_save_FFLAGS rm -rf conftest* # On HP/UX there is a line like: "LPATH is: /foo:/bar:/baz" where # /foo, /bar, and /baz are search directories for the Fortran linker. # Here, we change these into -L/foo -L/bar -L/baz (and put it first): ac_f77_v_output="`echo $ac_f77_v_output | grep 'LPATH is:' | sed 's|.*LPATH is\(: *[^ ]*\).*|\1|;s|: */| -L/|g'` $ac_f77_v_output" # FIXME: we keep getting bitten by quoted arguments; a more general fix # that detects unbalanced quotes in FLIBS should be implemented # and (ugh) tested at some point. case $ac_f77_v_output in # If we are using xlf then replace all the commas with spaces. *xlfentry*) ac_f77_v_output=`echo $ac_f77_v_output | sed 's/,/ /g'` ;; # With Intel ifc, ignore the quoted -mGLOB_options_string stuff (quoted # $LIBS confuse us, and the libraries appear later in the output anyway). *mGLOB_options_string*) ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"-mGLOB[^"]*"/ /g'` ;; # Portland Group compiler has singly- or doubly-quoted -cmdline argument # Singly-quoted arguments were reported for versions 5.2-4 and 6.0-4. # Doubly-quoted arguments were reported for "PGF90/x86 Linux/x86 5.0-2". *-cmdline\ * | *-ignore\ * | *-def\ *) ac_f77_v_output=`echo $ac_f77_v_output | sed "\ s/-cmdline *'[^']*'/ /g; s/-cmdline *\"[^\"]*\"/ /g s/-ignore *'[^']*'/ /g; s/-ignore *\"[^\"]*\"/ /g s/-def *'[^']*'/ /g; s/-def *\"[^\"]*\"/ /g"` ;; # If we are using Cray Fortran then delete quotes. *cft90*) ac_f77_v_output=`echo $ac_f77_v_output | sed 's/"//g'` ;; esac ac_cv_f77_libs= # Save positional arguments (if any) ac_save_positional="$@" set X $ac_f77_v_output while test $# != 1; do shift ac_arg=$1 case $ac_arg in [\\/]*.a | ?:[\\/]*.a) ac_exists=false for ac_i in $ac_cv_f77_libs; do if test x"$ac_arg" = x"$ac_i"; then ac_exists=true break fi done if test x"$ac_exists" = xtrue; then : else ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" fi ;; -bI:*) ac_exists=false for ac_i in $ac_cv_f77_libs; do if test x"$ac_arg" = x"$ac_i"; then ac_exists=true break fi done if test x"$ac_exists" = xtrue; then : else if test "$ac_compiler_gnu" = yes; then for ac_link_opt in $ac_arg; do ac_cv_f77_libs="$ac_cv_f77_libs -Xlinker $ac_link_opt" done else ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" fi fi ;; # Ignore these flags. -lang* | -lcrt*.o | -lc | -lgcc* | -lSystem | -libmil | -little \ |-LANG:=* | -LIST:* | -LNO:* | -link) ;; -lkernel32) test x"$CYGWIN" != xyes && ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" ;; -[LRuYz]) # These flags, when seen by themselves, take an argument. # We remove the space between option and argument and re-iterate # unless we find an empty arg or a new option (starting with -) case $2 in "" | -*);; *) ac_arg="$ac_arg$2" shift; shift set X $ac_arg "$@" ;; esac ;; -YP,*) for ac_j in `$as_echo "$ac_arg" | sed -e 's/-YP,/-L/;s/:/ -L/g'`; do ac_exists=false for ac_i in $ac_cv_f77_libs; do if test x"$ac_j" = x"$ac_i"; then ac_exists=true break fi done if test x"$ac_exists" = xtrue; then : else ac_arg="$ac_arg $ac_j" ac_cv_f77_libs="$ac_cv_f77_libs $ac_j" fi done ;; -[lLR]*) ac_exists=false for ac_i in $ac_cv_f77_libs; do if test x"$ac_arg" = x"$ac_i"; then ac_exists=true break fi done if test x"$ac_exists" = xtrue; then : else ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" fi ;; -zallextract*| -zdefaultextract) ac_cv_f77_libs="$ac_cv_f77_libs $ac_arg" ;; # Ignore everything else. esac done # restore positional arguments set X $ac_save_positional; shift # We only consider "LD_RUN_PATH" on Solaris systems. If this is seen, # then we insist that the "run path" must be an absolute path (i.e. it # must begin with a "/"). case `(uname -sr) 2>/dev/null` in "SunOS 5"*) ac_ld_run_path=`$as_echo "$ac_f77_v_output" | sed -n 's,^.*LD_RUN_PATH *= *\(/[^ ]*\).*$,-R\1,p'` test "x$ac_ld_run_path" != x && if test "$ac_compiler_gnu" = yes; then for ac_link_opt in $ac_ld_run_path; do ac_cv_f77_libs="$ac_cv_f77_libs -Xlinker $ac_link_opt" done else ac_cv_f77_libs="$ac_cv_f77_libs $ac_ld_run_path" fi ;; esac fi # test "x$[]_AC_LANG_PREFIX[]LIBS" = "x" fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_libs" >&5 $as_echo "$ac_cv_f77_libs" >&6; } FLIBS="$ac_cv_f77_libs" ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Checks for programs. ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="${ac_tool_prefix}gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="gcc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="${ac_tool_prefix}cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 $as_echo "$CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_CC+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_CC="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 $as_echo "$ac_ct_CC" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } if ${ac_cv_c_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 $as_echo "$ac_cv_c_compiler_gnu" >&6; } if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+set} ac_save_CFLAGS=$CFLAGS { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 $as_echo_n "checking whether $CC accepts -g... " >&6; } if ${ac_cv_prog_cc_g+:} false; then : $as_echo_n "(cached) " >&6 else ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes else CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : else ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 $as_echo "$ac_cv_prog_cc_g" >&6; } if test "$ac_test_CFLAGS" = set; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } if ${ac_cv_prog_cc_c89+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include /* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ struct buf { int x; }; FILE * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not '\xHH' hex character constants. These don't provoke an error unfortunately, instead are silently treated as 'x'. The following induces an error, until -std is added to get proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an array size at least. It's necessary to write '\x00'==0 to get something that's true only with -std. */ int osf4_cc_array ['\x00' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) 'x' int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); int argc; char **argv; int main () { return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; ; return 0; } _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO"; then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi # AC_CACHE_VAL case "x$ac_cv_prog_cc_c89" in x) { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 $as_echo "none needed" >&6; } ;; xno) { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 $as_echo "unsupported" >&6; } ;; *) CC="$CC $ac_cv_prog_cc_c89" { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 $as_echo "$ac_cv_prog_cc_c89" >&6; } ;; esac if test "x$ac_cv_prog_cc_c89" != xno; then : fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu DEPDIR="${am__leading_dot}deps" ac_config_commands="$ac_config_commands depfiles" am_make=${MAKE-make} cat > confinc << 'END' am__doit: @echo this is the am__doit target .PHONY: am__doit END # If we don't find an include directive, just comment out the code. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for style of include used by $am_make" >&5 $as_echo_n "checking for style of include used by $am_make... " >&6; } am__include="#" am__quote= _am_result=none # First try GNU make style include. echo "include confinc" > confmf # Ignore all kinds of additional output from `make'. case `$am_make -s -f confmf 2> /dev/null` in #( *the\ am__doit\ target*) am__include=include am__quote= _am_result=GNU ;; esac # Now try BSD make style include. if test "$am__include" = "#"; then echo '.include "confinc"' > confmf case `$am_make -s -f confmf 2> /dev/null` in #( *the\ am__doit\ target*) am__include=.include am__quote="\"" _am_result=BSD ;; esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $_am_result" >&5 $as_echo "$_am_result" >&6; } rm -f confinc confmf # Check whether --enable-dependency-tracking was given. if test "${enable_dependency_tracking+set}" = set; then : enableval=$enable_dependency_tracking; fi if test "x$enable_dependency_tracking" != xno; then am_depcomp="$ac_aux_dir/depcomp" AMDEPBACKSLASH='\' fi if test "x$enable_dependency_tracking" != xno; then AMDEP_TRUE= AMDEP_FALSE='#' else AMDEP_TRUE='#' AMDEP_FALSE= fi depcc="$CC" am_compiler_list= { $as_echo "$as_me:${as_lineno-$LINENO}: checking dependency style of $depcc" >&5 $as_echo_n "checking dependency style of $depcc... " >&6; } if ${am_cv_CC_dependencies_compiler_type+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$AMDEP_TRUE" && test -f "$am_depcomp"; then # We make a subdir and do the tests there. Otherwise we can end up # making bogus files that we don't know about and never remove. For # instance it was reported that on HP-UX the gcc test will end up # making a dummy file named `D' -- because `-MD' means `put the output # in D'. mkdir conftest.dir # Copy depcomp to subdir because otherwise we won't find it if we're # using a relative directory. cp "$am_depcomp" conftest.dir cd conftest.dir # We will build objects and dependencies in a subdirectory because # it helps to detect inapplicable dependency modes. For instance # both Tru64's cc and ICC support -MD to output dependencies as a # side effect of compilation, but ICC will put the dependencies in # the current directory while Tru64 will put them in the object # directory. mkdir sub am_cv_CC_dependencies_compiler_type=none if test "$am_compiler_list" = ""; then am_compiler_list=`sed -n 's/^#*\([a-zA-Z0-9]*\))$/\1/p' < ./depcomp` fi am__universal=false case " $depcc " in #( *\ -arch\ *\ -arch\ *) am__universal=true ;; esac for depmode in $am_compiler_list; do # Setup a source with many dependencies, because some compilers # like to wrap large dependency lists on column 80 (with \), and # we should not choose a depcomp mode which is confused by this. # # We need to recreate these files for each test, as the compiler may # overwrite some of them when testing with obscure command lines. # This happens at least with the AIX C compiler. : > sub/conftest.c for i in 1 2 3 4 5 6; do echo '#include "conftst'$i'.h"' >> sub/conftest.c # Using `: > sub/conftst$i.h' creates only sub/conftst1.h with # Solaris 8's {/usr,}/bin/sh. touch sub/conftst$i.h done echo "${am__include} ${am__quote}sub/conftest.Po${am__quote}" > confmf # We check with `-c' and `-o' for the sake of the "dashmstdout" # mode. It turns out that the SunPro C++ compiler does not properly # handle `-M -o', and we need to detect this. Also, some Intel # versions had trouble with output in subdirs am__obj=sub/conftest.${OBJEXT-o} am__minus_obj="-o $am__obj" case $depmode in gcc) # This depmode causes a compiler race in universal mode. test "$am__universal" = false || continue ;; nosideeffect) # after this tag, mechanisms are not by side-effect, so they'll # only be used when explicitly requested if test "x$enable_dependency_tracking" = xyes; then continue else break fi ;; msvisualcpp | msvcmsys) # This compiler won't grok `-c -o', but also, the minuso test has # not run yet. These depmodes are late enough in the game, and # so weak that their functioning should not be impacted. am__obj=conftest.${OBJEXT-o} am__minus_obj= ;; none) break ;; esac if depmode=$depmode \ source=sub/conftest.c object=$am__obj \ depfile=sub/conftest.Po tmpdepfile=sub/conftest.TPo \ $SHELL ./depcomp $depcc -c $am__minus_obj sub/conftest.c \ >/dev/null 2>conftest.err && grep sub/conftst1.h sub/conftest.Po > /dev/null 2>&1 && grep sub/conftst6.h sub/conftest.Po > /dev/null 2>&1 && grep $am__obj sub/conftest.Po > /dev/null 2>&1 && ${MAKE-make} -s -f confmf > /dev/null 2>&1; then # icc doesn't choke on unknown options, it will just issue warnings # or remarks (even with -Werror). So we grep stderr for any message # that says an option was ignored or not supported. # When given -MP, icc 7.0 and 7.1 complain thusly: # icc: Command line warning: ignoring option '-M'; no argument required # The diagnosis changed in icc 8.0: # icc: Command line remark: option '-MP' not supported if (grep 'ignoring option' conftest.err || grep 'not supported' conftest.err) >/dev/null 2>&1; then :; else am_cv_CC_dependencies_compiler_type=$depmode break fi fi done cd .. rm -rf conftest.dir else am_cv_CC_dependencies_compiler_type=none fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $am_cv_CC_dependencies_compiler_type" >&5 $as_echo "$am_cv_CC_dependencies_compiler_type" >&6; } CCDEPMODE=depmode=$am_cv_CC_dependencies_compiler_type if test "x$enable_dependency_tracking" != xno \ && test "$am_cv_CC_dependencies_compiler_type" = gcc3; then am__fastdepCC_TRUE= am__fastdepCC_FALSE='#' else am__fastdepCC_TRUE='#' am__fastdepCC_FALSE= fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 $as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } set x ${MAKE-make} ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : $as_echo_n "(cached) " >&6 else cat >conftest.make <<\_ACEOF SHELL = /bin/sh all: @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF # GNU make sometimes prints "make[1]: Entering ...", which would confuse us. case `${MAKE-make} -f conftest.make 2>/dev/null` in *@@@%%%=?*=@@@%%%*) eval ac_cv_prog_make_${ac_make}_set=yes;; *) eval ac_cv_prog_make_${ac_make}_set=no;; esac rm -f conftest.make fi if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } SET_MAKE= else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } SET_MAKE="MAKE=${MAKE-make}" fi if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. set dummy ${ac_tool_prefix}ranlib; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_RANLIB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 $as_echo "$RANLIB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi fi if test -z "$ac_cv_prog_RANLIB"; then ac_ct_RANLIB=$RANLIB # Extract the first word of "ranlib", so it can be a program name with args. set dummy ranlib; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_RANLIB="ranlib" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 $as_echo "$ac_ct_RANLIB" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi if test "x$ac_ct_RANLIB" = x; then RANLIB=":" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac RANLIB=$ac_ct_RANLIB fi else RANLIB="$ac_cv_prog_RANLIB" fi ac_ext=f ac_compile='$F77 -c $FFLAGS conftest.$ac_ext >&5' ac_link='$F77 -o conftest$ac_exeext $FFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_f77_compiler_gnu if test -n "$ac_tool_prefix"; then for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_F77+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$F77"; then ac_cv_prog_F77="$F77" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_F77="$ac_tool_prefix$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi F77=$ac_cv_prog_F77 if test -n "$F77"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $F77" >&5 $as_echo "$F77" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$F77" && break done fi if test -z "$F77"; then ac_ct_F77=$F77 for ac_prog in g77 xlf f77 frt pgf77 cf77 fort77 fl32 af77 xlf90 f90 pgf90 pghpf epcf90 gfortran g95 xlf95 f95 fort ifort ifc efc pgfortran pgf95 lf95 ftn do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 $as_echo_n "checking for $ac_word... " >&6; } if ${ac_cv_prog_ac_ct_F77+:} false; then : $as_echo_n "(cached) " >&6 else if test -n "$ac_ct_F77"; then ac_cv_prog_ac_ct_F77="$ac_ct_F77" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_exec_ext in '' $ac_executable_extensions; do if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then ac_cv_prog_ac_ct_F77="$ac_prog" $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_F77=$ac_cv_prog_ac_ct_F77 if test -n "$ac_ct_F77"; then { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_F77" >&5 $as_echo "$ac_ct_F77" >&6; } else { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 $as_echo "no" >&6; } fi test -n "$ac_ct_F77" && break done if test "x$ac_ct_F77" = x; then F77="" else case $cross_compiling:$ac_tool_warned in yes:) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 $as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac F77=$ac_ct_F77 fi fi # Provide some information about the compiler. $as_echo "$as_me:${as_lineno-$LINENO}: checking for Fortran 77 compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" $as_echo "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done rm -f a.out # If we don't use `.F' as extension, the preprocessor is not run on the # input file. (Note that this only needs to work for GNU compilers.) ac_save_ext=$ac_ext ac_ext=F { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU Fortran 77 compiler" >&5 $as_echo_n "checking whether we are using the GNU Fortran 77 compiler... " >&6; } if ${ac_cv_f77_compiler_gnu+:} false; then : $as_echo_n "(cached) " >&6 else cat > conftest.$ac_ext <<_ACEOF program main #ifndef __GNUC__ choke me #endif end _ACEOF if ac_fn_f77_try_compile "$LINENO"; then : ac_compiler_gnu=yes else ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext ac_cv_f77_compiler_gnu=$ac_compiler_gnu fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_f77_compiler_gnu" >&5 $as_echo "$ac_cv_f77_compiler_gnu" >&6; } ac_ext=$ac_save_ext ac_test_FFLAGS=${FFLAGS+set} ac_save_FFLAGS=$FFLAGS FFLAGS= { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $F77 accepts -g" >&5 $as_echo_n "checking whether $F77 accepts -g... " >&6; } if ${ac_cv_prog_f77_g+:} false; then : $as_echo_n "(cached) " >&6 else FFLAGS=-g cat > conftest.$ac_ext <<_ACEOF program main end _ACEOF if ac_fn_f77_try_compile "$LINENO"; then : ac_cv_prog_f77_g=yes else ac_cv_prog_f77_g=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_f77_g" >&5 $as_echo "$ac_cv_prog_f77_g" >&6; } if test "$ac_test_FFLAGS" = set; then FFLAGS=$ac_save_FFLAGS elif test $ac_cv_prog_f77_g = yes; then if test "x$ac_cv_f77_compiler_gnu" = xyes; then FFLAGS="-g -O2" else FFLAGS="-g" fi else if test "x$ac_cv_f77_compiler_gnu" = xyes; then FFLAGS="-O2" else FFLAGS= fi fi if test $ac_compiler_gnu = yes; then G77=yes else G77= fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu # Checks for libraries. # FIXME: Replace `main' with a function in `-ledfpack': #AC_CHECK_LIB([edfpack], [main]) # FIXME: Replace `main' with a function in `-lfitpack': #AC_CHECK_LIB([fitpack], [main]) # Checks for header files. ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 $as_echo_n "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if ${ac_cv_prog_CPP+:} false; then : $as_echo_n "(cached) " >&6 else # Double quotes because CPP needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 $as_echo "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # Prefer to if __STDC__ is defined, since # exists even on freestanding compilers. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #ifdef __STDC__ # include #else # include #endif Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : else # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO"; then : # Broken: success on invalid input. continue else # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok; then : else { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 $as_echo_n "checking for grep that handles long lines and -e... " >&6; } if ${ac_cv_path_GREP+:} false; then : $as_echo_n "(cached) " >&6 else if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in grep ggrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_GREP" && $as_test_x "$ac_path_GREP"; } || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'GREP' >> "conftest.nl" "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_GREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_GREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_GREP"; then as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_GREP=$GREP fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 $as_echo "$ac_cv_path_GREP" >&6; } GREP="$ac_cv_path_GREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 $as_echo_n "checking for egrep... " >&6; } if ${ac_cv_path_EGREP+:} false; then : $as_echo_n "(cached) " >&6 else if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then ac_path_EGREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. for ac_prog in egrep; do for ac_exec_ext in '' $ac_executable_extensions; do ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" { test -f "$ac_path_EGREP" && $as_test_x "$ac_path_EGREP"; } || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; *) ac_count=0 $as_echo_n 0123456789 >"conftest.in" while : do cat "conftest.in" "conftest.in" >"conftest.tmp" mv "conftest.tmp" "conftest.in" cp "conftest.in" "conftest.nl" $as_echo 'EGREP' >> "conftest.nl" "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break as_fn_arith $ac_count + 1 && ac_count=$as_val if test $ac_count -gt ${ac_path_EGREP_max-0}; then # Best one so far, save it but keep looking for a better one ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_max=$ac_count fi # 10*(2^10) chars as input seems more than enough test $ac_count -gt 10 && break done rm -f conftest.in conftest.tmp conftest.nl conftest.out;; esac $ac_path_EGREP_found && break 3 done done done IFS=$as_save_IFS if test -z "$ac_cv_path_EGREP"; then as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 fi else ac_cv_path_EGREP=$EGREP fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 $as_echo "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 $as_echo_n "checking for ANSI C header files... " >&6; } if ${ac_cv_header_stdc+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #include #include int main () { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdc=yes else ac_cv_header_stdc=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext if test $ac_cv_header_stdc = yes; then # SunOS 4.x string.h does not declare mem*, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "memchr" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "free" >/dev/null 2>&1; then : else ac_cv_header_stdc=no fi rm -f conftest* fi if test $ac_cv_header_stdc = yes; then # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. if test "$cross_compiling" = yes; then : : else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) #else # define ISLOWER(c) \ (('a' <= (c) && (c) <= 'i') \ || ('j' <= (c) && (c) <= 'r') \ || ('s' <= (c) && (c) <= 'z')) # define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) #endif #define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) int main () { int i; for (i = 0; i < 256; i++) if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) return 2; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : else ac_cv_header_stdc=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 $as_echo "$ac_cv_header_stdc" >&6; } if test $ac_cv_header_stdc = yes; then $as_echo "#define STDC_HEADERS 1" >>confdefs.h fi # On IRIX 5.3, sys/types and inttypes.h are conflicting. for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ inttypes.h stdint.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default " if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done for ac_header in fcntl.h float.h limits.h stdlib.h string.h sys/param.h sys/time.h unistd.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 _ACEOF fi done # --------------------------------------------------------------------------- # Check for ZLIB. # --------------------------------------------------------------------------- # Check whether --with-zlib-include-dir was given. if test "${with_zlib_include_dir+set}" = set; then : withval=$with_zlib_include_dir; fi # Check whether --with-zlib-lib-dir was given. if test "${with_zlib_lib_dir+set}" = set; then : withval=$with_zlib_lib_dir; fi if test "x$with_zlib_lib_dir" != "x" ; then LDFLAGS="-L$with_zlib_lib_dir $LDFLAGS" fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for inflateEnd in -lz" >&5 $as_echo_n "checking for inflateEnd in -lz... " >&6; } if ${ac_cv_lib_z_inflateEnd+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lz $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char inflateEnd (); int main () { return inflateEnd (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_z_inflateEnd=yes else ac_cv_lib_z_inflateEnd=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_z_inflateEnd" >&5 $as_echo "$ac_cv_lib_z_inflateEnd" >&6; } if test "x$ac_cv_lib_z_inflateEnd" = xyes; then : zlib_lib=yes else zlib_lib=no fi if test "$zlib_lib" = "no" -a "x$with_zlib_lib_dir" != "x"; then as_fn_error $? "Zlib library not found at $with_zlib_lib_dir" "$LINENO" 5 fi if test "x$with_zlib_include_dir" != "x" ; then CPPFLAGS="-I$with_zlib_include_dir $CPPFLAGS" fi ac_fn_c_check_header_mongrel "$LINENO" "zlib.h" "ac_cv_header_zlib_h" "$ac_includes_default" if test "x$ac_cv_header_zlib_h" = xyes; then : zlib_h=yes else zlib_h=no fi if test "$zlib_h" = "no" -a "x$with_zlib_include_dir" != "x" ; then as_fn_error $? "Zlib headers not found at $with_zlib_include_dir" "$LINENO" 5 fi LIBS="-lz $LIBS" if test "$HAVE_RPATH" = "yes" -a "x$with_zlib_lib_dir" != "x" ; then LIBDIR="-R $with_zlib_lib_dir $LIBDIR" fi # Checks for typedefs, structures, and compiler characteristics. { $as_echo "$as_me:${as_lineno-$LINENO}: checking for C/C++ restrict keyword" >&5 $as_echo_n "checking for C/C++ restrict keyword... " >&6; } if ${ac_cv_c_restrict+:} false; then : $as_echo_n "(cached) " >&6 else ac_cv_c_restrict=no # The order here caters to the fact that C++ does not require restrict. for ac_kw in __restrict __restrict__ _Restrict restrict; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ typedef int * int_ptr; int foo (int_ptr $ac_kw ip) { return ip[0]; } int main () { int s[1]; int * $ac_kw t = s; t[0] = 0; return foo(t) ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_c_restrict=$ac_kw fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext test "$ac_cv_c_restrict" != no && break done fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_restrict" >&5 $as_echo "$ac_cv_c_restrict" >&6; } case $ac_cv_c_restrict in restrict) ;; no) $as_echo "#define restrict /**/" >>confdefs.h ;; *) cat >>confdefs.h <<_ACEOF #define restrict $ac_cv_c_restrict _ACEOF ;; esac ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" if test "x$ac_cv_type_size_t" = xyes; then : else cat >>confdefs.h <<_ACEOF #define size_t unsigned int _ACEOF fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for stdbool.h that conforms to C99" >&5 $as_echo_n "checking for stdbool.h that conforms to C99... " >&6; } if ${ac_cv_header_stdbool_h+:} false; then : $as_echo_n "(cached) " >&6 else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #ifndef bool "error: bool is not defined" #endif #ifndef false "error: false is not defined" #endif #if false "error: false is not 0" #endif #ifndef true "error: true is not defined" #endif #if true != 1 "error: true is not 1" #endif #ifndef __bool_true_false_are_defined "error: __bool_true_false_are_defined is not defined" #endif struct s { _Bool s: 1; _Bool t; } s; char a[true == 1 ? 1 : -1]; char b[false == 0 ? 1 : -1]; char c[__bool_true_false_are_defined == 1 ? 1 : -1]; char d[(bool) 0.5 == true ? 1 : -1]; /* See body of main program for 'e'. */ char f[(_Bool) 0.0 == false ? 1 : -1]; char g[true]; char h[sizeof (_Bool)]; char i[sizeof s.t]; enum { j = false, k = true, l = false * true, m = true * 256 }; /* The following fails for HP aC++/ANSI C B3910B A.05.55 [Dec 04 2003]. */ _Bool n[m]; char o[sizeof n == m * sizeof n[0] ? 1 : -1]; char p[-1 - (_Bool) 0 < 0 && -1 - (bool) 0 < 0 ? 1 : -1]; /* Catch a bug in an HP-UX C compiler. See http://gcc.gnu.org/ml/gcc-patches/2003-12/msg02303.html http://lists.gnu.org/archive/html/bug-coreutils/2005-11/msg00161.html */ _Bool q = true; _Bool *pq = &q; int main () { bool e = &s; *pq |= q; *pq |= ! q; /* Refer to every declared value, to avoid compiler optimizations. */ return (!a + !b + !c + !d + !e + !f + !g + !h + !i + !!j + !k + !!l + !m + !n + !o + !p + !q + !pq); ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO"; then : ac_cv_header_stdbool_h=yes else ac_cv_header_stdbool_h=no fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdbool_h" >&5 $as_echo "$ac_cv_header_stdbool_h" >&6; } ac_fn_c_check_type "$LINENO" "_Bool" "ac_cv_type__Bool" "$ac_includes_default" if test "x$ac_cv_type__Bool" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE__BOOL 1 _ACEOF fi if test $ac_cv_header_stdbool_h = yes; then $as_echo "#define HAVE_STDBOOL_H 1" >>confdefs.h fi # Checks for library functions. for ac_header in stdlib.h do : ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" if test "x$ac_cv_header_stdlib_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STDLIB_H 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU libc compatible malloc" >&5 $as_echo_n "checking for GNU libc compatible malloc... " >&6; } if ${ac_cv_func_malloc_0_nonnull+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_malloc_0_nonnull=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #if defined STDC_HEADERS || defined HAVE_STDLIB_H # include #else char *malloc (); #endif int main () { return ! malloc (0); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_malloc_0_nonnull=yes else ac_cv_func_malloc_0_nonnull=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_malloc_0_nonnull" >&5 $as_echo "$ac_cv_func_malloc_0_nonnull" >&6; } if test $ac_cv_func_malloc_0_nonnull = yes; then : $as_echo "#define HAVE_MALLOC 1" >>confdefs.h else $as_echo "#define HAVE_MALLOC 0" >>confdefs.h case " $LIBOBJS " in *" malloc.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS malloc.$ac_objext" ;; esac $as_echo "#define malloc rpl_malloc" >>confdefs.h fi for ac_header in stdlib.h do : ac_fn_c_check_header_mongrel "$LINENO" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" if test "x$ac_cv_header_stdlib_h" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_STDLIB_H 1 _ACEOF fi done { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GNU libc compatible realloc" >&5 $as_echo_n "checking for GNU libc compatible realloc... " >&6; } if ${ac_cv_func_realloc_0_nonnull+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_realloc_0_nonnull=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #if defined STDC_HEADERS || defined HAVE_STDLIB_H # include #else char *realloc (); #endif int main () { return ! realloc (0, 0); ; return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_realloc_0_nonnull=yes else ac_cv_func_realloc_0_nonnull=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_realloc_0_nonnull" >&5 $as_echo "$ac_cv_func_realloc_0_nonnull" >&6; } if test $ac_cv_func_realloc_0_nonnull = yes; then : $as_echo "#define HAVE_REALLOC 1" >>confdefs.h else $as_echo "#define HAVE_REALLOC 0" >>confdefs.h case " $LIBOBJS " in *" realloc.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS realloc.$ac_objext" ;; esac $as_echo "#define realloc rpl_realloc" >>confdefs.h fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working strtod" >&5 $as_echo_n "checking for working strtod... " >&6; } if ${ac_cv_func_strtod+:} false; then : $as_echo_n "(cached) " >&6 else if test "$cross_compiling" = yes; then : ac_cv_func_strtod=no else cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default #ifndef strtod double strtod (); #endif int main() { { /* Some versions of Linux strtod mis-parse strings with leading '+'. */ char *string = " +69"; char *term; double value; value = strtod (string, &term); if (value != 69 || term != (string + 4)) return 1; } { /* Under Solaris 2.4, strtod returns the wrong value for the terminating character under some conditions. */ char *string = "NaN"; char *term; strtod (string, &term); if (term != string && *(term - 1) == 0) return 1; } return 0; } _ACEOF if ac_fn_c_try_run "$LINENO"; then : ac_cv_func_strtod=yes else ac_cv_func_strtod=no fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ conftest.$ac_objext conftest.beam conftest.$ac_ext fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_func_strtod" >&5 $as_echo "$ac_cv_func_strtod" >&6; } if test $ac_cv_func_strtod = no; then case " $LIBOBJS " in *" strtod.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS strtod.$ac_objext" ;; esac ac_fn_c_check_func "$LINENO" "pow" "ac_cv_func_pow" if test "x$ac_cv_func_pow" = xyes; then : fi if test $ac_cv_func_pow = no; then { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pow in -lm" >&5 $as_echo_n "checking for pow in -lm... " >&6; } if ${ac_cv_lib_m_pow+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lm $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC builtin and then its argument prototype would still apply. */ #ifdef __cplusplus extern "C" #endif char pow (); int main () { return pow (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_m_pow=yes else ac_cv_lib_m_pow=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_pow" >&5 $as_echo "$ac_cv_lib_m_pow" >&6; } if test "x$ac_cv_lib_m_pow" = xyes; then : POW_LIB=-lm else { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find library containing definition of pow" >&5 $as_echo "$as_me: WARNING: cannot find library containing definition of pow" >&2;} fi fi fi for ac_func in floor gettimeofday memset pow sqrt strcasecmp strchr strdup strerror strncasecmp strrchr strspn strstr strtol do : as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes"; then : cat >>confdefs.h <<_ACEOF #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF fi done ac_config_files="$ac_config_files edfpack/Makefile fitpack/Makefile Makefile src/Makefile man/Makefile" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 $as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 $as_echo "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' DEFS=-DHAVE_CONFIG_H ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`$as_echo "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs if test -n "$EXEEXT"; then am__EXEEXT_TRUE= am__EXEEXT_FALSE='#' else am__EXEEXT_TRUE='#' am__EXEEXT_FALSE= fi if test -z "${AMDEP_TRUE}" && test -z "${AMDEP_FALSE}"; then as_fn_error $? "conditional \"AMDEP\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi if test -z "${am__fastdepCC_TRUE}" && test -z "${am__fastdepCC_FALSE}"; then as_fn_error $? "conditional \"am__fastdepCC\" was never defined. Usually this means the macro was only invoked conditionally." "$LINENO" 5 fi : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 $as_echo "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi as_nl=' ' export as_nl # Printing a long string crashes Solaris 7 /usr/bin/printf. as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo # Prefer a ksh shell builtin over an external printf program on Solaris, # but without wasting forks for bash or zsh. if test -z "$BASH_VERSION$ZSH_VERSION" \ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='print -r --' as_echo_n='print -rn --' elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then as_echo='printf %s\n' as_echo_n='printf %s' else if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' as_echo_n='/usr/ucb/echo -n' else as_echo_body='eval expr "X$1" : "X\\(.*\\)"' as_echo_n_body='eval arg=$1; case $arg in #( *"$as_nl"*) expr "X$arg" : "X\\(.*\\)$as_nl"; arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; esac; expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" ' export as_echo_n_body as_echo_n='sh -c $as_echo_n_body as_echo' fi export as_echo_body as_echo='sh -c $as_echo_body as_echo' fi # The user is always right. if test "${PATH_SEPARATOR+set}" != set; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # IFS # We need space, tab and new line, in precisely that order. Quoting is # there to prevent editors from complaining about space-tab. # (If _AS_PATH_WALK were called with IFS unset, it would disable word # splitting by setting IFS to empty value.) IFS=" "" $as_nl" # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS test -z "$as_dir" && as_dir=. test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Unset variables that we do not need and which cause bugs (e.g. in # pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" # suppresses any "Segmentation fault" message there. '((' could # trigger a bug in pdksh 5.2.14. for as_var in BASH_ENV ENV MAIL MAILPATH do eval test x\${$as_var+set} = xset \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done PS1='$ ' PS2='> ' PS4='+ ' # NLS nuisances. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # CDPATH. (unset CDPATH) >/dev/null 2>&1 && unset CDPATH # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi $as_echo "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : eval 'as_fn_append () { eval $1+=\$2 }' else as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : eval 'as_fn_arith () { as_val=$(( $* )) }' else as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || $as_echo X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -p'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -p' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -p' fi else as_ln_s='cp -p' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi if test -x / >/dev/null 2>&1; then as_test_x='test -x' else if ls -dL / >/dev/null 2>&1; then as_ls_L_option=L else as_ls_L_option= fi as_test_x=' eval sh -c '\'' if test -d "$1"; then test -d "$1/."; else case $1 in #( -*)set "./$1";; esac; case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #(( ???[sx]*):;;*)false;;esac;fi '\'' sh ' fi as_executable_p=$as_test_x # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by spd $as_me 1.3.0, which was generated by GNU Autoconf 2.68. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac case $ac_config_headers in *" "*) set x $ac_config_headers; shift; ac_config_headers=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" config_headers="$ac_config_headers" config_commands="$ac_config_commands" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE --header=FILE[:TEMPLATE] instantiate the configuration header FILE Configuration files: $config_files Configuration headers: $config_headers Configuration commands: $config_commands Report bugs to ." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ spd config.status 1.3.0 configured by $0, generated by GNU Autoconf 2.68, with options \\"\$ac_cs_config\\" Copyright (C) 2010 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' INSTALL='$INSTALL' MKDIR_P='$MKDIR_P' AWK='$AWK' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) $as_echo "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) $as_echo "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --header | --heade | --head | --hea ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append CONFIG_HEADERS " '$ac_optarg'" ac_need_defaults=false;; --he | --h) # Conflict between --help and --header as_fn_error $? "ambiguous option: \`$1' Try \`$0 --help' for more information.";; --help | --hel | -h ) $as_echo "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX $as_echo "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # # INIT-COMMANDS # AMDEP_TRUE="$AMDEP_TRUE" ac_aux_dir="$ac_aux_dir" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "config.h") CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; "depfiles") CONFIG_COMMANDS="$CONFIG_COMMANDS depfiles" ;; "edfpack/Makefile") CONFIG_FILES="$CONFIG_FILES edfpack/Makefile" ;; "fitpack/Makefile") CONFIG_FILES="$CONFIG_FILES fitpack/Makefile" ;; "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; "src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;; "man/Makefile") CONFIG_FILES="$CONFIG_FILES man/Makefile" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers test "${CONFIG_COMMANDS+set}" = set || CONFIG_COMMANDS=$config_commands fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. # This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF # Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. # Create a delimiter string that does not exist in confdefs.h, to ease # handling of long lines. ac_delim='%!_!# ' for ac_last_try in false false :; do ac_tt=`sed -n "/$ac_delim/p" confdefs.h` if test -z "$ac_tt"; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done # For the awk script, D is an array of macro values keyed by name, # likewise P contains macro parameters if any. Preserve backslash # newline sequences. ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]* sed -n ' s/.\{148\}/&'"$ac_delim"'/g t rset :rset s/^[ ]*#[ ]*define[ ][ ]*/ / t def d :def s/\\$// t bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3"/p s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p d :bsnl s/["\\]/\\&/g s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\ D["\1"]=" \3\\\\\\n"\\/p t cont s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p t cont d :cont n s/.\{148\}/&'"$ac_delim"'/g t clear :clear s/\\$// t bsnlc s/["\\]/\\&/g; s/^/"/; s/$/"/p d :bsnlc s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p b cont ' >$CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 for (key in D) D_is_set[key] = 1 FS = "" } /^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ { line = \$ 0 split(line, arg, " ") if (arg[1] == "#") { defundef = arg[2] mac1 = arg[3] } else { defundef = substr(arg[1], 2) mac1 = arg[2] } split(mac1, mac2, "(") #) macro = mac2[1] prefix = substr(line, 1, index(line, defundef) - 1) if (D_is_set[macro]) { # Preserve the white space surrounding the "#". print prefix "define", macro P[macro] D[macro] next } else { # Replace #undef with comments. This is necessary, for example, # in the case of _POSIX_SOURCE, which is predefined and required # on some systems where configure will not decide to define it. if (defundef == "undef") { print "/*", prefix defundef, macro, "*/" next } } } { print } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 fi # test -n "$CONFIG_HEADERS" eval set X " :F $CONFIG_FILES :H $CONFIG_HEADERS :C $CONFIG_COMMANDS" shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 $as_echo "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`$as_echo "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # case $INSTALL in [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; *) ac_INSTALL=$ac_top_build_prefix$INSTALL ;; esac ac_MKDIR_P=$MKDIR_P case $MKDIR_P in [\\/$]* | ?:[\\/]* ) ;; */*) ac_MKDIR_P=$ac_top_build_prefix$MKDIR_P ;; esac _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 $as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t s&@INSTALL@&$ac_INSTALL&;t t s&@MKDIR_P@&$ac_MKDIR_P&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; :H) # # CONFIG_HEADER # if test x"$ac_file" != x-; then { $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" } >"$ac_tmp/config.h" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 $as_echo "$as_me: $ac_file is unchanged" >&6;} else rm -f "$ac_file" mv "$ac_tmp/config.h" "$ac_file" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 fi else $as_echo "/* $configure_input */" \ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ || as_fn_error $? "could not create -" "$LINENO" 5 fi # Compute "$ac_file"'s index in $config_headers. _am_arg="$ac_file" _am_stamp_count=1 for _am_header in $config_headers :; do case $_am_header in $_am_arg | $_am_arg:* ) break ;; * ) _am_stamp_count=`expr $_am_stamp_count + 1` ;; esac done echo "timestamp for $_am_arg" >`$as_dirname -- "$_am_arg" || $as_expr X"$_am_arg" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$_am_arg" : 'X\(//\)[^/]' \| \ X"$_am_arg" : 'X\(//\)$' \| \ X"$_am_arg" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$_am_arg" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'`/stamp-h$_am_stamp_count ;; :C) { $as_echo "$as_me:${as_lineno-$LINENO}: executing $ac_file commands" >&5 $as_echo "$as_me: executing $ac_file commands" >&6;} ;; esac case $ac_file$ac_mode in "depfiles":C) test x"$AMDEP_TRUE" != x"" || { # Autoconf 2.62 quotes --file arguments for eval, but not when files # are listed without --file. Let's play safe and only enable the eval # if we detect the quoting. case $CONFIG_FILES in *\'*) eval set x "$CONFIG_FILES" ;; *) set x $CONFIG_FILES ;; esac shift for mf do # Strip MF so we end up with the name of the file. mf=`echo "$mf" | sed -e 's/:.*$//'` # Check whether this is an Automake generated Makefile or not. # We used to match only the files named `Makefile.in', but # some people rename them; so instead we look at the file content. # Grep'ing the first line is not enough: some people post-process # each Makefile.in and add a new line on top of each file to say so. # Grep'ing the whole file is not good either: AIX grep has a line # limit of 2048, but all sed's we know have understand at least 4000. if sed -n 's,^#.*generated by automake.*,X,p' "$mf" | grep X >/dev/null 2>&1; then dirpart=`$as_dirname -- "$mf" || $as_expr X"$mf" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$mf" : 'X\(//\)[^/]' \| \ X"$mf" : 'X\(//\)$' \| \ X"$mf" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$mf" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` else continue fi # Extract the definition of DEPDIR, am__include, and am__quote # from the Makefile without running `make'. DEPDIR=`sed -n 's/^DEPDIR = //p' < "$mf"` test -z "$DEPDIR" && continue am__include=`sed -n 's/^am__include = //p' < "$mf"` test -z "am__include" && continue am__quote=`sed -n 's/^am__quote = //p' < "$mf"` # When using ansi2knr, U may be empty or an underscore; expand it U=`sed -n 's/^U = //p' < "$mf"` # Find all dependency output files, they are included files with # $(DEPDIR) in their names. We invoke sed twice because it is the # simplest approach to changing $(DEPDIR) to its actual value in the # expansion. for file in `sed -n " s/^$am__include $am__quote\(.*(DEPDIR).*\)$am__quote"'$/\1/p' <"$mf" | \ sed -e 's/\$(DEPDIR)/'"$DEPDIR"'/g' -e 's/\$U/'"$U"'/g'`; do # Make sure the directory exists. test -f "$dirpart/$file" && continue fdir=`$as_dirname -- "$file" || $as_expr X"$file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$file" : 'X\(//\)[^/]' \| \ X"$file" : 'X\(//\)$' \| \ X"$file" : 'X\(/\)' \| . 2>/dev/null || $as_echo X"$file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir=$dirpart/$fdir; as_fn_mkdir_p # echo "creating $dirpart/$file" echo '# dummy' > "$dirpart/$file" done done } ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lc" >&5 $as_echo_n "checking for main in -lc... " >&6; } if ${ac_cv_lib_c_main+:} false; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS LIBS="-lc $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () { return main (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : ac_cv_lib_c_main=yes else ac_cv_lib_c_main=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_c_main" >&5 $as_echo "$ac_cv_lib_c_main" >&6; } if test "x$ac_cv_lib_c_main" = xyes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBC 1 _ACEOF LIBS="-lc $LIBS" fi spd-1.3.0/AUTHORS0000644000175000017500000000015711643121541010273 00000000000000Original idea: Jorg Klora Main development: Peter Boesecke Maintenance: Rainer Wilcke & Jerome Kiefferspd-1.3.0/NEWS0000644000175000017500000000004411643121541007715 00000000000000October 2011: SPD moves to autotoolsspd-1.3.0/man/0000755000175000017500000000000011655563114010064 500000000000000spd-1.3.0/man/Makefile.in0000644000175000017500000002777511650556154012074 00000000000000# Makefile.in generated by automake 1.11.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, # 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, # Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : subdir = man DIST_COMMON = $(dist_man_MANS) $(srcdir)/Makefile.am \ $(srcdir)/Makefile.in ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = SOURCES = DIST_SOURCES = am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; am__vpath_adj = case $$p in \ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \ *) f=$$p;; \ esac; am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`; am__install_max = 40 am__nobase_strip_setup = \ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'` am__nobase_strip = \ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||" am__nobase_list = $(am__nobase_strip_setup); \ for p in $$list; do echo "$$p $$p"; done | \ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \ if (++n[$$2] == $(am__install_max)) \ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \ END { for (dir in files) print dir, files[dir] }' am__base_list = \ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g' man1dir = $(mandir)/man1 am__installdirs = "$(DESTDIR)$(man1dir)" NROFF = nroff MANS = $(dist_man_MANS) DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ F77 = @F77@ FFLAGS = @FFLAGS@ FLIBS = @FLIBS@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ OBJEXT = @OBJEXT@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ POW_LIB = @POW_LIB@ RANLIB = @RANLIB@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ ac_ct_F77 = @ac_ct_F77@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build_alias = @build_alias@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host_alias = @host_alias@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ dist_man_MANS = spd.1 all: all-am .SUFFIXES: $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu man/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu man/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): install-man1: $(dist_man_MANS) @$(NORMAL_INSTALL) test -z "$(man1dir)" || $(MKDIR_P) "$(DESTDIR)$(man1dir)" @list=''; test -n "$(man1dir)" || exit 0; \ { for i in $$list; do echo "$$i"; done; \ l2='$(dist_man_MANS)'; for i in $$l2; do echo "$$i"; done | \ sed -n '/\.1[a-z]*$$/p'; \ } | while read p; do \ if test -f $$p; then d=; else d="$(srcdir)/"; fi; \ echo "$$d$$p"; echo "$$p"; \ done | \ sed -e 'n;s,.*/,,;p;h;s,.*\.,,;s,^[^1][0-9a-z]*$$,1,;x' \ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,' | \ sed 'N;N;s,\n, ,g' | { \ list=; while read file base inst; do \ if test "$$base" = "$$inst"; then list="$$list $$file"; else \ echo " $(INSTALL_DATA) '$$file' '$(DESTDIR)$(man1dir)/$$inst'"; \ $(INSTALL_DATA) "$$file" "$(DESTDIR)$(man1dir)/$$inst" || exit $$?; \ fi; \ done; \ for i in $$list; do echo "$$i"; done | $(am__base_list) | \ while read files; do \ test -z "$$files" || { \ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(man1dir)'"; \ $(INSTALL_DATA) $$files "$(DESTDIR)$(man1dir)" || exit $$?; }; \ done; } uninstall-man1: @$(NORMAL_UNINSTALL) @list=''; test -n "$(man1dir)" || exit 0; \ files=`{ for i in $$list; do echo "$$i"; done; \ l2='$(dist_man_MANS)'; for i in $$l2; do echo "$$i"; done | \ sed -n '/\.1[a-z]*$$/p'; \ } | sed -e 's,.*/,,;h;s,.*\.,,;s,^[^1][0-9a-z]*$$,1,;x' \ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,'`; \ test -z "$$files" || { \ echo " ( cd '$(DESTDIR)$(man1dir)' && rm -f" $$files ")"; \ cd "$(DESTDIR)$(man1dir)" && rm -f $$files; } tags: TAGS TAGS: ctags: CTAGS CTAGS: distdir: $(DISTFILES) @list='$(MANS)'; if test -n "$$list"; then \ list=`for p in $$list; do \ if test -f $$p; then d=; else d="$(srcdir)/"; fi; \ if test -f "$$d$$p"; then echo "$$d$$p"; else :; fi; done`; \ if test -n "$$list" && \ grep 'ab help2man is required to generate this page' $$list >/dev/null; then \ echo "error: found man pages containing the \`missing help2man' replacement text:" >&2; \ grep -l 'ab help2man is required to generate this page' $$list | sed 's/^/ /' >&2; \ echo " to fix them, install help2man, remove and regenerate the man pages;" >&2; \ echo " typically \`make maintainer-clean' will remove them" >&2; \ exit 1; \ else :; fi; \ else :; fi @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(MANS) installdirs: for dir in "$(DESTDIR)$(man1dir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ `test -z '$(STRIP)' || \ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-generic mostlyclean-am distclean: distclean-am -rm -f Makefile distclean-am: clean-am distclean-generic dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-man install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-man1 install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-generic pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: uninstall-man uninstall-man: uninstall-man1 .MAKE: install-am install-strip .PHONY: all all-am check check-am clean clean-generic distclean \ distclean-generic distdir dvi dvi-am html html-am info info-am \ install install-am install-data install-data-am install-dvi \ install-dvi-am install-exec install-exec-am install-html \ install-html-am install-info install-info-am install-man \ install-man1 install-pdf install-pdf-am install-ps \ install-ps-am install-strip installcheck installcheck-am \ installdirs maintainer-clean maintainer-clean-generic \ mostlyclean mostlyclean-generic pdf pdf-am ps ps-am uninstall \ uninstall-am uninstall-man uninstall-man1 # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: spd-1.3.0/man/spd.10000644000175000017500000001520611655563060010660 00000000000000.\" $Id$ .\" .\" Man page for the SPD program. .\" .\" $Log$ .\" .TH spd 1 " Oct 5 2011" "SPD=1.3 SAXS=2.445 EDF=2.188" .SH NAME spd \- SPatial Distortion Program .SH SYNOPSIS .P Synchrotron image corrections and azimuthal integration .SH DESCRIPTION .P SPD stands for SPatial Distortion. Written in C language, this command\-line driven program deals with images coming from X\-ray diffusion/diffraction experiments. It does subsequently: * intensity corrections (dark current, flat field correction, ...), * geometry corrections using spline files or a pair of distortion arrays, * azimuthal integration in 2D or 1D after masking defective pixels. SPD was originally written by Jorg Klora for ESRF and was re\-written by Peter Boesecke from ESRF/ID02. Maintenance and packaging of the program are provided by Rainer Wilcke and Jerome Kieffer from SciSoft at ESRF. .SH OPTIONS .P Usage: spd [\-\-server] [\-\-exit] parameter=option [filenames] .P src_id= .P src_ext= (default none) .P cor_id= .P cor_ext= (default none) .P type= (default "FloatIEEE32") .P dvo= data value offset (default 0) .P dark_id= .P dark_file= .P dark_const= subtract constant dark image value default: no dark image subtraction done .P dark_ext= default none .P do_dark=0|1 if 0, suppress dark image correction default 1 .P save_dark=0|1|2 save dark image memory to file 0: never, 1: always, 2: only if new (default 2) .P inp_const= add input image constant (default 0.) .P inp_exp= apply exponent to input image (default 1.) .P inp_factor= multiply with input image factor (default 1.) .P raw_cmpr="none"|"gzip"|"z" compression of raw & dark images (default none) .P flood_id= (or flat field) .P flood_file= (default: no flood field used) .P bckg_id= .P bckg_file= (default: no scattering background used) .P bckg_const= (default 0.) .P bckg_fact= (default 1.) .P header_id= (default: not used) .P pass=0|1 pass input file header to output (default 0) .P header_min= (default 0) .P header_ext= (default none) .P distortion_file= (default "spatial.dat") .P xfile= (x distortion read from edf file) .P yfile= (y distortion read from edf file) .P xoutfile= (x distortion saved to edf file) .P youtfile= (y distortion saved to edf file) .P active_radius= (values outside will not be corrected) .P precen_1=xxx for pre\-rotation center_1 (default calculated) .P precen_2=xxx for pre\-rotation center_2 (default calculated) .P .P predis=xxx for pre\-rotation distance (default calculated) .P prerot_1= (default 0.) .P prerot_2= (default 0.) .P prerot_3= (default 0.) .P psize_distort=0|1|2 take image params from distortion file 0: none, 1: pix, 2: pix, cen, dis, proj, rot (default 0) .P cen_1=xxx if set, defines Center_1 header value .P cen_2=xxx if set, defines Center_2 header value .P i0=xxx if set, defines Intensity0 header value .P i1=xxx if set, defines Intensity1 header value .P off_1=xxx if set, defines Offset_1 header value .P off_2=xxx if set, defines Offset_2 header value .P pix_1=xxx if set, defines PSize_1 header value .P pix_2=xxx if set, defines PSize_2 header value .P bis_1=xxx if set, defines BSize_1 header value .P bis_2=xxx if set, defines BSize_2 header value .P dis=xxx if set, defines SampleDistance header value .P ori=xxx if set, defines RasterOrientation header value .P tit=xxx if set, defines Title header value .P wvl=xxx if set, defines WaveLength header value .P pro="Saxs"|"Waxs" projection type of image (default Saxs) .P rot_1= (default 0.) .P rot_2= (default 0.) .P rot_3= (default 0.) .P base_name= (default "image") .P outdir= directory for output files (default: base_name) .P verbose=\-1|0|1|2 message printing level (low \-> high, default 1) .P version=0|1 print version string of the program if != 0 .P simul=0|1 (default 0) .P do_distortion=0|1|2|3 distortion correction (default 1) (0: none, 1: after dark, 2: after flat, 3: after norm) .P flat_distortion=0|1 normalize to flat imgage (default 1) .P do_prerotation=0|1|2 pre\-rotation correction (default 1) (0: none, 1: after, 2: without distortion correction) .P norm_int=0|1 intensity normalization (default 0 = no) .P norm_factor= (default 1.) .P overflow=xxx (default 0 = not set) .P dummy= (default 0. = not set) .P inp_min= (default 0. = not set) .P inp_max= (default 0. = not set) .P bin_1= factor for x\-binning (default 1 = no binning) .P bin_2= factor for y\-binning (default 1 = no binning) .P azim_int=0|1 azimuthal regrouping (default 0 = no) .P azim_pass=0|1 pass full header to azimuthal regrouping (def. 1 = yes) .P azim_pro="Saxs"|"Waxs" project. type of azim. regrp. (default Saxs) .P azim_id= (default \-1) .P azim_ext= (default none) .P azim_r0= minimum regrouping radius (default 0.) .P azim_r_num= radial output size (default 0) .P azim_a0= 1st regrouping start angle (default 0.) .P azim_a1= 2nd regrouping start angle (default: not used) .P azim_da= angular regrouping interval (default 1.) .P azim_a_num= angular output size (default 0) .P ave_id= (default \-1) .P ave_ext= (default none) .P ave_scf= (default 1.) .P mask_file= (default: not used) .P clear=0|1 reset all command options (default 0) .P \-\-server switch to server mode, i.e. wait for new command/image to process on stdin .P \-\-exit quit the program when we are on server mode. .SH BUGS .P Azimuthal integration can only be achieved if a wavelength is given, even if it is not needed for any calculation. .P SPD was developed at ESRF and is tightly bound to Spec shared\-memory arrays (http://www.certif.com) and EDF (ESRF Data Format) images, both in input and output. spd-1.3.0/man/Makefile.am0000644000175000017500000000002511644024471012031 00000000000000dist_man_MANS = spd.1spd-1.3.0/missing0000755000175000017500000002623311643121541010625 00000000000000#! /bin/sh # Common stub for a few missing GNU programs while installing. scriptversion=2009-04-28.21; # UTC # Copyright (C) 1996, 1997, 1999, 2000, 2002, 2003, 2004, 2005, 2006, # 2008, 2009 Free Software Foundation, Inc. # Originally by Fran,cois Pinard , 1996. # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # You should have received a copy of the GNU General Public License # along with this program. If not, see . # As a special exception to the GNU General Public License, if you # distribute this file as part of a program that contains a # configuration script generated by Autoconf, you may include it under # the same distribution terms that you use for the rest of that program. if test $# -eq 0; then echo 1>&2 "Try \`$0 --help' for more information" exit 1 fi run=: sed_output='s/.* --output[ =]\([^ ]*\).*/\1/p' sed_minuso='s/.* -o \([^ ]*\).*/\1/p' # In the cases where this matters, `missing' is being run in the # srcdir already. if test -f configure.ac; then configure_ac=configure.ac else configure_ac=configure.in fi msg="missing on your system" case $1 in --run) # Try to run requested program, and just exit if it succeeds. run= shift "$@" && exit 0 # Exit code 63 means version mismatch. This often happens # when the user try to use an ancient version of a tool on # a file that requires a minimum version. In this case we # we should proceed has if the program had been absent, or # if --run hadn't been passed. if test $? = 63; then run=: msg="probably too old" fi ;; -h|--h|--he|--hel|--help) echo "\ $0 [OPTION]... PROGRAM [ARGUMENT]... Handle \`PROGRAM [ARGUMENT]...' for when PROGRAM is missing, or return an error status if there is no known handling for PROGRAM. Options: -h, --help display this help and exit -v, --version output version information and exit --run try to run the given command, and emulate it if it fails Supported PROGRAM values: aclocal touch file \`aclocal.m4' autoconf touch file \`configure' autoheader touch file \`config.h.in' autom4te touch the output file, or create a stub one automake touch all \`Makefile.in' files bison create \`y.tab.[ch]', if possible, from existing .[ch] flex create \`lex.yy.c', if possible, from existing .c help2man touch the output file lex create \`lex.yy.c', if possible, from existing .c makeinfo touch the output file tar try tar, gnutar, gtar, then tar without non-portable flags yacc create \`y.tab.[ch]', if possible, from existing .[ch] Version suffixes to PROGRAM as well as the prefixes \`gnu-', \`gnu', and \`g' are ignored when checking the name. Send bug reports to ." exit $? ;; -v|--v|--ve|--ver|--vers|--versi|--versio|--version) echo "missing $scriptversion (GNU Automake)" exit $? ;; -*) echo 1>&2 "$0: Unknown \`$1' option" echo 1>&2 "Try \`$0 --help' for more information" exit 1 ;; esac # normalize program name to check for. program=`echo "$1" | sed ' s/^gnu-//; t s/^gnu//; t s/^g//; t'` # Now exit if we have it, but it failed. Also exit now if we # don't have it and --version was passed (most likely to detect # the program). This is about non-GNU programs, so use $1 not # $program. case $1 in lex*|yacc*) # Not GNU programs, they don't have --version. ;; tar*) if test -n "$run"; then echo 1>&2 "ERROR: \`tar' requires --run" exit 1 elif test "x$2" = "x--version" || test "x$2" = "x--help"; then exit 1 fi ;; *) if test -z "$run" && ($1 --version) > /dev/null 2>&1; then # We have it, but it failed. exit 1 elif test "x$2" = "x--version" || test "x$2" = "x--help"; then # Could not run --version or --help. This is probably someone # running `$TOOL --version' or `$TOOL --help' to check whether # $TOOL exists and not knowing $TOOL uses missing. exit 1 fi ;; esac # If it does not exist, or fails to run (possibly an outdated version), # try to emulate it. case $program in aclocal*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." touch aclocal.m4 ;; autoconf*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." touch configure ;; autoheader*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`acconfig.h' or \`${configure_ac}'. You might want to install the \`Autoconf' and \`GNU m4' packages. Grab them from any GNU archive site." files=`sed -n 's/^[ ]*A[CM]_CONFIG_HEADER(\([^)]*\)).*/\1/p' ${configure_ac}` test -z "$files" && files="config.h" touch_files= for f in $files; do case $f in *:*) touch_files="$touch_files "`echo "$f" | sed -e 's/^[^:]*://' -e 's/:.*//'`;; *) touch_files="$touch_files $f.in";; esac done touch $touch_files ;; automake*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified \`Makefile.am', \`acinclude.m4' or \`${configure_ac}'. You might want to install the \`Automake' and \`Perl' packages. Grab them from any GNU archive site." find . -type f -name Makefile.am -print | sed 's/\.am$/.in/' | while read f; do touch "$f"; done ;; autom4te*) echo 1>&2 "\ WARNING: \`$1' is needed, but is $msg. You might have modified some files without having the proper tools for further handling them. You can get \`$1' as part of \`Autoconf' from any GNU archive site." file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -f "$file"; then touch $file else test -z "$file" || exec >$file echo "#! /bin/sh" echo "# Created by GNU Automake missing as a replacement of" echo "# $ $@" echo "exit 0" chmod +x $file exit 1 fi ;; bison*|yacc*) echo 1>&2 "\ WARNING: \`$1' $msg. You should only need it if you modified a \`.y' file. You may need the \`Bison' package in order for those modifications to take effect. You can get \`Bison' from any GNU archive site." rm -f y.tab.c y.tab.h if test $# -ne 1; then eval LASTARG="\${$#}" case $LASTARG in *.y) SRCFILE=`echo "$LASTARG" | sed 's/y$/c/'` if test -f "$SRCFILE"; then cp "$SRCFILE" y.tab.c fi SRCFILE=`echo "$LASTARG" | sed 's/y$/h/'` if test -f "$SRCFILE"; then cp "$SRCFILE" y.tab.h fi ;; esac fi if test ! -f y.tab.h; then echo >y.tab.h fi if test ! -f y.tab.c; then echo 'main() { return 0; }' >y.tab.c fi ;; lex*|flex*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a \`.l' file. You may need the \`Flex' package in order for those modifications to take effect. You can get \`Flex' from any GNU archive site." rm -f lex.yy.c if test $# -ne 1; then eval LASTARG="\${$#}" case $LASTARG in *.l) SRCFILE=`echo "$LASTARG" | sed 's/l$/c/'` if test -f "$SRCFILE"; then cp "$SRCFILE" lex.yy.c fi ;; esac fi if test ! -f lex.yy.c; then echo 'main() { return 0; }' >lex.yy.c fi ;; help2man*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a dependency of a manual page. You may need the \`Help2man' package in order for those modifications to take effect. You can get \`Help2man' from any GNU archive site." file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -f "$file"; then touch $file else test -z "$file" || exec >$file echo ".ab help2man is required to generate this page" exit $? fi ;; makeinfo*) echo 1>&2 "\ WARNING: \`$1' is $msg. You should only need it if you modified a \`.texi' or \`.texinfo' file, or any other file indirectly affecting the aspect of the manual. The spurious call might also be the consequence of using a buggy \`make' (AIX, DU, IRIX). You might want to install the \`Texinfo' package or the \`GNU make' package. Grab either from any GNU archive site." # The file to touch is that specified with -o ... file=`echo "$*" | sed -n "$sed_output"` test -z "$file" && file=`echo "$*" | sed -n "$sed_minuso"` if test -z "$file"; then # ... or it is the one specified with @setfilename ... infile=`echo "$*" | sed 's/.* \([^ ]*\) *$/\1/'` file=`sed -n ' /^@setfilename/{ s/.* \([^ ]*\) *$/\1/ p q }' $infile` # ... or it is derived from the source name (dir/f.texi becomes f.info) test -z "$file" && file=`echo "$infile" | sed 's,.*/,,;s,.[^.]*$,,'`.info fi # If the file does not exist, the user really needs makeinfo; # let's fail without touching anything. test -f $file || exit 1 touch $file ;; tar*) shift # We have already tried tar in the generic part. # Look for gnutar/gtar before invocation to avoid ugly error # messages. if (gnutar --version > /dev/null 2>&1); then gnutar "$@" && exit 0 fi if (gtar --version > /dev/null 2>&1); then gtar "$@" && exit 0 fi firstarg="$1" if shift; then case $firstarg in *o*) firstarg=`echo "$firstarg" | sed s/o//` tar "$firstarg" "$@" && exit 0 ;; esac case $firstarg in *h*) firstarg=`echo "$firstarg" | sed s/h//` tar "$firstarg" "$@" && exit 0 ;; esac fi echo 1>&2 "\ WARNING: I can't seem to be able to run \`tar' with the given arguments. You may want to install GNU tar or Free paxutils, or check the command line arguments." exit 1 ;; *) echo 1>&2 "\ WARNING: \`$1' is needed, and is $msg. You might have modified some files without having the proper tools for further handling them. Check the \`README' file, it often tells you about the needed prerequisites for installing this package. You may also peek at any GNU archive site, in case some other package would contain this missing \`$1' program." exit 1 ;; esac exit 0 # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" # time-stamp-time-zone: "UTC" # time-stamp-end: "; # UTC" # End: spd-1.3.0/Makefile.am0000644000175000017500000000004211644024471011255 00000000000000SUBDIRS=fitpack edfpack src man spd-1.3.0/INSTALL0000644000175000017500000000032111633462461010255 00000000000000To get the sources: svn co http://forge.epn-campus.eu/svn/azimuthal To compile: copy common-gcc4.mk or common-gcc3.mk to common.mk, edit them if needed, then make To install: copy runtime/$OS/spd to ~/bin spd-1.3.0/configure.ac0000644000175000017500000000442211650556146011523 00000000000000# -*- Autoconf -*- # Process this file with autoconf to produce a configure script. AC_PREREQ([2.65]) AC_INIT([spd], [1.3.0], [Jerome.Kieffer@esrf.fr]) AM_INIT_AUTOMAKE AC_CONFIG_SRCDIR([.]) AC_CONFIG_HEADERS([config.h]) AC_F77_LIBRARY_LDFLAGS # Checks for programs. AC_PROG_CC AC_PROG_MAKE_SET AC_PROG_RANLIB AC_PROG_F77 # Checks for libraries. # FIXME: Replace `main' with a function in `-ledfpack': #AC_CHECK_LIB([edfpack], [main]) # FIXME: Replace `main' with a function in `-lfitpack': #AC_CHECK_LIB([fitpack], [main]) # Checks for header files. AC_CHECK_HEADERS([fcntl.h float.h limits.h stdlib.h string.h sys/param.h sys/time.h unistd.h]) # --------------------------------------------------------------------------- # Check for ZLIB. # --------------------------------------------------------------------------- AC_ARG_WITH(zlib-include-dir, AS_HELP_STRING([--with-zlib-include-dir=DIR], [location of Zlib headers]),,) AC_ARG_WITH(zlib-lib-dir, AS_HELP_STRING([--with-zlib-lib-dir=DIR], [location of Zlib library binary]),,) if test "x$with_zlib_lib_dir" != "x" ; then LDFLAGS="-L$with_zlib_lib_dir $LDFLAGS" fi AC_CHECK_LIB(z, inflateEnd, [zlib_lib=yes], [zlib_lib=no],) if test "$zlib_lib" = "no" -a "x$with_zlib_lib_dir" != "x"; then AC_MSG_ERROR([Zlib library not found at $with_zlib_lib_dir]) fi if test "x$with_zlib_include_dir" != "x" ; then CPPFLAGS="-I$with_zlib_include_dir $CPPFLAGS" fi AC_CHECK_HEADER(zlib.h, [zlib_h=yes], [zlib_h=no]) if test "$zlib_h" = "no" -a "x$with_zlib_include_dir" != "x" ; then AC_MSG_ERROR([Zlib headers not found at $with_zlib_include_dir]) fi LIBS="-lz $LIBS" if test "$HAVE_RPATH" = "yes" -a "x$with_zlib_lib_dir" != "x" ; then LIBDIR="-R $with_zlib_lib_dir $LIBDIR" fi # Checks for typedefs, structures, and compiler characteristics. AC_C_RESTRICT AC_TYPE_SIZE_T AC_HEADER_STDBOOL # Checks for library functions. AC_FUNC_MALLOC AC_FUNC_REALLOC AC_FUNC_STRTOD AC_CHECK_FUNCS([floor gettimeofday memset pow sqrt strcasecmp strchr strdup strerror strncasecmp strrchr strspn strstr strtol]) AC_CONFIG_FILES([edfpack/Makefile fitpack/Makefile Makefile src/Makefile man/Makefile ]) AC_OUTPUT AC_CHECK_LIB([c], [main])spd-1.3.0/src/0000755000175000017500000000000011655563114010100 500000000000000spd-1.3.0/src/util.c0000644000175000017500000006356111650061053011142 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2001-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /* Update 12/10/2011 P. Boesecke (boesecke@esrf.fr) print_memlist() added Update 30/09/2009 R. Wilcke (wilcke@esrf.fr) scan_argument(): for "%s" format, return an empty string buffer if the input argument is empty (left the "result" argument unchanged before). Update 24/04/2009 R. Wilcke (wilcke@esrf.fr) outname(): increase size of output name buffer from 512 to 1024 characters; outname(): duplicate result buffer before passing it to the "basename()" routine (the routine can change its argument); outname(): add new input argument "outdir" to the argument list and code to add it in front of the output file name. Update 21/01/2008 R. Wilcke (wilcke@esrf.fr) _pmalloc(), _prealloc() and _pfree(): slight modifications of error messages. Update 11/12/2007 R. Wilcke (wilcke@esrf.fr) fnampat(): initialize filename buffer only after test for NULL pointer. Update 06/12/2007 R. Wilcke (wilcke@esrf.fr) add function fnampat(). Update 24/08/2004 R. Wilcke (wilcke@esrf.fr) _pfree(), print_memsize(), byte_swap2N(): add "return(0)" at the end of the routine; bench(): add "return(iret)" at the end of the routine; isbigendian(): return -1 if type cannot be determined; scan_argument(): add "u" format conversion and size modifiers "h" and "l". Update 23/08/2004 R. Wilcke (wilcke@esrf.fr) scan_argument(): add "g" format conversion, write all input arguments into a special history buffer. Update 17/09/2002 R. Wilcke (wilcke@esrf.fr) bench(): return error code of gettimeofday() or 0 if no error. Update 16/09/2002 R. Wilcke (wilcke@esrf.fr) reallocate the message levels for the prmsg() calls. Update 20/11/2001 R. Wilcke (wilcke@esrf.fr) outname(): handle the case when a name is an empty string. Update 11/12/2001 R. Wilcke (wilcke@esrf.fr) protect against taking strlen() from NULL pointer. Update 20/11/2001 R. Wilcke (wilcke@esrf.fr) outname(): protect against infile = NULL pointer. outname(): handle the cases when "inext" or "outext" are NULL; Update 08/11/2001 R. Wilcke (wilcke@esrf.fr) split the code of "util.c" in two files: - "inout.c" contains all input/output related routines, - "util.c" contains the other routines of the old "util.c". Update 09/08/2001 R. Wilcke (wilcke@esrf.fr) declare struct *pmem_head as "static". */ #include "spd.h" #if MY_MALLOC /*============================================================================== * If MY_MALLOC is defined, an alternative set of routines for memory * management is used. The following routines are defined: * * - pmalloc(), prealloc(), pfree() replace the standard routines malloc(), * realloc() and free(); * - print_memsize() prints the total allocated memory size. * * The differences to the standard routines are: * - the alternative set provides error printout indicating the current file * and line number where the error occurred; * - the alternative set operates on a linked list of data structures of type * "pmem". Each structure contains the size of its data segment, a pointer to * the next element in the list, and a pointer to its own data segment. This * allows to keep track of the overall memory usage by the program with the * routine print_memsize(). * * Otherwise, the input parameters and return values of the routines in the * alternative set are the same as the ones in the standard set. * * If MY_MALLOC is not defined, pmalloc(), prealloc() and pfree() are defined * to be the standard set of memory management routines, and print_memsize() * is a dummy. */ static struct pmem *pmem_head = NULL; void *_pmalloc(int size,char *file,int line) { struct pmem *ptr; /* * Allocate the new memory segment, put the address of the last memory * segment in the link pointer, and save the address of the new memory * segment for use in the link pointer at the next call. */ if((ptr = (struct pmem *)malloc(size + sizeof(struct pmem))) == NULL) __prmsg(FATAL,file,line,("cannot allocate %d bytes\n",size)); ptr->next = pmem_head; pmem_head = ptr; ptr->data = (void *)(((char *)ptr) + sizeof(struct pmem)); ptr->size = size; return ptr->data; } void *_prealloc(void *ptr,int size,char *file,int line) { struct pmem *loop_ptr,*new_ptr,**ref_ptr; /* * Loop throuth the linked list until the requested data segment is found or * the end of the list is reached (then loop_ptr == NULL). */ for(loop_ptr = pmem_head, ref_ptr = &pmem_head; loop_ptr; loop_ptr = *(ref_ptr = &loop_ptr->next)) if(ptr == loop_ptr->data) break; if(loop_ptr == NULL) __prmsg(FATAL,file,line,("pointer was never allocated: 0x%x \n",ptr)); /* * Reallocate the requested data segment. */ if((new_ptr = (struct pmem *) realloc(loop_ptr,size + sizeof(struct pmem))) == NULL) __prmsg(FATAL,file,line,("cannot reallocate %d bytes \n", size + sizeof(struct pmem))); *ref_ptr = new_ptr; new_ptr->data = (void*)(((char*)new_ptr) + sizeof(struct pmem)); new_ptr->size = size; return(new_ptr->data); } int _pfree(void *ptr,char *file,int line) { struct pmem *loop_ptr, **ref_ptr; /* * Loop through the linked list until the requested data segment is found or * the end of the list is reached (then loop_ptr == NULL). */ for(loop_ptr = pmem_head, ref_ptr = &pmem_head; loop_ptr; loop_ptr = *(ref_ptr = &loop_ptr->next)) { if(ptr == loop_ptr->data) break; } if(loop_ptr == NULL) __prmsg(FATAL,file,line,("pointer was never allocated: 0x%x\n",ptr)); /* * Free the requested data segment, and re-adjust the link pointer. */ *ref_ptr = loop_ptr->next; free(loop_ptr); return(0); } /*============================================================================== * Print the total memory size of all allocated data segments. */ int print_memsize() { struct pmem *loop_ptr; float sum = 0; for(loop_ptr = pmem_head; loop_ptr; loop_ptr = loop_ptr->next) sum += loop_ptr->size; prmsg(DMSG,("Memory usage is now: %7.2f MiB\n",sum / 1024 / 1024)); return(0); } /*============================================================================== * Print the list of all allocated data segments. */ int print_memlist() { struct pmem *loop_ptr; int loop_cnt; printf("================================================================================\n"); for(loop_ptr=pmem_head,loop_cnt=1; loop_ptr; loop_ptr=loop_ptr->next,loop_cnt++) { printf(" memory segment %3d: %p\n",loop_cnt,loop_ptr); printf(" data %3s: %p\n"," ",loop_ptr->data); printf(" size %3s: %d\n"," ",loop_ptr->size); printf(" next %3s: %p\n"," ",loop_ptr->next); printf("--------------------------------------------------------------------------------\n"); } } #else int print_memsize() { return(0); } int print_memlist() { return(0); } #endif /* MY_MALLOC */ /*============================================================================== * Switch the byte order in the input array "s" containing "n" elements of type * short. * * Input : s: input data array, type short * n: number of data items in the input data array * Output: s: input data array with bytes swapped * Return: 0 */ union swap2_data { unsigned char c[2]; unsigned short x; }; int byte_swap2N(register union swap2_data *s,int n) { register int i; register unsigned char t; for(i = 0; i < n; i++, s++) { t = s->c[0]; s->c[0] = s->c[1]; s->c[1] = t; } return(0); } /*============================================================================== * Determines the minimum and the maximum of the four input values. * * Input : f1, f2, f3, f4: the four values to be searched for miminum and * maximum * Output: p_minf: the minimum of the four input values * p_maxf: the maximum of the four input values * Return: 0 */ int minmax4(float f1,float f2,float f3,float f4,float *p_minf,float *p_maxf) { int i; float ft[3]; float minf = f1; float maxf = f1; ft[0] = f2; ft[1] = f3; ft[2] = f4; for(i=0; i<3; i++) { if(minf > ft[i]) minf = ft[i]; if(maxf < ft[i]) maxf = ft[i]; } *p_minf = minf; *p_maxf = maxf; return(0); } /*============================================================================== * Obtains a parameter value from an input argument string. * * It searches the input argument "arg" for a string of the form * * parameter_name=parameter_value * * where parameter_name is the string contained in the input argument "str". * * If found, it prints the parameter value according to the format given in the * input argument "format" and returns the value in "result". * * Special case for "%s" format: if "parameter_value" is an empty string, the * routine retuns an empty string in "result". * * Input : arg: string to be searched for the parameter name and value * str: string with the parameter name * format: format for the parameter's value, composed of * - a '%' in the first character * - optionally followed by the size modifier 'h', or 'l' * - followed by the conversion letter 's', 'd', 'u', 'f' or 'g' * Output: result: the value of the requested parameter * Return: 1 if the requested parameter was found * 0 otherwise */ int scan_argument(char *arg,char *str,char *format,void *result) { char *pfmt,*rescop; char str_eq[256]; static char bfhisnam[EdfMaxValLen + 1]; int retval; /* * Test for valid format specification. */ pfmt = format; if(*pfmt++ != '%' || strspn(pfmt + strspn(pfmt,"hl"),"sdufg") != 1) { prmsg(ERROR,("unknown parameter format %s wrong\n",format)); return(0); } /* * Add a "=" (equal sign) to "str" and then search for the string in "arg". */ strcpy(str_eq,str); strcat(str_eq,"="); if(strncmp(arg,str_eq,strlen(str_eq)) == 0) { strcat(str_eq,format); /* * Read the parameter value from the string "arg" according to the format * given. * * Return 0 if parameter name cannot be found. */ if((retval = sscanf(arg,str_eq,result)) == 0) { prmsg(ERROR,("unknown parameter %s=xxx\n",str)); return(0); /* * If found, print parameter value. */ } else { strcat(str_eq,"\n"); if(*pfmt == 's') { /* * The sscanf() function skips whitespace for "%s" format, and returns * an EOF error if an argument contains only whitespace. This would * therefore mean that the input value of "result" remains unchanged. * * To get an empty string argument from the input, check therefore if * the last character in the input is an equal sign "=". */ if(retval == EOF && *(arg + strlen(arg) - 1) == '=') { *(char *)result = '\0'; sprintf(bfhisnam,"%s=",str); } else { rescop = strdup(result); sprintf(bfhisnam,"%s=%.*s",str,EdfMaxValLen - 11,basename(rescop)); free(rescop); } prmsg(DMSG,(str_eq,result)); } else { sprintf(bfhisnam,"%s%s",str,strchr(arg,'=')); if(*pfmt == 'f' || *pfmt == 'g') prmsg(DMSG,(str_eq,*(float *)result)); else if(*pfmt == 'd') prmsg(DMSG,(str_eq,*(int *)result)); else if(*pfmt == 'u') prmsg(DMSG,(str_eq,*(unsigned int *)result)); if(strcmp(pfmt,"lf") == 0 || strcmp(pfmt,"lg") == 0) prmsg(DMSG,(str_eq,*(double *)result)); if(strcmp(pfmt,"hd") == 0) prmsg(DMSG,(str_eq,*(short *)result)); if(strcmp(pfmt,"hu") == 0) prmsg(DMSG,(str_eq,*(short unsigned *)result)); if(strcmp(pfmt,"ld") == 0) prmsg(DMSG,(str_eq,*(long *)result)); if(strcmp(pfmt,"lu") == 0) prmsg(DMSG,(str_eq,*(long unsigned *)result)); } } edf_history_argv("InputArg",bfhisnam); return(1); } else return(0); } /*============================================================================== * Analyzes a list of filename patterns and extracts filenames from them. * * At the first call, or the next call after a reset, the routine starts at the * beginning of the list of filename patterns, analyzes the first pattern and * if successful returns with the first filename. * * For the following calls, the routine keeps internally trace of how far the * pattern list has been analyzed, and returns subsequent filenames until an * error occurs or the pattern list is exhausted. * * When the pattern list has been exhausted, the internal state of the routine * is reset. This can also be done manually by calling the routine with a non- * positive number of file name patterns. * * There can be an arbitrary number of filename patterns as input to the * routine. * * The routine creates a sequence of filenames from a filename template with * some wildcard characters. These wildcard characters are replaced by numbers * according to the numerical information contained in the filename pattern. * * The filename pattern consists of up to four elements, separated by commas: * 1) the filename template: essentially a filename (possibly with path), but * the name itself can contain one or several wildcard characters "%" * (percent sign). These need not be contiguous in the template; * 2) the start value of the numerical sequence; * 3) the end value of the numerical sequence; * 4) the increment between two sequence numbers. * * In a filename pattern with wildcards, the first filename returned will be * the template string with the wildcard characters replaced by the start value * of the numerical sequence. The second filename will then contain the start * value plus the increment, and so on, until the generated number passes the * end value of the sequence. * * Negative numbers are allowed, even for the increment. The sequence then * counts downwards. * * Under the following circumstances the routine will return exactly one * filename (with the start value of the sequence): * - if the increment is 0; * - if (start value) > (end value) and the increment is positive; * - if (start value) < (end value) and the increment is negative; * * If the wildcard pattern is longer than the significant digits in the number, * it will be left padded with zeros. If the number is negative, the first * wildcard is replaced by a "-" (minus). If the wildcard pattern is shorter * than the significant digits in the number, the number will be truncated. * * Not all elements of the sequence need to be specified. Missing elements are * replaced by default values: * - start value = 1; * - end value = start value; * - increment = 1. * * If the filename template does not contain any wildcards, the template string * is returned as filename. * * Examples: pattern filenames created * abc%%d,1,3,2 abc01d abc03d * abc%%de%%,497,495,-1 ab04de97 ab04de96 ab04de95 * abcdef abcdef * abc%%% abc001 * abc%%%,8 abc008 * abc%%%,4,7 abc004 abc005 abc006 abc007 * abc%%%,-7,-6 abc-07 abc-06 * * Input : filnam: buffer to receive character string. Must be allocated by * calling program * fillen: length of buffer filnam * patc: number of file name patterns to analyze. If <= 0, the * internal state of the routine is reset * patv: array of strings with the file name patterns * Output: filnam: most recent filename obtained from the pattern analysis * Return: -1 (= error) if input arguments are incorrect or invalid * -2 (= end) if pattern list has been exhausted (end of present * analysis) or if manual reset has been done * 0 else (= OK, new filename obtained) */ int fnampat(char *filnam,size_t fillen,int patc,char *patv[]) { static char filbuf[FILENAME_MAX]; char number[1024]; char *ptrpatv; static int patn = 0; int err,numlen = sizeof(number); static long num,fst,lst,inc,maxloop,loop = 0; /* * Check for incorrect input buffer arguments. If so, return error. */ if(fillen <= 0 || filnam == NULL) return(-1); *filnam = '\0'; /* * Check if the input pattern list is exhausted, or a manual reset has been * requested. Return with end code. */ if(patn >= patc || patc <= 0) { patn = 0; loop = 0; return(-2); } /* * Check if the filename pattern has wildcards. If not, return just this * pattern string and advance the pattern list pointer to the next pattern. */ ptrpatv = *(patv + patn); if(filename_has_pattern(ptrpatv) == 0) { strncat(filnam,ptrpatv,fillen - 1); patn++; return(0); } /* * Check if at the beginning of a pattern analysis (then the pattern loop * counter is 0). If so, extract the filename template and possibly the * numerical arguments. Set default values for the numerical arguments if they * are not provided in the pattern. */ if(loop == 0) { if(filename_parameter(filbuf,sizeof(filbuf),ptrpatv,0) == NULL) return(-1); fst = num_str2long(filename_parameter(number,numlen,ptrpatv,1),NULL,&err); if(err) fst = 0; lst = num_str2long(filename_parameter(number,numlen,ptrpatv,2),NULL,&err); if(err) lst = fst; inc = num_str2long(filename_parameter(number,numlen,ptrpatv,3),NULL,&err); if(err) inc = 1; /* * Determine number of iterations for the pattern, and set file index number * to the first value. */ maxloop = inc == 0 ? 1 : (lst - fst) / inc + 1; if(maxloop < 1) maxloop = 1; num = fst; } /* * Construct the actual filename from the pattern with the present file index * number. */ filename_pattern(filnam,fillen,filbuf,num); /* * Check if at the end of a pattern analysis. If so, advance the pattern list * pointer to the next pattern and reset loop counter. If not, set the file * index number to its next value for the next call of the routine. */ if(++loop >= maxloop) { loop = 0; patn++; } else num+=inc; return(0); } /*============================================================================== * Creates a name for an output file by taking the string "infile" with the * name of the input file and replacing the extension contained in "inext" by * the string contained in "outext". The resulting file name can optionally be * preceded by the directory path contained in "outdir". * * More precisely, the "infile" is searched for the occurrence of the substring * given by "inext". If found, "inext" in the string "infile" is replaced by * "outext". It does not need to be separated by e.g. a dot, and the substring * does not even have to be at the end of "infile". As an example, with "infile" * containing "datafile3.dat", "inext" containing "e3" and "outext" containing * "_cor", the output file name is "datafil_cor.dat". * * If "infile" is a NULL pointer or empty, the output file name is "outext". * If "outext" is also a NULL pointer, the routine returns a NULL pointer. * * If "inext" is a NULL pointer or is not found as a substring of "infile", then * the output file name is created by concatenating "infile" with "outext". If * "outext" is empty or NULL, this means that the output file name is the same * as the input file name. * * If "outext" is a NULL pointer or empty, the output file name is "infile", * with the substring "inext" removed if found. * * The resulting file name will be preceded by the directory path contained in * "outdir", if * - "outdir" does contain a real string (not NULL pointer and not empty); * - "infile" does not contain a directory part (i.e. the "infile" string does * not contain the directory separator "/" anywhere). * * No tests are made that the string in "outdir" is of the type "directory path" * (e.g. with at least one "/" separator at the end of the string), thus the * routine could also be used to add a prefix to the output file name. * * Note that the routine returns a pointer to a static character array. It will * therefore be overwritten by each subsequent call, but it needs not (cannot) * be freed. * * Input : infile: string with the name for the input file * outdir: string with the (optional) directory path for the output file * inext: string with the extension for the input file name * outext: string with the extension for the output file name * Output: none * Return: string with the name for the output file * NULL if no output file name could be created */ char *outname(char *infile,char *outdir,char *inext,char *outext) { char *pos; static char outfile[1024]; /* * Put output directory path at the beginning of the file name if: * - it exists (not NULL pointer and not empty); * - the file name itself does not contain a directory path. */ if(outdir != NULL && *outdir != '\0' && strchr(infile,'/') == NULL) strcpy(outfile,outdir); else *outfile = '\0'; /* * Search for the substring with the input file name extension. */ if(infile == NULL || *infile == '\0') { /* * If the input file name is a NULL pointer or empty, the output file name * is just the file name extension. If the extension is equally a NULL * pointer or empty, return a NULL pointer for the output file name. */ if(outext == NULL || *outext == '\0') return((char *)NULL); strcat(outfile,outext); } else if(inext == NULL || *inext == '\0' || (pos = (char *)strstr(infile,inext)) == NULL) { /* * If the file name extension is not found, concatenate the input file name * with the output file extension. */ strcat(outfile,infile); if(outext != NULL && *outext != '\0') strcat(outfile,outext); } else { /* * If found, replace everything from the start of the input file name * extension with the output file name extension. */ strncat(outfile,infile,pos - infile); if(outext != NULL && *outext != '\0') strcat(outfile,outext); strcat(outfile,pos + strlen(inext)); } return(outfile); } /*============================================================================== * Determines the byte ordering scheme of the computer on which the program * runs. * * The possibilities are big endian, where the most significant byte (of a * 2-byte or bigger word) has the lower address, or little endian, where the * least significant byte has the lower address. * * Input : none * Output: none * Return: 1 if big endian byte ordering * 0 if little endian byte ordering * -1 if type cannot be determined */ int isbigendian() { union { char buf[4]; long x; } v; /* ??? why does setting to 0 help for the 64 bit case? Would one then not get 0x1234567800000000 for the big endian case ??? */ v.x = 0; /*if 64 bit longs */ v.buf[0] = 0x12; v.buf[1] = 0x34; v.buf[2] = 0x56; v.buf[3] = 0x78; if (v.x == 0x12345678) return(1); /* Sun Sparc, HP700 ... */ else if (v.x == 0x78563412) return(0); /* 80x86, vax, ... */ /* ??? if it is neither (see remark above), what is returned then ??? */ return(-1); } /*============================================================================== * Measures and prints the time difference between two consecutive calls. * * At the first call to this routine, the input argument "str" must be a NULL * pointer. This sets the start time. * * All subsequent calls with "str" not equal to a NULL pointer measure the time * between the start time and the time of the present call, print it together * with "str" and store the time of the present call into the start time as * preparation for the next call. It is thus possible to time a whole sequence * of events. * * To end such a sequence and start a new one, the routine can at any time be * called again with a NULL pointer, thus resetting the start time. * * Input : str: if NULL: resets the start time to the time of the present call * else: string to be printed with the time difference * Output: none * Return: if no error: 0 * else : error code of gettimeofday() function */ int bench(char *str) { static struct timeval start,stop; struct timezone tzp; int iret; if(str == (char *)NULL) { iret = gettimeofday(&start,&tzp); } else { if((iret = gettimeofday(&stop,&tzp)) == 0) { prmsg(DMSG,("Time in %s : %10.3f\n",str,(double)(stop.tv_sec-start.tv_sec) + (double)(stop.tv_usec-start.tv_usec) * (double)0.000001)); start.tv_sec = stop.tv_sec; start.tv_usec = stop.tv_usec; } } return(iret); } spd-1.3.0/src/correct.c0000644000175000017500000121351711655560076011643 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2001-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /* Update 23/10/2011 P. Boesecke (boesecke@esrf.fr) DO_DARK default set to 0 strtok_r -> strlib_tok_r Update 19/10/2011 P. Boesecke (boesecke@esrf.fr) Various changes to allow intensity renormalization during prerotation corrections. The following variables have been added: INVALID_TYP, SDMTYP, TMPTYP, MINFILE, MOUTFILE, M_COR, NORM_PREROT, If NORM_PREROT is set the distortion corrected image is multiplied with the intensity correction array M_COR. The array M_COR is always created together with the displacement arrays X_COR and Y_COR, but it remains always available. The renormalization during prerotation correction can be controlled with set_normprerot, set_moutfile defines the output file name of the the intensity correction array M_COR, if required. The correct intensity normalization with and without prerotations has been checked. Other changes: - get_doprerot added to allow to read the prerot values from outside this module. - upd_headval(): parameters out_type and mode added, upd_headval must only be used for DO_PREROT!=2, - normint_im(): partial normalizations to Intensity1 and DOmega added. This can be controlled with set_normint(normint,factor), with normint 0: copy src_im to cor_im 1: full normalization (I/DOmega/Intensity1*NORMFACT) 2: normalization to Intensity1 (I/Intensity1*NORMFACT) 3: normalization to DOmega (I/DOmega*NORMFACT) Originally, only the values 0 and 1 were possible. Update 23/09/2011 P. Boesecke (boesecke@esrf.fr) DO_SPD=4 added, subtract_im: additional parameter fac added, to avoid usage of scale_im in scattering background subtraction. old function renamed to subtract_drk Update 22/09/2011 P. Boesecke (boesecke@esrf.fr) DO_PREROT default is 0 (according to inout.c) Update 14/09/2011 P. Boesecke (boesecke@esrf.fr) Only a single place to write final XOUTFILE and YOUTFILE at the end of spd_corr (removed from spd_scorr and spd_fcorr). correct_image: with SDX_PREROT it is not necessary any more to check that the prerotation angles are zero when DO_PREROT is not set. Update 12/09/2011 P. Boesecke (boesecke@esrf.fr) SDX_PREROT variable added. Update 10/09/2011 P. Boesecke (boesecke@esrf.fr) spd_rotcorr and undistort_im: To allow the use of DSTRTVAL updated CORTYP header parameters inside spd_rotcorr the CORTYP and SDXTYP headers are updated with the new functions upd_headval calc_prerot and set_prerot_headval. Update 08/09/2011 P. Boesecke (boesecke@esrf.fr) default of overflow parameter IMAGE_OVER changed from 0xffff to 0 because it is detector dependent. The overflow parameter is now an unsigned long (before unsigned short) to allow use with detectors having more than 2 bytes data per pixel. Update 17/08/2011 P. Boesecke (boesecke@esrf.fr) set_doprerot added (to do a rotation correction after the distortion correction) Update 22/07/2011 P. Boesecke (boesecke@esrf.fr) rearrangement of code: andy_corr split into andy_corr and andy_scorr, error labels added in andy_corr, andy_scorr and andy_fcorr, no forward declaration, corr_calc renamed to undistort_im, ANDY_CORR code collected in a single block, because it is - and was - not possible any more to compile spd without ANDY_CORR defined this FLAG is not checked any more. my_func -> spd_func, myfgets -> spd_fgets, unloadspd -> spd_unloadspline, loadspdfile -> spd_loadspline, findkeyword -> spd_findkeyword, readarray -> spd_readarray, pxcorrgrid -> spd_calcspline Update 03/06/2010 P. Boesecke (boesecke@esrf.fr) angle_sum replaced by ang_sum to include rotations azim_int: flag apro added, a0, da in radian, parameter verbose added. For azim_pro!=0 the key ProjectionType in the AZITYP header is set according to azim_pro:IO_ProSaxs | IO_ProWaxs. Update 06/10/2009 P. Boesecke (boesecke@esrf.fr) azim_int(): azimuthal regrouping and averaging is now done with functions angle_sum (angle.h) and project_1 (project.h), unused variables removed. Update 06/05/2009 R. Wilcke (wilcke@esrf.fr) correct_image(): print information on corrections performed; set_splinfil(): return without action if input buffer is NULL. Update 13/02/2009 Peter Boesecke (boesecke@esrf.fr) in map_imag: The displaced offsets of read xyfiles were twice as big as they should. They contained additionally the offset of the mapped region. This bug could only be observed for option psize_distort==2. Now, the displaced offsets are only divided by the binning factor. Update 16/06/2008 Peter Boesecke (boesecke@esrf.fr) obsolete include "SaxsRoutine.h" removed. Update 22/01/2008 R. Wilcke (wilcke@esrf.fr) slightly modified many error messages in the program; added routines interval_compare() and region_compare(). Update 20/12/2007 R. Wilcke (wilcke@esrf.fr) set dimension of table "exptab" to USHRT_MAX + 1; mark_overflow_nocorr(): scale the various limits (overflow, minimum, maximum) with the exponentiation constant INPEXP if it is set. Update 17/12/2007 R. Wilcke (wilcke@esrf.fr) scale_im(): add size of image to the argument list and change code to use that value instead of XSIZE * YSIZE; correct_image() and map_imag(): add image size to the arguments of the scale_im() call. Update 28/11/2007 R. Wilcke (wilcke@esrf.fr) correct_image() and map_imag(): move linearity correction from correct_image() to map_imag(). Update 26/11/2007 R. Wilcke (wilcke@esrf.fr) expon_im() and set_inpexp(): replace exponential function by a lookup table calculation for speed. Update 10/04/2007 R. Wilcke (wilcke@esrf.fr) add new global variable DO_DARK to suppress the dark image correction; add new function set_dodark() to set DO_DARK; correct_image(): do dark image correction only if DO_DARK is set. Update 01/02/2007 P. Boesecke (boesecke@esrf.fr) map_imag(): replace call to RebinFloat2d() with IpolRebin2(). Update 14/02/2007 R. Wilcke (wilcke@esrf.fr) correct_image(): modify linearity correction if the source or dark image are binned. Update 12/02/2007 R. Wilcke (wilcke@esrf.fr) set_dstrtval() and undistort_im(): for the update of the output image header, do no longer use the special enumerated data, but the general flags for the user data header. Update 26/09/2006 R. Wilcke (wilcke@esrf.fr) mark_overflow_nocorr(): add new argument containing the list with the dummy pixels; add new functions set_inpexp() to define a exponential constant for the linearity correction and expon_im() to apply this constant to an image; correct_image(): add the exponentiation of the source image at the very beginning of the corrections and equally modify code for dark image subtraction to include exponentiation. Update 10/03/2006 R. Wilcke (wilcke@esrf.fr) set_dospd(): do no longer set LUT_INVALID in this routine. Update 15/09/2005 R. Wilcke (wilcke@esrf.fr) lut_calc(): make the two tests for MAX_PIXELSIZE identical. Update 09/09/2005 R. Wilcke (wilcke@esrf.fr) triangle_cutall(): modify the definition and thus also the calculation of the cut lines; this also changes the returned minimum and maximum grid lines in x and y; andy_corr(): change code to calculate the coordinates along the right and upper edges of the image as well; andy_corr(): add Offset_1 and Offset_2 to the header flags of the SDXTYP and SDYTYP buffers; andy_fcorr(): write the displacement buffers to x and y files if requested with XOUTFILE and YOUTFILE; my_func(): allow calculations of corrected coordinates for the right and upper edge of the image as well; map_imag(): for displacement files (type SDXTYP and SDYTYP), make output dimensions one bigger and set an offset of -0.5; lut_calc(): for the loops over the source pixels, modify the processing of their corners to include the edges of the image in a consistent manner. Update 24/08/2005 R. Wilcke (wilcke@esrf.fr) lut_calc(): when compressing the program (in Step 5), allocate a bigger buffer for the compressed LUT if necessary instead of terminating the program when the buffer gets too small. Update 19/08/2005 R. Wilcke (wilcke@esrf.fr) replace multiplication by RELTABSIZE with shift by RELTABSH. Update 13/04/2005 R. Wilcke (wilcke@esrf.fr) lut_calc(): when creating multipixel target advances, check that the counter does not overflow (unsigned short), and create additional MULTIINC instructions if necessary. Update 01/04/2005 R. Wilcke (wilcke@esrf.fr) set_headval(): move from this routine to routine scanhead() (file "inout.c") the initialization of header values that are not set by the input data. Update 24/03/2005 R. Wilcke (wilcke@esrf.fr) azim_int(): change the way the "s" and average values are preset for the averaged output array. Update 25/01/2005 R. Wilcke (wilcke@esrf.fr) map_imag(): handle the "displaced parameters" of the distortion files; undistort_im(): add Offset_1, Offset_2, BSize_1 and Bsize_2 to the list of header values that will be updated. Update 14/01/2005 R. Wilcke (wilcke@esrf.fr) remove routine set_dolater() and global variable DO_LATER; set_dospd(): add code for new functionality (possible values now 0, 1, 2 or 3); set_headval(): provide default values for the new header members ProjTyp, DetRot_1, DetRot_2 and DetRot_3; undistort_im(): get the values for the new header members from the distortion files if required; azim_int(): remove input argument ave_waxs, add header flag FL_PRO to the list of required header flags and use the header members ProjTyp to determine Saxs / Waxs image type; correct_image(): change code for processing the various combinations of corrections and add the case DO_SPD == 3. Update 21/09/2004 R. Wilcke (wilcke@esrf.fr) change name and call of bin_imag() to map_imag(). Update 07/09/2004 R. Wilcke (wilcke@esrf.fr) set_splinfil(): cleaned up code for the case of a new distortion file; andy_corr() and andy_free_buffers(): made x_buf and y_buf local variables in andy_corr(), allocate and free them there as well; andy_corr(): allocation of cor_x and cor_y buffers is done by get_buffer(). Update 31/08/2004 R. Wilcke (wilcke@esrf.fr) divide_im() and divide_insito_im(): do no longer mark illegal pixels of the flood field image with "Dummy" in the output image; mark_overflow_nocorr(): process also illegal pixels of the flood field image; correct_image(): fill temp_im buffer with 0. before marking illegal pixels and add code to mark illegal pixels for the flood field image; normint_im(): use num_str2double() instead of atof() to get value of header member Intens_1; correct_image(): free structure members lut_d->xrel and lut_d->yrel. Update 30/08/2004 R. Wilcke (wilcke@esrf.fr) set_imgbuf(): call to prepare_flood() for flood field images moved here from get_buffer() (file inout.c); normint_im(): process all pixels, do not test for "Dummy"; prepare_flood(): return without action if NULL output buffer. Update 25/08/2004 R. Wilcke (wilcke@esrf.fr) azim_int(): add new input parameter and code to calculate the scattering vector for an image that has been projected to the Ewald sphere; change name of global variable PSIZDIST to DSTRTVAL; change name of routine set_psizdist() to set_dstrtval() and change test for allowed values; undistort_im(): add code to set center coordinates and sample distance from the distortion files. Update 24/08/2004 R. Wilcke (wilcke@esrf.fr) trianglecutv_only(), trianglecuth_only(), andy_active_area(), make_grid(), azim_int(), lut_calc(), debug_print(): remove unused variables; trianglecuth_only(), triangle_cutall(), debutout(), my_func(), andy_free_buffers(), andy_active_area(), make_grid(), mark_overflow_nocorr(), undistort_im(), debug_print(), despair(): add "return(0)" at the end of the routine; Update 18/08/2004 R. Wilcke (wilcke@esrf.fr) replace call to rebin_float_2d() by RebinFloat2d() and remove rebin_float_2d() function declaration. Update 21/06/2004 R. Wilcke (wilcke@esrf.fr) andy_loadspline(): add search for optional keyword "BINNING". Update 18/06/2004 R. Wilcke (wilcke@esrf.fr) bin_imag(): do not divide the binned pixels by the weight factor for SRCTYP and DRKTYP. Update 17/06/2004 R. Wilcke (wilcke@esrf.fr) correct_image(): set temp_im pointer to NULL after pfree(). Update 29/03/2004 R. Wilcke (wilcke@esrf.fr) set_headval(): set default values for header elements BSize_1 and BSize_2; prepare_flood(): use size information from flood image if it is defined; remove conditional code for LOW_MEM (no longer used). Update 19/03/2004 R. Wilcke (wilcke@esrf.fr) add function bin_imag(); andy_corr(): add code for binning of the x- and y-distortion files; replace the functions set_bckgim(), set_drkim() and set_floim() by function set_imgbuf(). Update 31/07/2003 R. Wilcke (wilcke@esrf.fr) normint_im(): correct the multiplication factor for the pixel values. Update 21/07/2003 R. Wilcke (wilcke@esrf.fr) add new global variable NORMFACT for the scattering intensity normalization factor; set_normint(): add the scattering intensity normalization factor as second argument to the function and set NORMFACT; normint_im(): multiply each pixel of the output image with NORMFACT. Update 11/03/2003 R. Wilcke (wilcke@esrf.fr) correct_image(): explicitly initialize *temp_im to NULL. Update 26/10/2002 R. Wilcke (wilcke@esrf.fr) change default value of PSIZDIST from 1 to 0; set_psizdist(): change comments to reflect the new possible values of PSIZDIST; set_psizdist(): change the function type from "void" to "int" and return an error if the input value is illegal; undistort_im(): add code to handle the new values of PSIZDIST; mark_overflow_nocorr(): correct comments. Update 24/10/2002 R. Wilcke (wilcke@esrf.fr) andy_calcspline(): removed variable "buffer" (not needed); andy_calcspline(): reorder output of BISPEV() routine to have x coordinate index increase fastest; my_func(): change the indexing algorithm for arrays X_COR and Y_COR to agree with the new storage layout in andy_calcspline(). Update 26/09/2002 R. Wilcke (wilcke@esrf.fr) move routine _prmsg() from "correct.c" to "inout.c"; remove routine set_verbose(); remove declaration of global variable "verbose"; lut_calc(): add flag PRERR to prmsg() call for "." (dot) printing. Update 17/09/2002 R. Wilcke (wilcke@esrf.fr) andy_unloadspline() and area_only(): declare functions as "void"; subtract_im(), divide_insito_im() and divide_im(): return 0 for no error; undistort_im(): return 0 if no error, -1 if error. Update 16/09/2002 R. Wilcke (wilcke@esrf.fr) _prmsg(): initialize "errmsg" = NULL, call strerror() only if errno != 0, print MSG level messages if "verbose" >= 0; reallocate the message levels for the prmsg() calls; lut_calc(): do BOUND_CHECK tests independent of "verbose". Update 05/09/2002 R. Wilcke (wilcke@esrf.fr) set_headval() and normint_im(): change code to treat "data_head" members "Intens_0" and "Intens_1" as string instead of "float". Update 03/09/2002 R. Wilcke (wilcke@esrf.fr) change references from "background correction" to "dark image correction", this includes changing all corresponding variable names from "bkg...." to "drk...."; rename enumerated variable BKGTYP to DRKTYP; rename BKG_CONST and BKG_IM to DRK_CONST and DRK_IM; change function names set_bkgconst() and set_bkgim() to set_drkconst() and set_drkim(); change variable names referring to "scattering background correction" from "sca...." to "bckg...."; rename enumerated variable SCATYP to SBKTYP; change function names set_scaconst(), set_scafact() and set_scaim() to set_bckgconst(), set_bckgfact and set_bckgim(); rename SCACONST, SCAFACT and SCA_IM to BCKGCONST, BCKGFACT and BCKG_IM; Update 02/09/2002 R. Wilcke (wilcke@esrf.fr) prmsg() and _prmsg(): print in _prmsg() all output to "stdout" instead of "stderr". This in turn determines where the prmsg() output goes to. Update 30/05/2002 R. Wilcke (wilcke@esrf.fr) mark_overflow(): mark all target pixels as "dummy" that have no source pixels mapped onto them; correct_image(): add INPFACT and INPCONST corrections for the case that only intensity normalization or scattering background correction are to be performed. Update 29/05/2002 R. Wilcke (wilcke@esrf.fr) correct_image(): modify the program flow to separate into three clearly distinguished steps: corrections, normalization and marking of invalid pixels. Update 14/03/2002 R. Wilcke (wilcke@esrf.fr) set_xycorin(): free the "spline" structure if it exists. Update 13/03/2002 R. Wilcke (wilcke@esrf.fr) andy_fcorr(): replace read_esrf_file() call by get_buffer(); andy_corr(): call andy_fcorr() before freeing buffers; andy_corr(): reset SPLINE_INVALID only if the new spline coefficients could be successfully obtained; andy_fcorr(): return without action if SPLINE_INVALID is false, and reset SPLINE_INVALID if the routine is successful; andy_calcspline(): return with error if "spline" structure is NULL. Update 12/03/2002 R. Wilcke (wilcke@esrf.fr) use macro MAXTYP to declare the size of "img_head" and use the C default value 0 to initialize the "init" members; get_headval() and set_headval(): use 0 and MAXTYP to test for valid values of the "type" input argument; andy_corr() and andy_fcorr(): replace data type SPDTYP by the two new data types SDXTYP and SDYTYP. Update 05/03/2002 R. Wilcke (wilcke@esrf.fr) lut_calc(): remove freeing "lut_d->temp_im" (no longer used). Update 04/03/2002 R. Wilcke (wilcke@esrf.fr) andy_fcorr(): test if the x and y pixel sizes are defined in the files with the distortion values, and if the definitions are identical in both files; undistort_im(): test for illegal or non-defined pixel sizes; andy_corr(): put the x and y pixel sizes in the files with the distortion values; andy_corr(): use put_buffer() instead of save_esrf_files() to write the distortion values to file. Update 01/03/2002 R. Wilcke (wilcke@esrf.fr) andy_corr() and andy_fcorr(): free distortion buffers only in andy_corr(), and call andy_fcorr() after this is done; set_splinfil(): modify test for new file; set_xycorin(): add test for new files. Update 28/02/2002 R. Wilcke (wilcke@esrf.fr) lut_calc(): test for fxmin and fymin "less or equal than 0" instead of just "less than 0" to avoid overwriting boundaries of array "offsets". Update 25/02/2002 R. Wilcke (wilcke@esrf.fr) lut_calc(): introduce additional variables xsize1, ysize1 and xysize to avoid recalculating values. Update 21/02/2002 R. Wilcke (wilcke@esrf.fr) andy_fcorr(): set cols = XSIZE, rows = YSIZE to have a size defined for the read_esrf_file() call; rename global variable FILENAME to DISTFILE; set_splinfil(), andy_loadspline() and gtest(): change variable name "filename" to "distfile". Update 23/01/2002 R. Wilcke (wilcke@esrf.fr) mark_overflow(): return -1 in case of error; lut_calc(): return NULL pointer in case of error; correct_image(): return with error if calculation of look-up table failed. Update 22/01/2002 R. Wilcke (wilcke@esrf.fr) andy_fcorr() and andy_corr(): test for read errors in the input files and return -1 if there are any; my_func(): return with error -1 if andy_corr() returns error. Update 20/12/2001 R. Wilcke (wilcke@esrf.fr) andy_corr(): remove last argument (title) in save_esrf_file() call and add "SPDTYP" as new 5th argument. Update 19/12/2001 R. Wilcke (wilcke@esrf.fr) andy_corr(): remove the last input argument in the call to save_esrf_file(). Update 13/12/2001 R. Wilcke (wilcke@esrf.fr) changed the initialization value of FILENAME from "spatial.dat" to NULL and modify set_splinfil() accordingly. Update 03/12/2001 R. Wilcke (wilcke@esrf.fr) _prmsg(): print system error messages only if "errno" has a valid value. Update 03/12/2001 R. Wilcke (wilcke@esrf.fr) get_headval(), set_headval() and azim_int(): add code to process the new header type AVETYP; azim_int(): add the averaging buffer and the scale factor to the input arguments and modify code to handle these arguments. Update 28/11/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): add "SampleDistance" and "Wavelength" to the required header values; azim_int(): copy CORTYP header structure to AZITYP structure; azim_int(): calculate "s" and averaged angle value for each radial value; Update 26/11/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): remove test for the range of the angular integration; azim_int(): change value for I0Offset_2; azim_int(): change the input arguments by providing the radial and angular dimensions instead of the end values, and change code of the routine accordingly; get_headval and set_headval(): type can now also be "AZITYP". Update 22/11/2001 R. Wilcke (wilcke@esrf.fr) increase dimension of structure img_head to 8. Update 20/11/2001 R. Wilcke (wilcke@esrf.fr) correct_image(): always allocate space for temporary image if there is none yet. Update 19/11/2001 R. Wilcke (wilcke@esrf.fr) add new global variables INPCONST, INPFACT, SCACONST, SCAFACT and functions set_inpconst(), set_inpfact, set_scaconst(), set_scafact() to set their values; add new function scale_im() to adjust the input image with a multiplicative and an additive constant; correct_image(): use new function scale_im() to adjust the values of the input and the scattering background images. Update 16/11/2001 R. Wilcke (wilcke@esrf.fr) add new global variable PSIZDIST and a function set_psizdist() to set its value; undistort_im(): set pixel size for corrected image from distortion files only if PSIZDIST is set. Update 14/11/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): correct values and test for the range of the angular integration. Update 13/11/2001 R. Wilcke (wilcke@esrf.fr) mark_overflow_nocorr(): test illegal values "IMAGE_OVER", "INP_MIN" and "INP_MAX" only for source and dark current images; correct_image(): do test for illegal "Dummy" values after performing the scattering background subtraction. Update 12/11/2001 R. Wilcke (wilcke@esrf.fr) mark_overflow_nocorr(): separate the tests for illegal values "IMAGE_OVER" and "dummy" in two loops for better performance; mark_overflow_nocorr(): add the 3. input argument "type" and replace the fixed index "SRCTYP" by this new index "type"; mark_overflow_nocorr(): return without action if the input image buffer is a NULL pointer; correct_image(): add the 3. input argument "SRCTYP" to the mark_overflow_nocorr() calls; correct_image(): call mark_overflow_nocorr() with the dark current image if there is one; Update 09/11/2001 R. Wilcke (wilcke@esrf.fr) change the scope of the first "#if ANDY_CORR" clause - as it was, all global variable declarations were in it. Update 08/11/2001 R. Wilcke (wilcke@esrf.fr) andy_corr() and andy_fcorr(): save the x- and y-pixel sizes when obtained from the (spline or coordinate) files; undistort_im(): set the header values PSize_1 and PSize_2 for the corrected image from the saved x- and y-pixel sizes; add global variables INP_MAX and INP_MIN, which define the maximum and minumum allowed values in the source and the dark images, and add routines set_inpmax() and set_inpmin() to set their values; mark_overflow_nocorr(): add test for values less than INP_MIN or greater than INP_MAX; Update 05/11/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): add code to restrict integration to the range given by either the input arguments or the dimension of the input image. Update 05/11/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): add 2 more new input arguments. Update 31/10/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): add calculation of maximum radius for the azimuthal integration. Update 22/10/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): add 3 new input arguments for start radius and angle as well as angular increment. Update 18/10/2001 R. Wilcke (wilcke@esrf.fr) set_dummy(): set value of "DDummy" to reflect new value of "Dummy"; normint_im(): take "ddummy" from the CORTYP header structure; add new routine azim_int() to integrate an image azimuthally. Update 03/10/2001 R. Wilcke (wilcke@esrf.fr) andy_corr(): change last argument in save_esrf_file() from NULL to -1. Update 02/10/2001 R. Wilcke (wilcke@esrf.fr) andy_corr(): remove the last two arguments in the call to save_esrf_file(). Update 14/09/2001 R. Wilcke (wilcke@esrf.fr) correct_image(): return -2 if no buffer for corrected image was given, -1 if any of the corrections failed, and 0 else. Update 13/09/2001 R. Wilcke (wilcke@esrf.fr) normint_im(): corrected test for the required header values. Update 11/09/2001 R. Wilcke (wilcke@esrf.fr) mark_overflow(): correct error in the processing of the last pixel: in the "for" loop for "j", replace "YSIZE" by "XSIZE" as it is the case in the loop for all other pixels; lut_calc(): correct code for filling the lut_d->xrel and lut_d->yrel arrays, because the input arrays x_trg and y_trg have one pixel more in each dimension than xrel and yrel. Update 20/08/2001 R. Wilcke (wilcke@esrf.fr) add function get_headval() to obtain the values of the header structures; set_headval(): define default values for structure members Dummy, DDummy, Offset_1, Offset_2, Orientat and Intens_1; correct_image(): if no correction is to be done, just copy the input file to the output file; set_dummy(): put the new "Dummy" in the header structure of the corrected image (type = CORTYP); mark_overflow_nocorr(): write the output "Dummy" value into the header of the corrected image; correct_image(): allocate the space for the temporary image no longer in the structure "lut_d", but in a separate static variable "temp_im"; Update 17/08/2001 R. Wilcke (wilcke@esrf.fr) set_headval(): do no longer set member "init" to 1 in the routine, as "init" now contains the "OR"ed flags of all header keywords that have been found; normint_im(): test "init" member for the required keywords; mark_overflow_nocorr() and prepare_flood(): test "init" member for the keywords "Dummy" and "DDummy"; mark_overflow(): return immediately without action if "image_over" is not a valid dummy value; change dimension of structure array img_head from 6 to 7; set_headval(): "type" can now also be "SPDTYP"; andy_fcorr(): fill the members PSize_1 and PSize_2 of the header structure for the corrected image from the files for the corrected x and y coordinates; andy_fcorr() and andy_corr(): or the flags for PSize_1 and PSize_2 into the "init" member of the corrected image header; move the declarations of andy_active_area() and andy_fcorr() to the beginning of the file; correct_image(): free the members of structure "lut_d" only if they do not contain NULL pointers. Update 16/08/2001 R. Wilcke (wilcke@esrf.fr) correct_image(): change code to process the marking of illegal pixels correctly; mark_overflow() and mark_overflow_nocorr(): use only "Dummy" to mark illegal pixel values in the output; prepare_flood(): use the value of the keyword "Dummy" in the floodfield image header to find illegal pixels in the floodfield image; normint_im(): do not process pixels with illegal values; set_actrad(): take new value only if different from old one. Update 14/08/2001 R. Wilcke (wilcke@esrf.fr) andy_fcorr(): add new fifth argument (type = SPDTYP) to the read_esrf_file() call. Update 13/08/2001 R. Wilcke (wilcke@esrf.fr) rename structure variable "src_head" to "img_head", make it an array with dimension 6 and initialize all their "init" members to 0; set_headval(): change the type of the function from "void" to "int", add a second input argument to the function, change code to copy the input header to particular element in the header structure array, copy a SRCTYP input header also to the CORTYP structure and return an error if the "type" of the structure requested has an illegal value; andy_corr(): put the x- and y-pixel sizes in the header structure element CORTYP; normint_im(): take the values from the header structure element CORTYP; prepare_flood(): add code to take the values for "dummy" and "ddummy" from the FLOTYP header structure, if this has been initialized. Update 10/08/2001 R. Wilcke (wilcke@esrf.fr) subtract_im(): always subtract the background constant; correct_image(): do corrections even if only NORM_INT or SCA_IM are specified; normint_im(): add output buffer as second input argument; Update 07/08/2001 R. Wilcke (wilcke@esrf.fr) add global variable SCA_IM, which points to the scattering background image, and routine set_scaim() to set its value; subtract_im(): remove variable "negative"; subtract_im(): add fourth input argument for the background constant and modify the references to BKG_CONST accordingly; correct_image(): add forth input argument to the calls to subtract_im(); correct_image(): correct error in the "distortion floodfield (floodfield after distortion)" case: wrong source image for undistort_im() call was specified; correct_image(): add code to perform the scattering background correction; andy_corr(): divide the x- and y-pixel sizes by 1000000. Update 06/08/2001 R. Wilcke (wilcke@esrf.fr) andy_corr(): put the corrected x- and y-pixel sizes in the data header structure. Update 03/08/2001 R. Wilcke (wilcke@esrf.fr) correct_image(): add variable "bkg_cor" to indicate if a background correction is to be done; add global variable NORM_INT for the normalization to absolute scattering intensities and routine set_normint() to set its value; add struct src_head and routine set_headval() to set its values; add routine normint_im() to calculate the normalization to absolute scattering intensities; correct_image(): reorganize the logical structure of the decision which corrections are to be made, and add the call to normint_im() if NORM_INT is set. Update 28/06/2001 R. Wilcke (wilcke@esrf.fr) add routines set_bkgim() and set_floim() to set the values of BKG_IM and FLO_IM, which point to the background image and the floodfield image; change routine correct_image() by eliminating the background image and the floodfield image from the input arguments and modifying the code to use the new global variables BKG_IM and FLO_IM; removed declaration of variable one_spline (not used); andy_unloadspline(): return without action if spline == NULL. Update 26/06/2001 R. Wilcke (wilcke@esrf.fr) change the name of the variables XFILE and YFILE to XINFILE and YINFILE; add variables XOUTFILE and YOUTFILE for the names of files where the distortion correction values can be written to; andy_corr(): make the output of the distortion correction values dependent on "XOUTFILE && YOUTFILE" instead of "verbose == 2" and use the filenames in XOUTFILE and YOUTFILE instead of the fixed names "cor_x.edf" and "cor_y.edf"; add new function set_xycorout() to set the value of XOUTFILE and YOUTFILE. Update 25/06/2001 R. Wilcke (wilcke@esrf.fr) remove variable DO_XYFILE; andy_corr(): replace test for DO_XYFILE with test for "XFILE && YFILE"; move declaration of variable "verbose" here from "spd.h"; change type of BKG_CONST from "int" to "float"; remove declaration of the parameters for the geometrical method (CURV_RADIUS, XCENTER and YCENTER) and all related code. This method is no longer used; make_grid(): set the variable CURV_RADIUS in this function to the old default value of CURV_RADIUS = 270000/180; add new functions: - set_verbose() to set the value of "verbose"; - set_overflow() to set the value of IMAGE_OVER and IMAGE_OVER_SET; - set_dummy() to set the value of "Dummy"; - set_actrad() to set the value of ACTIVE_R; - set_slinfil() to set the value of FILENAME; - set_xycorin() to set the value of XFILE and YFILE; - set_xysize() to set the value of XSIZE and YSIZE; - get_xsize() to get the value of XSIZE; - get_ysize() to get the value of YSIZE; - set_bkgconst() to set the value of BKG_CONST; - set_dospd() to set the value of DO_SPD; - set_dolater() to set the value of DO_LATER; - set_doflat() to set the value of DO_FLAT; Update 12/06/2001 R. Wilcke (wilcke@esrf.fr) change variable name "DUMMY" to "Dummy" to avoid name conflict with macro DUMMY(). Update 14/05/2001 R. Wilcke (wilcke@esrf.fr) andy_corr(): replace SHM_FLOAT by MFloat in the call to save_esrf_file(). Update 03/05/2001 R. Wilcke (wilcke@esrf.fr) andy_fcorr(): replace SHM_FLOAT by MFloat in the call to read_esrf_file(). Update 26/04/2001 R. Wilcke (wilcke@esrf.fr) prepare_flood(): add the possibility that the input image is already of type "float", and just invert the image in this case. Update 14/02/2001 R. Wilcke (wilcke@esrf.fr) divide_im() and divide_insito_im(): remove the code that tests for pixel values >= IMAGE_OVER and replaces them with IMAGE_OVER_SET. This is no longer needed for "float" arrays; correct_image(): remove the calls to "mark_overflow_nocorr()" for the cases where the floodfield correction is done before before the distortion correction, and call "mark_overflow()" with the original source image. This is a consequence of the changes to "divide_im()" and "divide_insito_im()" described above; mark_overflow_nocorr() and mark_overflow(): to mark pixels with overflow in the output images, use the value DUMMY if it is set (i.e., != 0.), otherwise IMAGE_OVER_SET. Update 13/02/2001 R. Wilcke (wilcke@esrf.fr) subtract_im(): allow the background subtraction to yield negative values in the output image (they were set =0 before), and remove the diagnostic message about negative values; clean up global variables: remove C_XSIZE, C_YSIZE; added global variable DUMMY; undistort_im(): set the value of empty pixels in the target image to DUMMY (they were set to 0. before). Update 06/02/2001 R. Wilcke (wilcke@esrf.fr) changed the arguments to the "BISPEV" call (they must all be pointers because of the FORTRAN calling convention). Update 02/02/2001 R. Wilcke (wilcke@esrf.fr) divide_insito_im() and divide_im(): change routines to work with an input image of type "float": convert the corresponding function arguments and local variables to type "float" and change code to operate on floats; substract_im(): change name to subtract_im() and convert routine to work with an input image of type "float": convert the corresponding function arguments and local variables to type "float" and change code to operate on floats; mark_overflow() and mark_overflow_nocorr(): change routines to work with an input image of type "float": convert the corresponding function arguments and local variables to type "float" and change code to operate on floats; undistort_im(): change routine to work with an input image of type "float": convert the corresponding function arguments and local variables to type "float" and change code to operate on floats; remove function undistort_im_plus(); correct_image(): change routine to work with an input image of type "float": convert the corresponding function arguments and allocate "float" memory space for "lut_d->temp_im"; Update 17/01/2001 R. Wilcke (wilcke@esrf.fr) andy_calcspline(): replaced call to E02DEF() by call to BISPEV(); changed type of arguments accordingly from "double" to "float" everywhere in the program. Update 10/01/2001 R. Wilcke (wilcke@esrf.fr) mark_overflow() and gtest(): replaced call to pxcorr() by call to andy_calcspline(); removed routine pxcorr() and all references to E02DEF(). */ #include "spd.h" static char *DISTFILE = NULL; static char *XINFILE = NULL; static char *YINFILE = NULL; static char *MINFILE = NULL; static char *XOUTFILE = NULL; static char *YOUTFILE = NULL; static char *MOUTFILE = NULL; static unsigned long IMAGE_OVER = 0; static unsigned long IMAGE_OVER_SET = 0; static int DO_DARK = 0; static int DO_SPD = 1; static int DO_PREROT = 0; static int NORM_PREROT = 1; static int DO_FLAT = 0; static int NORM_INT = 0; static int XSIZE = 1024; /* x-size of the src image */ static int YSIZE = 1024; /* y-size of the src image */ static unsigned long DSTRTVAL = 0; static float ACTIVE_R = 0.; static float DRK_CONST = 0.; static float INPCONST = 0.; static float INPEXP = 1.; static float exptab[USHRT_MAX + 1]; static float INPFACT = 1.; static float BCKGCONST = 0.; static float BCKGFACT = 1.; static float Dummy = 0.; static float INP_MAX = 0.; static float INP_MIN = 0.; static float NORMFACT = 1.; static float *DRK_IM = NULL; static float *FLO_IM = NULL; static float *BCKG_IM = NULL; static float psizex = -1.,psizey = -1.; //+++++++++++ used???? /* * Declare structure for data header. The "init" member is by C default * initialized to 0, which indicates that the structure values are not set. */ static struct data_head img_head[MAXTYP]; static int LUT_INVALID = 1; static int SPLINE_INVALID = 1; static long *fldumlst = NULL; static long *drdumlst = NULL; static float *X_COR = NULL; static float *Y_COR = NULL; static float *M_COR = NULL; /* * The variable SDX_PREROT keeps the type of the * distortion arrays. The value is set to * DO_PREROT when the distortion arrays are * created with spd_corr. When DO_SPD is set * and SDX_PREROT differs from DO_PREROT the * look-up table is invalid and must be * recalculated. */ static int SDX_PREROT = -1; /* ANDY_CORR definitions BEGIN */ #ifdef UNDERSCORE #define BISPEV bispev_ void bispev_(); #else #ifdef UPPERCASE #define BISPEV BISPEV void BISPEV(); #else #define BISPEV bispev void bispev(); #endif /* UPPERCASE */ #endif /* UNDERSCORE */ struct spd_spline { int dx_xknots; int dx_yknots; double xcor_size; double xcenter; float *xlambda; float *xmu; float *xpars; int dy_xknots; int dy_yknots; double ycor_size; double ycenter; float *ylambda; float *ymu; float *ypars; double grid_space; float *wrk; int *iwrk; int maxspace; double reg_x0; /* Valid region from to */ double reg_x1; double reg_y0; double reg_y1; float bsize_1,bsize_2; }; static struct spd_spline *spline = NULL; /*============================================================================== * Reads a number of values from the input file and fills them into an array. * * Input : fp: stream pointer referring to the input file * no: the number of values to read * arr: pointer to the array where the values will be stored * Output: none * Return: 0 if requested number of values was read * 1 otherwise */ int spd_readarray(FILE *fp,int no,float *arr) { int i, j, idx=0; char *line,*s; char dammed_minus_copy[512]; while((line = spd_fgets(fp)) != NULL) { /* * Handles the special case that the input might contain tokens that are * separated by a "-" (minus) instead of a blank, but the "-" is actually * part of the next token (e.g. 2345-4567). Insert a blank before the "-". */ for(i=0, j=0; i <= strlen(line); i++) { if(i && line[i] == '-' && line[i-1] != ' ') dammed_minus_copy[j++] = ' '; dammed_minus_copy[j++] = line[i]; } line = dammed_minus_copy; for(i=0; i< VALUES_PERLINE; i++) { if((s = (char*) strlib_tok(line," ")) == NULL) { prmsg(ERROR,("not enough values in file\n")); return(1); } line = NULL; arr[idx++] = atof(s); if(idx == no) return(0); } } prmsg(ERROR,("unexpected end of file\n")); return(1); } /* spd_readarray */ /*============================================================================== * Searches the input file for a line containing a specified keyword. * * Input : fp: stream pointer referring to the input file * keyword: the keyword to search for * Output: none * Return: 0 if found * 1 otherwise */ int spd_findkeyword(FILE *fp,char *keyword) { char *line; while((line = spd_fgets(fp)) != NULL) { if((char *)strstr(line,keyword) != NULL) return(0); } prmsg(ERROR,("missing keyword \"%s\" in file \n",keyword)); return(1); } /* spd_findkeyword */ /*============================================================================== * Reads the spline function parameters from a file and fills them into the * corresponding elements of a newly created spd_spline structure. * * Memory for the arrays of the structure is allocated by the function itself * and can be freed by a call to spd_unloadspline(). * * Input : distfile: name of the file that contains the spline function * parameters * Output: none * Return: if successful: pointer to the created spline function structure * else: NULL */ struct spd_spline *spd_loadspline(char *distfile) { FILE *fp; char *line; struct spd_spline *spline; int nopar,maxspace; if(distfile == NULL) { prmsg(ERROR,("spd_loadspline: file name empty\n")); return(NULL); } if((fp = fopen(distfile,"r")) == NULL) { prmsg(ERROR,("spd_loadspline: cannot read <%s> (open failed)\n",distfile)); return(NULL); } if((spline = (struct spd_spline *)pmalloc(sizeof(struct spd_spline))) == NULL) goto memerror; /* * Read in binning size in pixels. * This is an optional keyword; if it is not found, its value is 1. Just * rewind the file and continue with the other keywords. */ spline->bsize_1 = 1.; spline->bsize_2 = 1.; if(spd_findkeyword(fp,"BINNING")) { rewind(fp); prmsg(MSG,("Binning size set to default = 1.\n")); } else if(((line = spd_fgets(fp)) == NULL) || (sscanf(line,"%f %f", &(spline->bsize_1),&(spline->bsize_2)) != 2)) goto readerror; /* Read in valid region in pixels */ if(spd_findkeyword(fp,"VALID REGION")) goto readerror; if(((line = spd_fgets(fp)) == NULL) || (sscanf(line,"%lf %lf %lf %lf", &(spline->reg_x0),&(spline->reg_y0),&(spline->reg_x1),&(spline->reg_y1)) != 4)) goto readerror; if(spd_findkeyword(fp,"GRID SPACING")) goto readerror; if(((line = spd_fgets(fp)) == NULL) || (sscanf(line,"%lf %lf %lf", &(spline->grid_space),&(spline->xcor_size),&(spline->ycor_size)) != 3)) goto readerror; /* Read in X Distortion data */ if(spd_findkeyword(fp,"X-DISTORTION")) goto readerror; if(((line = spd_fgets(fp)) == NULL) || (sscanf(line,"%d %d",&(spline->dx_xknots),&(spline->dx_yknots)) != 2)) goto readerror; nopar = (spline->dx_yknots-4) * (spline->dx_xknots-4); if(!(spline->xpars = (float *)pmalloc(sizeof(float) * nopar)) || !(spline->xmu = (float *)pmalloc(sizeof(float) * spline->dx_yknots)) || !(spline->xlambda = (float *)pmalloc(sizeof(float) * spline->dx_xknots))) goto memerror; if(spd_readarray(fp,spline->dx_xknots,spline->xlambda)) goto readerror; if(spd_readarray(fp,spline->dx_yknots,spline->xmu)) goto readerror; if(spd_readarray(fp,nopar,spline->xpars)) goto readerror; /* Read in Y Distortion data */ if (spd_findkeyword(fp,"Y-DISTORTION")) goto readerror; if(((line = spd_fgets(fp)) == NULL) || (sscanf(line,"%d %d",&(spline->dy_xknots),&(spline->dy_yknots)) != 2)) goto readerror; nopar = (spline->dy_yknots-4) * (spline->dy_xknots-4); if(!(spline->ypars = (float *)pmalloc(sizeof(float) * nopar)) || !(spline->ymu = (float *)pmalloc(sizeof(float) * spline->dy_yknots)) || !(spline->ylambda = (float *)pmalloc(sizeof(float) * spline->dy_xknots))) goto memerror; maxspace = 3000 * 5 * 2; spline->maxspace = maxspace; if(!(spline->wrk = (float *)pmalloc(sizeof(float) * maxspace)) || !(spline->iwrk = (int *)pmalloc(sizeof(int) * maxspace))) goto memerror; if(spd_readarray(fp,spline->dy_xknots,spline->ylambda)) goto readerror; if(spd_readarray(fp,spline->dy_yknots,spline->ymu)) goto readerror; if(spd_readarray(fp,nopar,spline->ypars)) goto readerror; fclose(fp); return(spline); readerror: prmsg(ERROR,("spd_loadspline: error reading from file <%s>\n",distfile)); fclose(fp); return(NULL); memerror: prmsg(ERROR,("spd_loadspline: cannot allocate memory\n")); fclose(fp); return(NULL); } /* spd_loadspline */ /*============================================================================== * Free the buffers allocated for the input spline function structure. * * Input : spline: structure with the parameters for the spline function * Output: none * Return: none */ void spd_unloadspline(struct spd_spline *spline) { if(!spline) return; if(spline->xlambda) pfree(spline->xlambda); if(spline->xmu) pfree(spline->xmu); if(spline->xpars) pfree(spline->xpars); if(spline->ylambda) pfree(spline->ylambda); if(spline->ymu) pfree(spline->ymu); if(spline->ypars) pfree(spline->ypars); if(spline->wrk) pfree(spline->wrk); if(spline->iwrk) pfree(spline->iwrk); if(spline) pfree(spline); } /* spd_unloadspline */ /*============================================================================== * Computes the spline function values for x and y direction at the grid formed * by the input coordinate points. It will calculate dx, dy at all the * intersections of the px, py arrays. E.g. with px = [2,3] and py = [7,8] this * routine will calculate dx,dy for the 4 points ((2,7), (2,8), (3,7), (3,8)). * * Input : spline: structure with the parameters of the x and y spline * functions * nox, noy: number of points in x and y arrays (= size in x and in y) * px, py: arrays with the x and y coordinates * Output: dx, dy: arrays with the x and y spline values at the corresponding * (px,py) coordinate points (will be nox * noy points) * Return: 0 if no errors * -1 if no valid "spline" structure or memory allocation error * error code from BISPEV call otherwise */ int spd_calcspline(struct spd_spline *spline,int nox,int noy,float px[],float py[], float dx[],float dy[]) { int ifail=0,i,j; int lwrk = spline->maxspace; int liwrk = spline->maxspace; int ideg = 3; float *ddx,*ddx_p; float *dx_p = dx, *dy_p = dy; if(spline == NULL) { prmsg(ERROR,("no valid spline structure in pxcalcgrid\n")); return(-1); } if((ddx = (float *)pmalloc(nox * noy * sizeof(float))) == NULL) { prmsg(ERROR,("no memory in pxcalcgrid\n")); return(-1); } /* * Note that BISPEV() is a FORTRAN routine, and that the FORTRAN calling * convention expects all arguments to be pointers. Thus even the constants * used for the degree of the spline must be given as pointers to variables * (in this case the variable "ideg"). * * Furthermore, the storing convention of BISPEV() is that the y coordinate * index is increased fastest, whereas the "correct" package increases the x * coordinate index fastest. Thus the BISPEV() output array "ddx" has to * be reordered to agree with the "correct" storage convention. */ /* * Calculate corrections in x direction. */ BISPEV(spline->xlambda,&spline->dx_xknots,spline->xmu,&spline->dx_yknots, spline->xpars,&ideg,&ideg,px,&nox,py,&noy, ddx,spline->wrk,&lwrk,spline->iwrk,&liwrk,&ifail); /* * Reorder BISPEV() output to have x coordinate index increase fastest. */ for(j = 0; j < noy; j++) for(i = 0, ddx_p = ddx + j; i < nox; i++, ddx_p += noy) *dx_p++ = *ddx_p; if(ifail) prmsg(ERROR,("error %d in BISPEV\n",ifail)); /* * Calculate corrections in y direction. */ BISPEV(spline->ylambda,&spline->dy_xknots,spline->ymu,&spline->dy_yknots, spline->ypars,&ideg,&ideg,px,&nox,py,&noy, ddx,spline->wrk,&lwrk,spline->iwrk,&liwrk,&ifail); /* * Reorder BISPEV() output to have x coordinate index increase fastest. */ for(j = 0; j < noy; j++) for(i = 0, ddx_p = ddx + j; i < nox; i++, ddx_p += noy) *dy_p++ = *ddx_p; pfree(ddx); if(ifail) prmsg(ERROR,("error %d in BISPEV\n",ifail)); return(ifail); } /* spd_calcspline */ /*============================================================================== */ char *spd_fgets(FILE *fp) { static char buf[1024]; return fgets(buf,1024,fp); } /* spd_fgets */ /*============================================================================== * Free the x and y buffers as well as the buffers for the corrected * coordinates. * * Buffers that have not been allocated will be silently ignored. * * Input : cor_x, cor_y: pointers to the buffers for the corrected coordinates * Output: none * Return: 0 */ int spd_free_buffers(float *cor_x,float *cor_y) { #if WASTE4_FORSPEED spd_unloadspline(spline); spline = NULL; #endif /* WASTE4_FORSPEED */ if(cor_x) { pfree((void *)cor_x); cor_x = NULL; } if(cor_y) { pfree((void *)cor_y); cor_y = NULL; } return(0); } /*============================================================================== * Sets new values for the pixels outside the active area. The active area is * a circle with radius "r", its center is at (xcen, ycen). * * The pixels in the image belong to one of the following five categories: * - pixels that are inside the active area; * - pixels that are in their x-coordinate outside the active area, without * regard to their y-coordinate (called "pixels to the left or right of the * active area"); * - pixels that are in their y-coordinate outside the active area, but in * their x-coordinate inside the active area (called "pixels above or below * the active area"). * * The values of the pixels inside the active area are not changed. * * All pixels to the left (right) of the active area are assigned the pixel * value of the leftmost (rightmost) pixel of the active area, i.e. the pixel * with the coordinates (xcen - r, 0) (or, for the right side, (xcen + r, 0)). * * All pixels above (below) the active area are assigned the pixel value of * that pixel on the border of the active area that is exactly below (above) * them, i.e. the pixel that has the same x-coordinate and is situated on * the circumference of the arcive area circle below (above). * * Input : image: array with the corrected coordinate values (x or y) for * the input image * xcen, ycen: x and y coordinates of the center of the active area * r: radius of the active area * Output: image: input array with redefined values for pixels outside the * active area * Return: 0 */ int spd_active_area(float *image,int xcen,int ycen,int r) { int x,y; float r2 = r * r; float dx,dy; prmsg(DMSG,("Setting pixel outside active area (r = %d) \n",r)); for(x = 0; x < XSIZE; x++) { dx = x - xcen; if(dx * dx < r2) { /* * Set pixel values above and below the active area. */ dy = sqrt(r2 - dx * dx); for(y = 0; y < (int)(ycen - dy); y++) image[x + y * XSIZE] = image[x + ((int)(ycen - dy)) * XSIZE]; for(y = (int)(ycen + dy); y < YSIZE; y++) image[x + y * XSIZE] = image[x + ((int)(ycen + dy)) * XSIZE]; } else { /* * Set pixel values left and right of the active area. */ if(dx > 0) for(y = 0; y < YSIZE; y++) image[x + y * XSIZE]= image[xcen + r + ycen * XSIZE]; else for(y = 0; y < YSIZE; y++) image[x + y * XSIZE]= image[xcen - r + ycen * XSIZE]; } } return(0); } /* spd_active_area */ /*============================================================================== * Obtains for all pixel points and for all lines the corrected coordinates * from a set of spline function parameters that are read from the spatial * distortion correction file. * * If any of the requested input files cannot be found, an error is returned. * * Output: cor_x, cor_y: arrays with the corrected coordinate values for the * input image * Return: 0 if successful * -1 else */ int spd_scorr(float **cor_x,float **cor_y) { static float *x_buf = NULL,*y_buf = NULL; int ix,iy,xreg,yreg; float *px,*py,*pcor_xnw,*pcor_ynw; struct data_head *sdx_head = &img_head[SDXTYP],*sdy_head = &img_head[SDYTYP]; prmsg(DMSG,("spd_fcorr: create displacements from splines\n")); /* * Get a new set of spline function parameters, if necessary. This includes * freeing the old buffers in the spline function structure, allocating new * buffers and reading the parameters from a file into the structure elements. * * This has to be done at the first pass through the program and also every * time the spatial distortion file is changed (then SPLINE_INVALID == 1). */ if(SPLINE_INVALID || spline == NULL) { if(spline != NULL) { spd_unloadspline(spline); spline = NULL; } bench(NULL); if((spline = spd_loadspline(DISTFILE)) == NULL) goto spd_scorr_error; SPLINE_INVALID = 0; /* * Save the corrected x- and y-pixel sizes. * * They will be put (by undistort_im()) in the data header structure for all * corrected images that are produced with this set of spline coefficients. * * Note that the units for these sizes are micro-meter in the spatial * distortion file, and meter in the data header. */ psizex = spline->xcor_size / 1000000.; psizey = spline->ycor_size / 1000000.; prmsg(DMSG,("XDist: XKnots: %d YKnots: %d YDist: XKnots: %d YKnots: %d\n", spline->dx_xknots,spline->dx_yknots,spline->dy_xknots,spline->dy_yknots)); prmsg(DMSG,("Size: [%4.0f %4.0f] [%4.0f %4.0f]\n",spline->reg_x0, spline->reg_y0,spline->reg_x1,spline->reg_y1)); } /* * Allocate buffers for the input x- and y-coordinate arrays. Make them one * element bigger than the "Size" to allow for the calculation of the left * and right (lower and upper) corners for each pixel. */ xreg = spline->reg_x1 - spline->reg_x0 + 1; yreg = spline->reg_y1 - spline->reg_y0 + 1; if((x_buf = (float *)pmalloc(xreg * sizeof(float))) == NULL || (y_buf = (float *)pmalloc(yreg * sizeof(float))) == NULL) prmsg(FATAL,("no memory for buffers in spd_scorr\n")); /* * Fill the x coordinate array with the x-values of the input image (all * integer values between the smallest and largest x). * * Then do the same for y. */ for(px = x_buf,ix = spline->reg_x0; ix <= spline->reg_x1; ix++) *(px++) = (float)ix; for(py = y_buf,iy = spline->reg_y0; iy <= spline->reg_y1; iy++) *(py++) = (float)iy; /* * Allocate buffers for the corrected x- and y-coordinate arrays. */ get_buffer(-1,NULL,(void **)cor_x,&yreg,&xreg,SDXTYP); sdx_head->PSize_1 = spline->xcor_size / 1000000.; sdx_head->PSize_2 = spline->ycor_size / 1000000.; sdx_head->BSize_1 = spline->bsize_1; sdx_head->BSize_2 = spline->bsize_2; sdx_head->Offset_1 = spline->reg_x0 - 0.5; sdx_head->Offset_2 = spline->reg_y0 - 0.5; sdx_head->init = FL_PSIZ1 | FL_PSIZ2 | FL_BSIZ1 | FL_BSIZ2 | FL_OFFS1 | FL_OFFS2; set_headval(*sdx_head,SDXTYP); get_buffer(-1,NULL,(void **)cor_y,&yreg,&xreg,SDYTYP); *sdy_head = *sdx_head; /* * For all points of the image (i.e. all combinations of values in x_buf and * y_buf) obtain the displacement values for the x and y coordinates using * spline functions (one for the x and the other for the y coordinate) and * return them in cor_x and cor_y. */ spd_calcspline(spline,xreg,yreg,x_buf,y_buf,*cor_x,*cor_y); pfree(x_buf); pfree(y_buf); x_buf = y_buf = NULL; /* * If there is an active area of the detector defined, do not correct the * coordinates for the pixels outside the active area. * * More precisely, set the coordinate corrections for all those pixels * identical to the corrections for the pixels on the edge of the active * area. This means that there is a steady transition from the coordinates * inside to the ones outside the active area. */ if(ACTIVE_R) { spd_active_area(*cor_x,XSIZE/2,YSIZE/2,ACTIVE_R); spd_active_area(*cor_y,XSIZE/2,YSIZE/2,ACTIVE_R); } /* * Map the buffers and headers of the displacement values so that their * geometry is identical to the one for the input source image. */ if(map_imag(*cor_x,(void **)&pcor_xnw,-1.,-1.,SDXTYP) >= 0 && map_imag(*cor_y,(void **)&pcor_ynw,-1.,-1.,SDYTYP) >= 0) { clean_buffer((void **)cor_x,SDXTYP,1); clean_buffer((void **)cor_y,SDYTYP,1); *cor_x = pcor_xnw; *cor_y = pcor_ynw; } else { prmsg(ERROR,("error mapping x- or y-distortion buffer\n")); goto spd_scorr_error; } return(0); spd_scorr_error: return(-1); } /* spd_scorr */ /*============================================================================== * Gets for all pixel points in the input image the corrected coordinates from * two input files (one for the x, the other for the y coordinates). * * If any of the two input files cannot be read correctly, the routine returns * an error. * * Input : x0, x1, y0, y1: minimal and maximal x and y coordinates of the input * image (x0 = left border, x1 = right border,...) * Output: cor_x, cor_y: arrays with the corrected coordinate values for the * input image * Return: 0 if successful * -1 else */ int spd_fcorr(float **cor_x,float **cor_y,int x0,int x1,int y0,int y1) { unsigned long reqflg = FL_PSIZ1 | FL_PSIZ2; int cols = x1 - x0 + 1,rows = y1 - y0 + 1; prmsg(DMSG,("spd_fcorr: read displacements from files\n")); /* * Read the x and y distortion values from the corresponding files, if they * are defined. * * Get also the corrected x- and y-pixel sizes from these files. * They will be put (by undistort_im()) in the data header structure for all * corrected images that are produced with this set of correction values. */ if(XINFILE && YINFILE) { if(get_buffer(-1,XINFILE,(void **)cor_x,&rows,&cols,SDXTYP) == -1) { prmsg(ERROR,("error reading file %s\n",XINFILE)); goto spd_fcorr_error; } if((img_head[SDXTYP].init & reqflg) != reqflg) psizex = psizey = -1.; else { psizex = img_head[SDXTYP].PSize_1; psizey = img_head[SDXTYP].PSize_2; } if(get_buffer(-1,YINFILE,(void **)cor_y,&rows,&cols,SDYTYP) == -1) { prmsg(ERROR,("error reading file %s\n",YINFILE)); goto spd_fcorr_error; } if((img_head[SDYTYP].init & reqflg) != reqflg) psizex = psizey = -1.; if(psizex != img_head[SDYTYP].PSize_1 || psizey != img_head[SDYTYP].PSize_2) psizex = psizey = -1.; } else { prmsg(ERROR,("no file(s) specified for x or y distortion values\n")); goto spd_fcorr_error; } SPLINE_INVALID = 0; return(0); spd_fcorr_error: return(-1); } /* spd_fcorr */ /*============================================================================== * Read the multiplication factors for each pixel after distortion correction * from a file. * * If MINFILE is set the multiplication array is read from a file, otherwise * it is allocated and initialized with 1. * * Input : x0, x1, y0, y1: minimal and maximal x and y coordinates of the input * image (x0 = left border, x1 = right border,...) * Output: cor_m: multiplication array from file or initialized with 1. * Return: 0 if successful * -1 else */ int spd_mcorr(float **cor_m,int x0,int x1,int y0,int y1) { int cols = x1 - x0,rows = y1 - y0; /* * Create the multiplication array or read it from a file. */ if(MINFILE) { if(get_buffer(-1,MINFILE,(void **)cor_m,&rows,&cols,SDMTYP) == -1) { prmsg(ERROR,("spd_mcorr: error reading file %s\n",MINFILE)); goto spd_mcorr_error; } } else { float *pbuf, *pend; if(get_buffer(-1,NULL,(void **)cor_m,&rows,&cols,SDMTYP) == -1) { prmsg(ERROR,("spd_mcorr: error creating multiplication array\n")); goto spd_mcorr_error; } pbuf = (float *) *cor_m; pend = pbuf + (cols * rows); /* * fill buffer with 1. */ while (pbufinit & paramsneeded; if ( paramsgiven == paramsneeded ) { /* * The sdx and sdy images are mapped to the edges of the * source image (Dim = Dim_src+1, Offset = Offset_src-0.5) */ float *px,*py; /* Pixel indices */ long i_10, i_20; float f_10, f_20; long i_11, i_21; float f_11, f_21; /* Array reference system */ float I0Off_1,I0Ps_1; float I0Off_2,I0Ps_2; float I1Off_1,I1Ps_1; float I1Off_2,I1Ps_2; /* Tangens reference system */ float Off_10, Off_20; float Off_11, Off_21; float Ps_10, Ps_20; float Ps_11, Ps_21; /* Header parameters */ float I0Offset_1,I0PSize_1,I0Center_1,I0Distance; float I0Offset_2,I0PSize_2,I0Center_2; long I1Dim_1, I1Dim_2; float I1Offset_1,I1PSize_1,I1Center_1,I1Distance; float I1Offset_2,I1PSize_2,I1Center_2; float I1Rot_1, I1Rot_2, I1Rot_3; /* Waxs parameters */ WParams I0wparams, I1wparams; struct sx_params sx; int err; char errbuf[1024]; I1Dim_1 = sdx_head->Dim_1; I1Dim_2 = sdx_head->Dim_2; I1Offset_1 = sdx_head->Offset_1; I1Offset_2 = sdx_head->Offset_2; I1PSize_1 = sdx_head->PSize_1; I1PSize_2 = sdx_head->PSize_2; I1Center_1 = sdx_head->PreCenter_1; I1Center_2 = sdx_head->PreCenter_2; I1Distance = sdx_head->PreSamplDis; I1Rot_1 = sdx_head->PreDetRot_1; I1Rot_2 = sdx_head->PreDetRot_2; I1Rot_3 = sdx_head->PreDetRot_3; I0Offset_1 = I1Offset_1; I0Offset_2 = I1Offset_2; I0PSize_1 = I1PSize_1; I0PSize_2 = I1PSize_2; sx_init( &sx ); sx.pix1.V = I1PSize_1; sx.pix1.I = 1; sx.pix2.V = I1PSize_2; sx.pix2.I = 1; sx.cen1.V = I1Center_1; sx.cen1.I = 1; sx.cen2.V = I1Center_2; sx.cen2.I = 1; sx.dis.V = I1Distance; sx.dis.I = 1; sx.rot1.V = I1Rot_1; sx.rot1.I = 1; sx.rot2.V = I1Rot_2; sx.rot2.I = 1; sx.rot3.V = I1Rot_3; sx.rot3.I = 1; if (sx_tf_params ( &sx, &sx, 0 , 0, &err )) { if (sx.bcen1.I && sx.bcen2.I && sx.bdis.I ) { I0Center_1 = sx.bcen1.V; I0Center_2 = sx.bcen2.V; I0Distance = sx.bdis.V; } else { prmsg(ERROR,("spd_rotcorr: Cannot calculate %s %s %s.\n", sx.bcen1.I?"":"BeamCenter_1", sx.bcen2.I?"":"BeamCenter_2", sx.bdis.I?"":"BeamDistance")); goto spd_rotcorr_error; } } else { prmsg(ERROR,("spd_rotcorr: sx_tf_params %s.\n", sx_errval2str ( errbuf, 1024, err ))); goto spd_rotcorr_error; } TANGENSREF(Off_10,Ps_10,I0Offset_1,I0PSize_1,I0Center_1,I0Distance); TANGENSREF(Off_20,Ps_20,I0Offset_2,I0PSize_2,I0Center_2,I0Distance); TANGENSREF(Off_11,Ps_11,I1Offset_1,I1PSize_1,I1Center_1,I1Distance); TANGENSREF(Off_21,Ps_21,I1Offset_2,I1PSize_2,I1Center_2,I1Distance); // TANGENSREF => K=1; waxs_Init ( &I0wparams, 1.0, 0.0, 0.0, 0.0 ); waxs_Init ( &I1wparams, 1.0, I1Rot_1, I1Rot_2, I1Rot_3 ); // The displacements are expressed in array coordinates // calculate I0 and I1 array coordinates ARRAYREF(I0Off_1,I0Ps_1); ARRAYREF(I0Off_2,I0Ps_2); ARRAYREF(I1Off_1,I1Ps_1); ARRAYREF(I1Off_2,I1Ps_2); // loop over the input image px = *cor_x; py = *cor_y; for (i_21=0;i_21Dim_1; Dim_2 = sdm_head->Dim_2; Off_1 = Off_10+0.5; Ps_1 = Ps_10; // Tangens reference system Off_2 = Off_20+0.5; Ps_2 = Ps_20; // Tangens reference system tmp = I1Distance*I1PSize_1*I1PSize_2; if (fabs(tmp)>eps) { /* * image after prerotation correction */ float I0rd20, I0rd2, I0rd3; float I0factor, I0fac; float I0N_1, I0N_2; /* * image before prerotation correction */ float I1rd20, I1rd2, I1rd3; float I1factor, I1fac; float I1N_1, I1N_2; float *pcor_m=*cor_m; I1fac= 1./tmp; tmp = I0Distance*I1PSize_1*I1PSize_2; if (fabs(tmp)>eps) { I0fac= 1./tmp; // loop over the output image for (i_20=0;i_20eps) { *pcor_m *= I1factor / I0factor; } // else invalid number } // if (!W1.status) // else invalid number pcor_m++; } /* for i_10 ... */ } /* for i_20 ... */ } // else all invalid } // else all invalid } /* if(*cor_m != NULL) */ } else { long unsigned missing = paramsneeded & ~paramsgiven; prmsg(ERROR,("spd_rotcorr: Missing required prerotation parameters (%x)\n", missing)); pr_headval(stdout, SDXTYP); goto spd_rotcorr_error; } return(0); spd_rotcorr_error: return(-1); } /* spd_rotcorr */ /*============================================================================== * Obtains for all pixel points between x0 and x1 (included) and for all * lines from y0 to y1 (included) the corrected coordinates. * * The corrected coordinates are either directly obtained from 2 input files * that contain for each pixel the correction values in the x- and in the y- * direction, or they are calculated from a set of spline function parameters * that are read from the spatial distortion correction file. * In addition, the multiplication array cor_m is always created and updated * together with cor_x and cor_y. * * If any of the requested input files cannot be found, an error is returned. * * DO_SPD controls the distortion/prerotation correction * 0: no distortion/prerotation * >0: distortion/prerotation correction * * DO_PREROT controls the rotation correction: * 0: no prerotation correction * 1: prerotation correction after distortion correction * 2: prerotation correction without distortion correction * * Input : x0, x1, y0, y1: minimal and maximal x and y coordinates of the input * image * Note: these input arguments are not used if the * correction is calculated from the spline function * parameters; then the spatial distortion file provides * this information. * Output: cor_x, cor_y: arrays with the corrected coordinate values for the * input image * cor_m: array with multiplication factors for the corrected image * image. If DO_SPD is set cor_m is always created. cor_m remains * valid as long as cor_x and cor_y are valid. * Return: 0 if successful * -1 else */ int spd_corr(float **cor_x,float **cor_y,float **cor_m, int x0,int x1,int y0,int y1) { if(*cor_x) pfree(*cor_x); if(*cor_y) pfree(*cor_y); if(*cor_m) pfree(*cor_m); *cor_x = *cor_y = *cor_m = NULL; /* * If the corrected image coordinates are to be determined from files which * contain directly the x- and y-direction displacement values, use * spd_fcorr(), otherwise calculate them from splines and use spd_scorr(). * Both routines do their own freeing and allocating of buffers. */ if (DO_SPD) { /* * create multiplication array cor_m */ if (spd_mcorr(cor_m,x0,x1,y0,y1)) goto spd_corr_error; /* * skip distortion correction when DO_PREROT is 2 */ if (DO_PREROT!=2) { if(XINFILE && YINFILE) { if (spd_fcorr(cor_x,cor_y,x0,x1,y0,y1)) goto spd_corr_error; } else { if (spd_scorr(cor_x,cor_y)) goto spd_corr_error; } } /* * pre-rotation correction */ if (DO_PREROT) { if (spd_rotcorr(cor_x,cor_y,cor_m,x0,x1,y0,y1)) goto spd_corr_error; } SDX_PREROT = DO_PREROT; /* * Save the final correction values in x and y direction to the two files * the names of which are in XOUTFILE and YOUTFILE. These files can then * be read and the correction values used by the correction program at * the next execution, or they can be inspected with a program to read * edf files (e.g. dis). */ if(XOUTFILE && YOUTFILE) { put_buffer(XOUTFILE,(void **)cor_x, img_head[SDXTYP].Dim_2,img_head[SDXTYP].Dim_1,SDXTYP); put_buffer(YOUTFILE,(void **)cor_y, img_head[SDYTYP].Dim_2,img_head[SDYTYP].Dim_1,SDYTYP); } SDX_PREROT = DO_PREROT; if(MOUTFILE) { put_buffer(MOUTFILE,(void **)cor_m, img_head[SDMTYP].Dim_2,img_head[SDMTYP].Dim_1,SDMTYP); } } /* if (DO_SPD) */ return(0); spd_corr_error: return(-1); } /* spd_corr */ /*============================================================================== * Obtains the corrected (resx,resy) coordinate values for the (ix,iy) input * image coordinate point. * * To speed up the calculation, this routine will calculate the whole image at * the first call and for all subsequent calls just get the calculated values. * * If the corrected values cannot be obtained, the routine returns an error. * * Input : ix, iy: x and y coordinate of a pixel in the input image * Output: resx, resy: corrected x and y coordinate of the input pixel * Return: 0 if successful * -1 else */ int spd_func(int ix,int iy,float *resx,float *resy) { int idx; float xcor = 0,ycor = 0; double x,y; x = (double)ix; y = (double)iy; if(ix > XSIZE) ix = XSIZE; else if(ix < 0) ix = 0; if(iy > YSIZE) iy = YSIZE; else if(iy < 0) iy = 0; /* * Calculate the arrays with the corrected x and y image coordinates if * necessary, then get the requested values from the arrays. */ if(X_COR == NULL) if(spd_corr(&X_COR,&Y_COR,&M_COR,0,XSIZE,0,YSIZE) != 0) goto spd_func_error; idx = iy * (XSIZE + 1) + ix; xcor = X_COR[idx]; ycor = Y_COR[idx]; *resx = x + xcor; *resy = y + ycor; return(0); spd_func_error: return(-1); } /* spd_func */ /* ANDY_CORR definitions END */ /*============================================================================== * Gets the values of the user-definable header parameters' structure. * * The image header structure selected by the input parameter "type" is returned * in the structure pointed to by the argument "outhead". The member "init" of * the structure contains the "OR"ed flags of all the header keywords that have * been initialized. * * Default value if this structure array element has never been initialized by * the user (i.e., if set_headval() has never been called for the structure * with index "type"): "init" = 0. However, the CORTYP structure needs not to be * initialized by the user, as its values will be set from the SRCTYP structure. * Thus the CORTYP structure is initialized if the SRCTYP structure has been * initialized. * * See the declaration of the "img_head" structure array for the values that * "type" can have. * * Input : type: index of the structure array element to be returned * Output: outhead: structure with the values of the structure "img_head[type]" * Return: -1 if "type" has an illegal value * 0 otherwise */ int get_headval(struct data_head *outhead,int type) { if(type <= 0 || type >= MAXTYP) return(-1); *outhead = img_head[type]; return(0); } /*============================================================================== * Print the initialized values of the user-definable header parameters' structure. * * Input : out: output file pointer type: index of the structure array element to be returned * Return: -1 if "type" has an illegal value * 0 otherwise */ int pr_headval(FILE *out, int type) { int status=0; struct data_head user_head; if ( status=get_headval(&user_head, type) ) return(status); fprintf(out,"Header of %s image\n",typestr[type]); if (user_head.init & FL_ORIEN) fprintf(out,"FL_ORIEN=%ld\n",user_head.Orientat); if (user_head.init & FL_DUMMY) fprintf(out,"FL_DUMMY=%.4g\n",user_head.Dummy); if (user_head.init & FL_DDUMM) fprintf(out,"FL_DDUMM=%.4g\n",user_head.DDummy); if (user_head.init & FL_OFFS1) fprintf(out,"FL_OFFS1=%.4g\n",user_head.Offset_1); if (user_head.init & FL_OFFS2) fprintf(out,"FL_OFFS2=%.4g\n",user_head.Offset_2); if (user_head.init & FL_PSIZ1) fprintf(out,"FL_PSIZ1=%.4g\n",user_head.PSize_1); if (user_head.init & FL_PSIZ2) fprintf(out,"FL_PSIZ2=%.4g\n",user_head.PSize_2); if (user_head.init & FL_INTE0) fprintf(out,"FL_INTE0=%s\n",user_head.Intens_0); if (user_head.init & FL_INTE1) fprintf(out,"FL_INTE1=%s\n",user_head.Intens_1); if (user_head.init & FL_CENT1) fprintf(out,"FL_CENT1=%.4g\n",user_head.Center_1); if (user_head.init & FL_CENT2) fprintf(out,"FL_CENT2=%.4g\n",user_head.Center_2); if (user_head.init & FL_SAMDS) fprintf(out,"FL_SAMDS=%.4g\n",user_head.SamplDis); if (user_head.init & FL_WAVLN) fprintf(out,"FL_WAVLN=%.4g\n",user_head.WaveLeng); if (user_head.init & FL_TITLE) fprintf(out,"FL_TITLE=%s\n",user_head.Title); if (user_head.init & FL_TIME) fprintf(out,"FL_TIME=%s\n",user_head.Time); if (user_head.init & FL_EXTIM) fprintf(out,"FL_EXTIM=%s\n",user_head.ExpTime); if (user_head.init & FL_BSIZ1) fprintf(out,"FL_BSIZ1=%.4g\n",user_head.BSize_1); if (user_head.init & FL_BSIZ2) fprintf(out,"FL_BSIZ2=%.4g\n",user_head.BSize_2); if (user_head.init & FL_DIM1) fprintf(out,"FL_DIM1=%d\n",user_head.Dim_1); if (user_head.init & FL_DIM2) fprintf(out,"FL_DIM2=%d\n",user_head.Dim_2); if (user_head.init & FL_PRO) fprintf(out,"FL_PRO=%s\n",user_head.ProjTyp); if (user_head.init & FL_ROT1) fprintf(out,"FL_ROT1=%.4g\n",user_head.DetRot_1); if (user_head.init & FL_ROT2) fprintf(out,"FL_ROT2=%.4g\n",user_head.DetRot_2); if (user_head.init & FL_ROT3) fprintf(out,"FL_ROT3=%.4g\n",user_head.DetRot_3); if (user_head.init & FL_PRECEN1) fprintf(out,"FL_PRECEN1=%.4g\n",user_head.PreCenter_1); if (user_head.init & FL_PRECEN2) fprintf(out,"FL_PRECEN2=%.4g\n",user_head.PreCenter_2); if (user_head.init & FL_PREDIS) fprintf(out,"FL_PREDIS=%.4g\n",user_head.PreSamplDis); if (user_head.init & FL_PREROT1) fprintf(out,"FL_PREROT1=%.4g\n",user_head.PreDetRot_1); if (user_head.init & FL_PREROT2) fprintf(out,"FL_PREROT2=%.4g\n",user_head.PreDetRot_2); if (user_head.init & FL_PREROT3) fprintf(out,"FL_PREROT3=%.4g\n",user_head.PreDetRot_3); return(status); } /* pr_headval */ /*============================================================================== * Gets the value of the user-definable variable XSIZE. This is the number of * pixels in the x-direction. * * Default value if not defined by the user: 1024 * * Input : none * Output: none * Return: present value of variable XSIZE */ int get_xsize(void) { return(XSIZE); } /*============================================================================== * Gets the value of the user-definable variable YSIZE. This is the number of * pixels in the y-direction. * * Default value if not defined by the user: 1024 * * Input : none * Output: none * Return: present value of variable YSIZE */ int get_ysize(void) { return(YSIZE); } /*============================================================================== * Sets the user-definable variable ACTIVE_R. If set, the spatial correction is * only done inside a circular area with radius ACTIVE_R in the image. * * Default value if not defined by the user: 0. (i.e., no circular area defined) * * Input : arad: new value for variable ACTIVE_R * Output: none * Return: none */ void set_actrad(float arad) { if(arad != ACTIVE_R) { ACTIVE_R = arad; LUT_INVALID = 1; } } /*============================================================================== * Sets the user-definable variable DRK_CONST. If set, this value is subtracted * from every pixel in the source image. * * For details, see routine subtract_drk(). * * Default value if not defined by the user: 0. * * Input : drkconst: new value for variable DRK_CONST * Output: none * Return: none */ void set_drkconst(float drkconst) { DRK_CONST = drkconst; } /*============================================================================== * Sets the user-definable variable DO_DARK. If this variable is set to 0, no * dark image correction will be performed. * * Default value if not defined by the user: 0 * * Input : dodark: new value for variable DO_DARK * Output: none * Return: none */ void set_dodark(int dodark) { DO_DARK = dodark; } /*============================================================================== * Sets the user-definable variable DO_FLAT. If this variable is set, the target * image will be normalized to a flat image. * * Default value if not defined by the user: 0 * * Input : doflat: new value for variable DO_FLAT * Output: none * Return: none */ void set_doflat(int doflat) { if(DO_FLAT != doflat) { LUT_INVALID = 1; DO_FLAT = doflat; } } /*============================================================================== * Sets the user-definable variable DO_SPD, which decides if a distortion/prerotation * correction will be performed: * DO_SPD = 0 no distortion/prerotation correction * = 1 distortion/prerotation correction after dark image, before * floodfield * = 2 distortion/prerotation correction after floodfield, before * normalization * = 3 distortion/prerotation correction after normalization * = 4 distortion/prerotation correction after background subtraction * * Default value if not defined by the user: 1 * * Input : dospd: new value for variable DO_SPD * Output: none * Return: none */ void set_dospd(int dospd) { if(dospd < 0 || dospd > 4) return; DO_SPD = dospd; } /*============================================================================== * Sets the user-definable variable DO_PREROT, which decides if a rotation * correction will be done after the distortion correction: * DO_PREROT = 0 no rotation correction * = 1 rotation correction after distortion correction * * Default value if not defined by the user: 1 * * Input : doprerot: new value for variable DO_PREROT * Output: none * Return: none */ void set_doprerot(int doprerot) { if(doprerot < 0 || doprerot > 2) return; DO_PREROT = doprerot; } int get_doprerot( void ) { return (DO_PREROT); } /*============================================================================== * Sets the user-definable variable NORM_PREROT, which decides whether * a multiplication with the spd multiplication array M_COR is done after * a spatial distortion correction. * NORM_PREROT = 0 no multiplication with M_COR * = 1 multiplication with M_COR * * Default value if not defined by the user: 0 * * Input : normprerot: new value for variable NORM_PREROT * Output: none * Return: none */ void set_normprerot(int normprerot) { if(normprerot < 0 || normprerot > 1) return; NORM_PREROT = normprerot; } /*============================================================================== * Sets the user-definable variable "Dummy" which is used to mark invalid pixels * in the output image. * * Default value if not defined by the user: 0. * * The value of "DDummy" is also redefined to reflect the new value of "Dummy": * DDummy = DDSET(Dummy) * * Input : dummy_in: new value for variable Dummy * Output: none * Return: none */ void set_dummy(float dummy_in) { Dummy = dummy_in; img_head[CORTYP].Dummy = Dummy; img_head[CORTYP].init |= FL_DUMMY; img_head[CORTYP].init |= FL_DDUMM; img_head[CORTYP].DDummy = DDSET(Dummy); } /*============================================================================== * Sets the values of the user-definable header parameters' structure. * * The input structure is copied to the "data_head" type structure with the * array index given by the input parameter "type". The member "init" of that * header structure contains then the "OR"ed flags of all the header keywords * that are initialized. * * Default value if this structure array element has never been initialized by * the user (i.e., if set_headval() has never been called for the structure * with index "type"): "init" = 0 * * If the input header is of type SRCTYP, copy it into the CORTYP structure as * well. * * See the declaration of the "img_head" structure array for the values that * "type" can have. * * Input : inhead: structure with the new values for the structure * "img_head[type]" * type : index of the structure array element to be initialized * Output: none * Return: -1 if "type" has an illegal value * 0 otherwise */ int set_headval(struct data_head inhead,int type) { if(type <= 0 || type >= MAXTYP) return(-1); img_head[type] = inhead; if(type == SRCTYP) img_head[CORTYP] = img_head[SRCTYP]; return(0); } /*============================================================================== * Sets pointers to several types of user-definable image buffers: * * - type = DRKTYP defines the dark image (variable DRK_IM); * - type = FLOTYP defines the flood field image (variable FLO_IM); * - type = SBKTYP defines the scattering background image (variable BCKG_IM); * * Default values for all buffers if not defined by the user: NULL pointer. * * If "type" has not one of the allowed values, an error message is displayed * and the routine returns without further action. * * Input : pbuf: pointer to image of type "type" * type: type of image * Output: none * Return: none */ void set_imgbuf(void *pbuf,int type) { switch(type) { case DRKTYP: DRK_IM = (float *)pbuf; break; case FLOTYP: /* * Invert the floodfield image. This makes later processing easier, as the * source image is then multiplied by the floodfield image, which avoids * the problems of division by 0. */ FLO_IM = (float *)pbuf; prepare_flood((unsigned short *)NULL,FLO_IM); break; case SBKTYP: BCKG_IM = (float *)pbuf; break; default: prmsg(ERROR,("illegal file type %d in set_imgbuf\n",type)); return; } } /*============================================================================== * Sets the user-definable variable INPCONST. If set, this value is added to * every pixel in the input image. * * For details, see routine scale_im(). * * Default value if not defined by the user: 0. * * Input : inpconst: new value for variable INPCONST * Output: none * Return: none */ void set_inpconst(float inpconst) { INPCONST = inpconst; } /*============================================================================== * Sets the user-definable variable INPEXP. If set, every pixel in the input * image is exponentiated with this value. * * As the exponential function is rather slow, the calculation will be done with * a lookup-table that contains the exponentiated values for all integers * between 0 and USHRT_MAX (i.e. the range of the source image data). This table * is prepared here every time the value of the input exponent INPEXP changes. * * Note that this means that the table has to have dimension USHRT_MAX + 1. * * For more details, see routine expon_im(). * * Default value if not defined by the user: 1. * * Input : inpexp: new value for variable INPEXP * Output: none * Return: none */ void set_inpexp(float inpexp) { int index; if(inpexp != INPEXP) { INPEXP = inpexp; for(index = 0; index <= USHRT_MAX; index++) *(exptab + index) = pow((double)index,(double)inpexp); } } /*============================================================================== * Sets the user-definable variable INPFACT. If set, every pixel in the input * image is multiplied with this value. * * For details, see routine scale_im(). * * Default value if not defined by the user: 1. * * Input : inpfact: new value for variable INPFACT * Output: none * Return: none */ void set_inpfact(float inpfact) { INPFACT = inpfact; } /*============================================================================== * Sets the user-definable variable "INP_MAX" which is used to define the * maximum allowed value in the input and the dark current image. * * The value 0. is used to signal that no maximum allowed value is set. * * Default value if not defined by the user: 0. (i.e., not set). * * Input : inpmax_in: new value for variable INP_MAX * Output: none * Return: none */ void set_inpmax(float inpmax_in) { INP_MAX = inpmax_in; } /*============================================================================== * Sets the user-definable variable "INP_MIN" which is used to define the * minimum allowed value in the input and the dark current image. * * The value 0. is used to signal that no minimum allowed value is set. * * Default value if not defined by the user: 0. (i.e., not set). * * Input : inpmin_in: new value for variable INP_MIN * Output: none * Return: none */ void set_inpmin(float inpmin_in) { INP_MIN = inpmin_in; } /*============================================================================== * Sets the user-definable variable NORM_INT. If this variable is set, the * target image will be normalized to absolute scattering intensities. * * Default value if not defined by the user: 0 (i.e., not set) * * Input : normint: new value for variable NORM_INT * Output: none * Return: none */ void set_normint(int normint,float normfact) { NORM_INT = normint; NORMFACT = normfact; } /*============================================================================== * Sets the user-definable variables IMAGE_OVER and IMAGE_OVER_SET which are * used to mark pixels with overflow values in the images. * * Default value for both variables if not defined by the user: 0xffff * * Input : overfl: new value for variables IMAGE_OVER and IMAGE_OVER_SET * Output: none * Return: none */ void set_overflow(unsigned long overf) { IMAGE_OVER = overf; IMAGE_OVER_SET = overf; } /*============================================================================== * Sets the user-definable variable DSTRTVAL. If this variable is set, the pixel * sizes, center coordinates, coordinate offsets, sample distance, bin sizes, * projection type and detector rotations for the corrected image are taken from * the distortion files, otherwise the values of the source image header are * retained. * * For more details, see routine undistort_im(). * * Default value if not defined by the user: 0 * * Input : dstrtval: new value for variable DSTRTVAL * Output: none * Return: 0 always */ int set_dstrtval(int dstrtval) { DSTRTVAL = dstrtval; return(0); } /*============================================================================== * Sets the user-definable variable BCKGCONST. If set, this value is added to * every pixel in the scattering background image. * * For details, see routine scale_im(). * * Default value if not defined by the user: 0. * * Input : bckgconst: new value for variable BCKGCONST * Output: none * Return: none */ void set_bckgconst(float bckgconst) { BCKGCONST = bckgconst; } /*============================================================================== * Sets the user-definable variable BCKGFACT. If set, every pixel in the * scattering background image is multiplied with this value. * * For details, see routine scale_im(). * * Default value if not defined by the user: 1. * * Input : bckgfact: new value for variable BCKGFACT * Output: none * Return: none */ void set_bckgfact(float bckgfact) { BCKGFACT = bckgfact; } /*============================================================================== * Sets the user-definable variable DISTFILE. The corresponding file contains * the spline function coefficients that are used to calculate the distortion * correction values. * * Default value if not defined by the user: NULL pointer * * Input : distfile: new value for variable DISTFILE * Output: none * Return: none */ void set_splinfil(char *distfile) { int dflen,istat; static int dist_mtime = 0; struct stat stat_buf; if(distfile == NULL || (dflen = strlen(distfile)) == 0) return; if(XINFILE) { pfree(XINFILE); XINFILE = NULL; } if(YINFILE) { pfree(YINFILE); YINFILE = NULL; } /* * Check if this is a new distortion file. This is the case if any of the * following is true: * - there was no previous distortion file; * - the file names of the previous and the present file are different; * - the modification time of the file has changed. */ if((istat = stat(distfile,&stat_buf)) != 0) prmsg(DMSG,("Cannot access distortion file %s\n",distfile)); if(DISTFILE == NULL || strcmp(DISTFILE,distfile) != 0 || dist_mtime == 0 || istat == 0 && dist_mtime != (int)stat_buf.st_mtime) { if(DISTFILE) { prmsg(DMSG,("Distortion file name changed from %s to %s\n",DISTFILE, distfile)); pfree(DISTFILE); } else prmsg(DMSG,("Distortion file name set to %s\n",distfile)); if(istat == 0) dist_mtime = (int)stat_buf.st_mtime; SPLINE_INVALID = 1; LUT_INVALID = 1; DISTFILE = (char *)pmalloc((dflen + 1) * sizeof(char)); strcpy(DISTFILE,distfile); } } /*============================================================================== * Sets the user-definable variables XINFILE and YINFILE. The corresponding * files contain for each pixel of the source image the spatial distortion * correction values in x direction (XINFILE) and y direction (YINFILE). * * Default value for both variables if not defined by the user: NULL pointer * * Input : xfile: new value for variable XINFILE * yfile: new value for variable YINFILE * Output: none * Return: none */ void set_xycorin(char *xfile,char *yfile) { int ixstat,iystat,xflen,yflen,newxfile = 0,newyfile = 0; static int x_mtime = 0,y_mtime = 0; struct stat xstat_buf,ystat_buf; if((xflen = strlen(xfile)) == 0 || (yflen = strlen(yfile)) == 0) return; if(DISTFILE) { pfree(DISTFILE); DISTFILE = NULL; } if(spline != NULL) { spd_unloadspline(spline); spline = NULL; } /* * Check if the distortion correction files are new. This is the case if any * of the following is true: * - there was no previous distortion file; * - the file names of the previous and the present file are different; * - the modification time of the file has changed. */ if((ixstat = stat(xfile,&xstat_buf)) != 0) prmsg(DMSG,("Cannot access x distortion value file %s\n",xfile)); if(XINFILE == NULL || strcmp(XINFILE,xfile) != 0 || x_mtime == 0 || ixstat == 0 && x_mtime != (int)xstat_buf.st_mtime) newxfile = 1; if((iystat = stat(yfile,&ystat_buf)) != 0) prmsg(DMSG,("Cannot access y distortion value file %s\n",yfile)); if(YINFILE == NULL || strcmp(YINFILE,yfile) != 0 || y_mtime == 0 || iystat == 0 && y_mtime != (int)ystat_buf.st_mtime) newyfile = 1; if(newxfile) { if(XINFILE) { prmsg(DMSG,("X distortion value file name changed from %s to %s\n", XINFILE,xfile)); pfree(XINFILE); } else prmsg(DMSG,("X distortion file name set to %s\n",xfile)); if(ixstat == 0) x_mtime = (int)xstat_buf.st_mtime; XINFILE = (char *)pmalloc((xflen + 1) * sizeof(char)); strcpy(XINFILE,xfile); } if(newyfile) { if(YINFILE) { prmsg(DMSG,("Y distortion value file name changed from %s to %s\n", YINFILE,yfile)); pfree(YINFILE); } else prmsg(DMSG,("Y distortion file name set to %s\n",yfile)); if(iystat == 0) y_mtime = (int)ystat_buf.st_mtime; YINFILE = (char *)pmalloc((yflen + 1) * sizeof(char)); strcpy(YINFILE,yfile); } if(newxfile || newyfile) { SPLINE_INVALID = 1; LUT_INVALID = 1; } } /* set_xycorin */ /*============================================================================== * Sets the user-definable variables XOUTFILE and YOUTFILE. If both are set, the * spatial distortion correction values for each pixel of the source image will * be saved in XOUTFILE (for x direction) and YOUTFILE (for y direction). * * Default value for both variables if not defined by the user: NULL pointer * (i.e., not set) * * Input : xfile: new value for variable XOUTFILE * yfile: new value for variable YOUTFILE * Output: none * Return: none */ void set_xycorout(char *xfile,char *yfile) { int xflen,yflen; if((xflen = strlen(xfile)) == 0 || (yflen = strlen(yfile)) == 0) return; if(XOUTFILE) { pfree(XOUTFILE); XOUTFILE = NULL; } if(YOUTFILE) { pfree(YOUTFILE); YOUTFILE = NULL; } XOUTFILE = (char *)pmalloc((xflen + 1) * sizeof(char)); strcpy(XOUTFILE,xfile); YOUTFILE = (char *)pmalloc((yflen + 1) * sizeof(char)); strcpy(YOUTFILE,yfile); } /* set_xycorout */ /*============================================================================== * Sets the user-definable variable MOUTFILE. If set, the prerotation * renormalization image will be saved in MOUTFILE. * * Default value: NULL pointer * (i.e., not set) * * Input : mfile: new value for variable MOUTFILE * Output: none * Return: none */ void set_moutfile(char *mfile) { int mflen; if((mflen = strlen(mfile)) == 0 ) return; if(MOUTFILE) { pfree(MOUTFILE); MOUTFILE = NULL; } MOUTFILE = (char *)pmalloc((mflen + 1) * sizeof(char)); strcpy(MOUTFILE,mfile); } /* set_moutfile */ /*============================================================================== * Sets the user-definable variables XSIZE and YSIZE. These are the number of * pixels in the x- and y-direction. * * The x-direction is the "fast-moving" index in a multidimensional C array, * the y-direction is the "slow-moving" one. * * Default value for both variables if not defined by the user: 1024 * * Input : xsize: new value for variable XSIZE * ysize: new value for variable YSIZE * Output: none * Return: none */ void set_xysize(int xsize,int ysize) { XSIZE = xsize; YSIZE = ysize; } /* set_xysize */ /*============================================================================== * A routine used to get either a perfect grid image or a distorted grid * with Gauss peaks for tests purposes. The first peak center is at (15,35) * and then every 50 pixels in x and y direction there is another one. * * Input : image: pointer to the image memory which has to exist * height, width: height and width of the individual peaks. * distorted: outputs the peaks not as a perfect grid but * distorted with a simple algorithm (projection * of points on a ball) * Output: image: filled with image data * Return: 0 */ int make_grid(unsigned short *image,float height,float width,int distorted) { float x,y,r,xcen,ycen; float CURV_RADIUS = 270000/180; int i,j; int i0,i1,j0,j1; prmsg(DMSG, ("Grid (%dx%d) with peak height : %f and width %f\n", XSIZE,YSIZE,height,width)); memset(image,0,sizeof(short) * XSIZE * YSIZE); for(x = 15; x < XSIZE; x += 50) for(y = 35; y < YSIZE; y += 50) { xcen = x; ycen = y; if(distorted) { double dx,dy,atn,d2; dx = x - XSIZE / 4; dy = y - YSIZE / 3; d2 = CURV_RADIUS * sin (sqrt (dx * dx + dy * dy) / CURV_RADIUS); if(fabs(dx) > 1E-5 || fabs(dy) < 1E-5) { atn = atan2(dy,dx); xcen = XSIZE/4.0 + d2 * cos(atn); ycen = YSIZE/3.0 + d2 * sin(atn); } } i0 = xcen - width * 2; i1 = xcen + width * 2 + 1; j0 = ycen - width * 2; j1 = ycen + width * 2 + 1; if(i0 >=0 && j0 >= 0 && i1 < XSIZE && j1 < YSIZE) for(i = i0; i < i1; i++) for(j = j0; j < j1; j++) { r = sqrt (pow(xcen - (float)i,2) + pow(ycen - (float)j,2)); image[i + j * XSIZE] = height * exp(-r / pow(width/3,2)); } } return(0); } /* make_grid */ /* TRIANGLE CALCULATION BEGIN */ /*============================================================================== * Cuts the input triangle along a vertical line into a (smaller) triangle and * an irregular quadrangle. The new coordinates of the triangle are stored in * the old input triangle. The quadrangle is divided into two new triangles, * and their coordinates are stored in "new_triangles". * * Under particular circumstances there may be only one or even no new triangle * created (if the cut line goes through one of the corners or coincides with * one of the sides of the input triangle). * * Input : in_tri: structure with the x and y coordinates of a triangle * v: x coordinate of the vertical cut line * Output: new_triangles: structures with the x and y coordinates of the new * triangles created * no_new: number of the new triangles created (normally 2) * Return: 0 */ int trianglecutv_only(struct triangle *in_tri,float v, struct triangle new_triangles[],int *no_new) { float U1,U2,U3; int i,next,afternext; float py,ndx; struct triangle *new = new_triangles; /* * Set pointers to the old (input) and the new (to be created) triangle: * - tri, x and y point to the old triangle; * - nx and ny point to the new triangle. */ struct triangle *tri = in_tri; float *x = tri->x, *y = tri->y; float *nx = new->x, *ny = new->y; /* * Define first point as "previous point". * Is this previous point to the right of the cut line? */ *no_new = 0; U1 = x[0] > v; for(i = 0; i < 3; i++) { /* * Determine next point. * Is this next point to the right of the cut line? */ next = (i == 2) ? 0 : (i + 1); U2 = x[next] > v; /* * If the previous and the next point are not on the same side of the cut * line, then cut the triangle at the cut line between previous point and * next point. * * The resulting two triangles will consist of the following points: * - old triangle: previous point, cut point, and "afternext" point; * - new triangle: cut point, next point, and "afternext" point. * * The new triangle will thus share two points with the old one (cutpoint * and afternext). * * If the previous and the next point are on the same side of the cut line, * then the cut will not happen between these two points. Just continue the * loop and test the next pair of points. */ if(U1 != U2) { /* * Calculate cut point. */ ndx = v - x[i]; py = y[i] + ndx * (y[next] - y[i]) / (x[next] - x[i]); /* * Copy old triangle to new triangle. */ memcpy(new,tri,sizeof(struct triangle)); /* * Put cut point as new point into the old and the new triangle. */ x[next] = nx[i] = v; y[next] = ny[i] = py; if(new == new_triangles) { /* * If this was the first cut, then there are now two triangles: the * modified input triangle and the newly created one. * * One of the two will be entirely on one side of the cut line, the * other needs to be cut again along the cut line. * * Find out which triangle needs to be cut. */ afternext = (next == 2) ? 0 : (next + 1); U3 = x[afternext] > v; /* * If the new triangle has to be cut: * * - cycle all triangle pointers: the second triangle will become the * old one, and the (to be created) third will be the new triangle * (i.e., "tri", "x" and "y" will point to the second, "nx" and "ny" * to the third triangle); * * - then just apply the same algorithm again: this will cut the second * triangle in the same way as the first one was cut before, with the * new cut point stored in the coordinates of the second and third * triangle. * * If the old (input) triangle has to be cut: * * - cycle just the pointers to the new triangle: the (to be created) * third triangle will be the new triangle, but the first triangle * will remain the old one (i.e., "tri", "x" and "y" will point to the * first, "nx" and "ny" to the third triangle); * * - then just apply the same algorithm again: this will cut the first * triangle again in the same way as it was cut before, with the new * cut point stored in the coordinates of the first and third * triangle. */ if(U3 == U1) { tri = new; x = nx; y = ny; } new++; nx = new->x; ny = new->y; *no_new = 1; } else { /* * If this was not the first cut, then the task is finished. Just * increase the triangle count, terminate the loop and return. */ *no_new = 2; break; } } U1 = U2; } return(0); } /* trianglecutv_only */ /*============================================================================== * Does the same as routine trianglecutv_only(), but cuts along a horizontal * line. * * See routine trianglecutv_only() for details of how the routine works. * * Input : in_tri: structure with the x and y coordinates of a triangle * v: y coordinate of the horizontal cut line * Output: new_triangles: structures with the x and y coordinates of the new * triangles created * no_new: number of the new triangles created (normally 2) * Return: 0 */ int trianglecuth_only(struct triangle *in_tri,float v, struct triangle new_triangles[],int *no_new) { float U1,U2,U3; int i,next,afternext; float px,ndy; struct triangle *new = new_triangles; struct triangle *tri = in_tri; float *x = tri->x,*y = tri->y; float *nx = new->x,*ny = new->y; *no_new = 0; U1 = y[0] > v; for(i = 0; i < 3; i++) { next = (i == 2) ? 0 : (i + 1); U2 = y[next] > v; if(U1 != U2) { ndy = v - y[i]; px = x[i] + ndy * (x[next] - x[i]) / (y[next] - y[i]); memcpy(new,tri,sizeof(struct triangle)); x[next] = nx[i] = px; y[next] = ny[i] = v; if(new == new_triangles) { afternext = (next == 2) ? 0 : (next + 1); U3 = y[afternext] > v; if (U3 == U1) { tri = new; x = nx; y = ny; } new++; nx = new->x; ny = new->y; *no_new = 1; } else { *no_new = 2; break; } } U1 = U2; } return(0); } /* trianglecuth_only */ /*============================================================================== * Calculates the area of the triangle formed by the three coordinate pairs in * the input arrays x and y. It uses Heron's formula * * area = sqrt(s * (s-a) * (s-b) * (s-c)) * * where a,b,c are the three sides of the triangle and s = (a+b+c) / 2 * * Input : x, y: arrays with the three x and y coordinates of the triangle * Output: area: the area of the triangle * Return: none */ void area_only(float *x,float *y,float *area) { float dx,dy; float sum = 0; float len1,len2,len3; float insum; dx = x[0] - x[2]; dy = y[0] - y[2]; sum = len1 = sqrt (dx * dx + dy * dy); dx = x[1] - x[0]; dy = y[1] - y[0]; len2 = sqrt (dx * dx + dy * dy); sum += len2; dx = x[2] - x[1]; dy = y[2] - y[1]; len3 = sqrt (dx * dx + dy * dy); sum += len3; sum /= 2; insum = sum * (sum - len1) * (sum - len2) * (sum - len3); if(insum >= 0) *area = sqrt (sum * (sum - len1) * (sum - len2) * (sum - len3)); else { *area = 0; } } /* area_only */ /*============================================================================== * Cuts the input triangle into several new ones such that each of them is * fully contained in one of the squares of an integer valued x and y grid. * * Expressed in terms of image pixels, the triangle is cut up in such a way that * each part is fully contained in one pixel. The "ixmin" to "iymax" return * arguments give the ranges of the x and y indices of the pixels that contain * the input triangle ("min" and "max" both included). * * Input : triangles[0]: structure with the x and y coordinates of a triangle * Output: triangles: structures with the x and y coordinates of the new * triangles created. These are the integer-truncated values * of the triangle's center (the (smallest x, smallest y) * corner of the grid square the triangle is in) * n: number of the new triangles created * ixmin: the x index of the vertical grid line just to the left of * the input triangle * ixmax: the x index of the rightmost vertical grid line that still * has part of the input triangle to its right * iymin: the y index of the horizontal grid line just below the * input triangle * iymax: the y index of the highest horizontal grid line that still * has part of the input triangle above it * Return: 0 */ int triangle_cutall(struct triangle triangles[],int *n,int *ixmin,int *ixmax, int *iymin,int *iymax) { int i,j; int no_add,no_tri,free,total_add; int cutxmin,cutxmax,cutymin,cutymax; float *x = triangles[0].x, *y = triangles[0].y; float xmin,xmax,ymin,ymax; /* * Get the smallest and largest x and y value of the input triangle. */ xmin = x[0] < x[1] ? x[0] : x[1]; if(xmin > x[2]) xmin = x[2]; ymin = y[0] < y[1] ? y[0] : y[1]; if(ymin > y[2]) ymin = y[2]; xmax = x[0] > x[1] ? x[0] : x[1]; if(xmax < x[2]) xmax = x[2]; ymax = y[0] > y[1] ? y[0] : y[1]; if(ymax < y[2]) ymax = y[2]; /* * Determine the leftmost and the rightmost vertical cut line, as well as * the lowest and highest horizontal cut line. * * A valid vertical cut line has a non-empty part of the triangle to the left * and another non-empty part to the right. Thus the leftmost vertical cut * line is the one with the smallest x index that still has a non-empty part * of the triangle to its left. * * Therefore if a grid line goes through the leftmost point of the triangle, * then the leftmost vertical cut line is not this one, but the next one to * the right. * * The rightmost vertical cut line is determined in an analog way by selecting * the vertical cut line with the largest x value that still has a non-empty * part of the triangle to its right. * * The same philosophy is then applied to select the lowest and highest * horizontal cut line. */ cutxmin = ceil(xmin); if(cutxmin == xmin) cutxmin++; cutxmax = floor(xmax); if(cutxmax == xmax) cutxmax--; cutymin = ceil(ymin); if(cutymin == ymin) cutymin++; cutymax = floor(ymax); if(cutymax == ymax) cutymax--; /* * Cut the input triangle along the vertical grid (formed by all integer * values between the leftmost and rightmost vertical cut line) into several * triangles in such a way that each triangle is entirely contained between * two grid lines. * * no_tri counts the number of triangles, the first cut triangle will replace * the input triangle, and the other ones are stored into subsequent * locations in the structure array triangles. */ no_tri = 1; free = 1; for(i = cutxmin; i <= cutxmax; i++) { total_add = 0; for(j = 0; j < no_tri; j++) { trianglecutv_only(triangles + j,(float)i,triangles + free,&no_add); free += no_add; if(free >= MAX_TRIANGLES) prmsg(ERROR,("too many triangles (%d) \n",free)); total_add += no_add; } no_tri += total_add; } /* * Now cut all these created triangles along the horizontal grid (formed by * the integer values between the lowest and highest horizontal cut line) * into several triangles in such a way that each triangle is entirely * contained in the square between adjacent grid lines (i.e., each triangle is * entirely contained in a single pixel). */ for(i = cutymin; i <= cutymax; i++) { total_add = 0; for(j = 0; j < no_tri; j++) { trianglecuth_only(triangles + j,(float)i,triangles + free,&no_add); free += no_add; if(free >= MAX_TRIANGLES) prmsg(ERROR,("too many triangles (%d) \n",free)); total_add += no_add; } no_tri += total_add; } /* * Determine the grid coordinates for each triangle. These are the * integer-truncated values of the triangle's center (i.e., the * (smallest x, smallest y) corner of the grid square the triangle is in). */ for(i = 0; i < no_tri; i++) { triangles[i].ypos = (int) ((triangles[i].y[0] + triangles[i].y[1] + triangles[i].y[2]) / 3); triangles[i].xpos = (int) ((triangles[i].x[0] + triangles[i].x[1] + triangles[i].x[2]) / 3); } /* * Determine the minimum and maximum pixel indices in x and y. */ *ixmin = cutxmin - 1; *iymin = cutymin - 1; *ixmax = cutxmax; *iymax = cutymax; *n = no_tri; return(0); } /* triangle_cutall */ /*============================================================================== * Cuts the input pixel into segments along an integer-values horizontal and * vertical grid. It determines the area of the input pixel that falls into * each grid square and the minimal and maximal grid values in x and y. * * To achieve this, the input pixel is cut in two triangles, which in turn are * cut into more triangles in such a way that at the end each of the created * triangles is fully contained in one square of the grid. * * Input : x, y: arrays with the (four) x and y coordinates of a pixel * debug: debugging flag: produce debugging output if != 0 * Output: parts: array that gives for each grid square the area of the input * pixel it contains * txmin: the x coordinate of the vertical grid line just to the left * of the input pixel * txmax: the x coordinate of the rightmost vertical grid line that * still has part of the input pixel to its right * tymin: the y coordinate of the horizontal grid line just below the * input pixel * tymax: the y coordinate of the highest horizontal grid line that * still has part of the input pixel above it * total: the area of the input pixel * Return: number of triangles created */ int calcparts(float x[],float y[],int debug,float parts[],int *txmin,int *txmax, int *tymin,int *tymax,float *total) { int xmin,xmax,ymin,ymax; int xmin2,xmax2,ymin2,ymax2; struct triangle triangles[MAX_TRIANGLES]; float totalarea; float totalarea2; int no_tri,no_tri2; int n,i,j,idx; /* * Divide the pixel into two triangles along the line from point "0" to * point "2": * * 0 1 * ------------- * | | * | | * | | * | | * ------------- * 3 2 * * Calculate the areas of these two triangles, then cut each into several * triangles along an integer-valued horizontal and vertical grid in such a * way that each of those new triangles is entirely contained between * neighboring grid lines. */ triangles[0].x[0] = x[0]; triangles[0].y[0] = y[0]; triangles[0].x[1] = x[1]; triangles[0].y[1] = y[1]; triangles[0].x[2] = x[2]; triangles[0].y[2] = y[2]; area_only(triangles[0].x,triangles[0].y,&totalarea); triangle_cutall(triangles,&no_tri,&xmin,&xmax,&ymin,&ymax); triangles[no_tri].x[0] = x[2]; triangles[no_tri].y[0] = y[2]; triangles[no_tri].x[1] = x[3]; triangles[no_tri].y[1] = y[3]; triangles[no_tri].x[2] = x[0]; triangles[no_tri].y[2] = y[0]; area_only(triangles[no_tri].x,triangles[no_tri].y,&totalarea2); triangle_cutall(triangles + no_tri,&no_tri2,&xmin2,&xmax2,&ymin2,&ymax2); /* * Get the total number of triangles, the area and the smallest and biggest * grid values in x and y. */ no_tri += no_tri2; totalarea += totalarea2; if(xmin2 < xmin) xmin = xmin2; if(ymin2 < ymin) ymin = ymin2; if(xmax2 > xmax) xmax = xmax2; if(ymax2 > ymax) ymax = ymax2; /* * Calculate for each grid square how much of its area the input pixel covers, * and store it in the array "parts". This array contains "number of x grid * squares" times "number of y grid squares" elements, and the grid squares * are stored in row-fashion (x increases fastest). * * Expressed in pixel indices, this determines for the input source pixel the * target pixels it is mapped to, and how much of each target pixel the source * pixel covers. */ n = (xmax - xmin + 1) * (ymax - ymin + 1); if(n > MAX_PARTS) { prmsg(ERROR,("too many parts (%d) - pixel too big\n",n)); exit(-1); } for(i = 0; i < n; i++) parts[i] = 0.; for(j = 0; j < no_tri; j++) { area_only(triangles[j].x,triangles[j].y,&triangles[j].area); idx = (triangles[j].xpos - xmin) + (triangles[j].ypos - ymin) * (xmax - xmin + 1); parts[idx] += triangles[j].area; } if(debug) debugout(triangles,no_tri,totalarea,parts,xmin,xmax,ymin,ymax); *txmin = xmin; *txmax = xmax; *tymin = ymin; *tymax = ymax; *total = totalarea; return(no_tri); } /* calcparts */ /*============================================================================== * Print for debugging purposes the values calculated by "calcparts()". * * Input : triangles: structure array with the triangles created * no_tri: number of triangles created * total: the area of the pixel * parts: array that gives for each grid square the area of the * input pixel it contains * xmin: the x coordinate of the vertical grid line just to the * left of the pixel * xmax: the x coordinate of the rightmost vertical grid line that * still has part of the pixel to its right * ymin: the y coordinate of the horizontal grid line just below * the pixel * ymax: the y coordinate of the highest horizontal grid line that * still has part of the pixel above it * Output: none * Return: 0 */ int debugout(struct triangle triangles[],int no_tri,float total,float parts[], int xmin,int xmax,int ymin,int ymax) { FILE *file; float sumparts; int i,j,idx = 0; float fxmin,fxmax,fymin,fymax; /* * Print smallest and largest grid value in x and y. */ printf("Min Max: X %d %d Y %d %d\n",xmin,xmax,ymin,ymax); /* * Print for each triangle the coordinates of the corners, the area and the * grid coordinates. * * Then test if the triangle is fully contained in its grid square, and * print an error message if not. */ for(i = 0; i < no_tri; i++) { fxmin = triangles[i].x[0]; fymin = triangles[i].y[0]; fxmax = triangles[i].x[0]; fymax = triangles[i].y[0]; printf("Triangle %d:\n",i); for(j = 0; j < 3; j++) { printf("x[%d]=%7.2f, y[%d]=%7.2f\n",j,triangles[i].x[j], j,triangles[i].y[j]); if(fxmin > triangles[i].x[j]) fxmin = triangles[i].x[j]; if(fymin > triangles[i].y[j]) fymin = triangles[i].y[j]; if(fxmax < triangles[i].x[j]) fxmax = triangles[i].x[j]; if(fymax < triangles[i].y[j]) fymax = triangles[i].y[j]; } printf(" area = %7.2f, xpos = %d, ypos = %d\n", triangles[i].area,triangles[i].xpos,triangles[i].ypos); if(fxmin < (float)triangles[i].xpos || fxmax > (float)triangles[i].xpos + 1 || fymin < (float)triangles[i].ypos || fymax > (float)triangles[i].ypos + 1) { printf("Error: x[%f:%f] y[%f:%f]\n",fxmin,fxmax,fymin,fymax); } } /* * Print the area of the input pixel contained in each grid square. */ for(j = ymin; j <= ymax; j++) { for(i = xmin; i <= xmax; i++) { printf("%6.2f ",parts[idx++]); } printf("\n"); } /* * Print the total area of the input pixel, determined as the sum over all * the triangle areas. */ sumparts = 0; for(i = 0; i < no_tri; i++) sumparts += triangles[i].area; printf("============ %f (total) = %f (sum of parts)\n",total,sumparts); /* * Write all the triangle coordinates to the file "/tmp/triangles". */ file = fopen("/tmp/triangles","w"); for(i = 0; i < no_tri; i++) { fprintf(file,"%f %f 1\n%f %f\n%f %f\n%f %f\n", triangles[i].x[0],triangles[i].y[0],triangles[i].x[1],triangles[i].y[1], triangles[i].x[2],triangles[i].y[2],triangles[i].x[0],triangles[i].y[0]); } fclose(file); return(0); } /* debugout */ /* TRIANGLE CALCULATION END */ /*============================================================================== * Put the pixel sizes, center coordinates, coordinate offsets, sample * distance, bin sizes, projection type and detector rotations of the * distortion files in the image header structure type, if this has been * selected by the user with the global variable DSTRTVAL (everything else * than prerotation parameters) * * In detail: the value of DSTRTVAL is compared (with a "bitwise and") to * several flags: * - if the comparison is true, then the corresponding value is taken from * the distortion file headers (SDXTYP, SDYTYP). * - else the values of the image header are retained for the value. * * Input : type: type of header to be updated * out_type: 0, header type is updated depending on moded * 1, output header is a copy of type * and updated depending on mode * mode: 0 Copy only type to out_type * mode: 1 update output header from SDXTYP and SDYTYP * Return: 0 no errors * -1 invalid header type */ int upd_headval( int type, int out_type, int mode ) { struct data_head *user_head, *out_head; if (type <= 0) goto upd_headval_error; user_head = &(img_head[type]); if ( ( out_type>INVALID_TYP ) && ( type != out_type ) ) { prmsg(DMSG,("upd_headval: copy %s header to %s.\n", typestr[type],typestr[out_type])); if (out_type <= 0) goto upd_headval_error; out_head = &(img_head[out_type]); /* * copy type header to output header */ *out_head = *user_head; } else { /* * output header is identical to input header */ prmsg(DMSG,("upd_headval: update %s header.\n",typestr[type])); out_head = user_head; } if (mode==1) { /* * update from SDX SDY headers */ if(DSTRTVAL) { if(DSTRTVAL & FL_OFFS1) { if(img_head[SDXTYP].Dspinit & FL_OFFS1) { out_head->Offset_1 = img_head[SDXTYP].DspOffset_1; out_head->init |= FL_OFFS1; } else if(img_head[SDXTYP].init & FL_OFFS1) { out_head->Offset_1 = img_head[SDXTYP].Offset_1; out_head->init |= FL_OFFS1; } } if(DSTRTVAL & FL_OFFS2) { if(img_head[SDYTYP].Dspinit & FL_OFFS2) { out_head->Offset_2 = img_head[SDYTYP].DspOffset_2; out_head->init |= FL_OFFS2; } else if(img_head[SDYTYP].init & FL_OFFS2) { out_head->Offset_2 = img_head[SDYTYP].Offset_2; out_head->init |= FL_OFFS2; } } if(DSTRTVAL & FL_PSIZ1) { if(img_head[SDXTYP].Dspinit & FL_PSIZ1) { out_head->PSize_1 = img_head[SDXTYP].DspPSize_1; out_head->init |= FL_PSIZ1; } else if(img_head[SDXTYP].init & FL_PSIZ1) { out_head->PSize_1 = img_head[SDXTYP].PSize_1; out_head->init |= FL_PSIZ1; } } if(DSTRTVAL & FL_PSIZ2) { if(img_head[SDYTYP].Dspinit & FL_PSIZ2) { out_head->PSize_2 = img_head[SDYTYP].DspPSize_2; out_head->init |= FL_PSIZ2; } else if(img_head[SDYTYP].init & FL_PSIZ2) { out_head->PSize_2 = img_head[SDYTYP].PSize_2; out_head->init |= FL_PSIZ2; } } if(DSTRTVAL & FL_CENT1) { if(img_head[SDXTYP].Dspinit & FL_CENT1) { out_head->Center_1 = img_head[SDXTYP].DspCenter_1; out_head->init |= FL_CENT1; } else if(img_head[SDXTYP].init & FL_CENT1) { out_head->Center_1 = img_head[SDXTYP].Center_1; out_head->init |= FL_CENT1; } } if(DSTRTVAL & FL_CENT2) { if(img_head[SDYTYP].Dspinit & FL_CENT2) { out_head->Center_2 = img_head[SDYTYP].DspCenter_2; out_head->init |= FL_CENT2; } else if(img_head[SDYTYP].init & FL_CENT2) { out_head->Center_2 = img_head[SDYTYP].Center_2; out_head->init |= FL_CENT2; } } if(DSTRTVAL & FL_SAMDS) { if(img_head[SDXTYP].Dspinit & FL_SAMDS) { out_head->SamplDis = img_head[SDXTYP].DspSamplDis; out_head->init |= FL_SAMDS; } else if(img_head[SDXTYP].init & FL_SAMDS) { out_head->SamplDis = img_head[SDXTYP].SamplDis; out_head->init |= FL_SAMDS; } } if(DSTRTVAL & FL_BSIZ1) { if(img_head[SDXTYP].Dspinit & FL_BSIZ1) { out_head->BSize_1 = img_head[SDXTYP].DspBSize_1; out_head->init |= FL_BSIZ1; } else if(img_head[SDXTYP].init & FL_BSIZ1) { out_head->BSize_1 = img_head[SDXTYP].BSize_1; out_head->init |= FL_BSIZ1; } } if(DSTRTVAL & FL_BSIZ2) { if(img_head[SDYTYP].Dspinit & FL_BSIZ2) { out_head->BSize_2 = img_head[SDYTYP].DspBSize_2; out_head->init |= FL_BSIZ2; } else if(img_head[SDYTYP].init & FL_BSIZ2) { out_head->BSize_2 = img_head[SDYTYP].BSize_2; out_head->init |= FL_BSIZ2; } } if(DSTRTVAL & FL_PRO) { if(img_head[SDXTYP].Dspinit & FL_PRO) { strcpy(out_head->ProjTyp,img_head[SDXTYP].DspProjTyp); out_head->init |= FL_PRO; } else if(img_head[SDXTYP].init & FL_PRO) { strcpy(out_head->ProjTyp,img_head[SDXTYP].ProjTyp); out_head->init |= FL_PRO; } } if(DSTRTVAL & FL_ROT1) { if(img_head[SDXTYP].Dspinit & FL_ROT1) { out_head->DetRot_1 = img_head[SDXTYP].DspDetRot_1; out_head->init |= FL_ROT1; } else if(img_head[SDXTYP].init & FL_ROT1) { out_head->DetRot_1 = img_head[SDXTYP].DetRot_1; out_head->init |= FL_ROT1; } } if(DSTRTVAL & FL_ROT2) { if(img_head[SDXTYP].Dspinit & FL_ROT2) { out_head->DetRot_2 = img_head[SDXTYP].DspDetRot_2; out_head->init |= FL_ROT2; } else if(img_head[SDXTYP].init & FL_ROT2) { out_head->DetRot_2 = img_head[SDXTYP].DetRot_2; out_head->init |= FL_ROT2; } } if(DSTRTVAL & FL_ROT3) { if(img_head[SDXTYP].Dspinit & FL_ROT3) { out_head->DetRot_3 = img_head[SDXTYP].DspDetRot_3; out_head->init |= FL_ROT3; } else if(img_head[SDXTYP].init & FL_ROT3) { out_head->DetRot_3 = img_head[SDXTYP].DetRot_3; out_head->init |= FL_ROT3; } } } } return( 0 ); upd_headval_error: prmsg(ERROR,("upd_headval: invalid input header type %s\n",typestr[type])); return( -1 ); } /* upd_headval */ /*============================================================================== * This function calculates the actual prerotation values for the header * type. The function sx_tf_params is used for calculation. The prerotations * and the detector orientation are always read from the source header: * PreDetRot_1, PreDetRot_2, PreDetRot_3. * The parameters PreCenter_1, PreCenter_2, PreSamplDis, can only be * returned if they are either explicitely defined or if they can be * calculated from header values of Center_1, Center_2 and SamplDis. * A calculation of prerotation parameters is necessary when parameters * are mixed, e.g. center, distance and prerotations, but not precenter, * predistance and prerotations. The distance and center values can change * between different images. * * The return value is only zero when all parameters have been * successfully calculated. * * int type : CORTYP, SDXTYP, SDYTYP * int do_prerot : 0 no prerotations, *prot1, *prot2, *prot3 are set to 0 * otherwise the source header values are returned * * return value: 0 no error, all parameters are updated * >0 error: number of missing (not updated) parameters * -1 calculation error */ int calc_prerot( int type, int do_prerot, float *pix1, float *pix2, float *pcen1, float *pcen2, float *pdis, float *prot1, float *prot2, float *prot3 ) { struct sx_params sx; struct data_head *src_head = &img_head[SRCTYP],*user_head; int err=0, iret=0; user_head = &img_head[type]; sx_init( &sx ); if ( user_head->init & FL_PSIZ1 ) { sx.pix1.V = user_head->PSize_1; sx.pix1.I = 1; } if ( user_head->init & FL_PSIZ2 ) { sx.pix2.V = user_head->PSize_2; sx.pix2.I = 1; } if ( user_head->init & FL_CENT1 ) { sx.bcen1.V = user_head->Center_1; sx.bcen1.I = 1; } if ( user_head->init & FL_CENT2 ) { sx.bcen2.V = user_head->Center_2; sx.bcen2.I = 1; } if ( user_head->init & FL_SAMDS ) { sx.bdis.V = user_head->SamplDis; sx.bdis.I = 1; } if (do_prerot) { sx.rot1.V = src_head->PreDetRot_1; sx.rot1.I = 1; sx.rot2.V = src_head->PreDetRot_2; sx.rot2.I = 1; sx.rot3.V = src_head->PreDetRot_3; sx.rot3.I = 1; } else { sx.rot1.V = 0.0; sx.rot1.I = 1; sx.rot2.V = 0.0; sx.rot2.I = 1; sx.rot3.V = 0.0; sx.rot3.I = 1; } if ( src_head->init & FL_PRECEN1 ) { sx.cen1.V = src_head->PreCenter_1; sx.cen1.I = 1; } if ( src_head->init & FL_PRECEN2 ) { sx.cen2.V = src_head->PreCenter_2; sx.cen2.I = 1; } if ( src_head->init & FL_PREDIS ) { sx.dis.V = src_head->PreSamplDis; sx.dis.I = 1; } if (sx_tf_params ( &sx, &sx, src_head->Orientat , 0, &err )) { iret=8; *pix1 = sx.pix1.V; iret-=sx.pix1.I; *pix2 = sx.pix2.V; iret-=sx.pix2.I; *pcen1 = sx.cen1.V; iret-=sx.cen1.I; *pcen2 = sx.cen2.V; iret-=sx.cen2.I; *pdis = sx.dis.V; iret-=sx.dis.I; *prot1 = sx.rot1.V; iret-=sx.rot1.I; *prot2 = sx.rot2.V; iret-=sx.rot2.I; *prot3 = sx.rot3.V; iret-=sx.rot3.I; if (iret > 0) { prmsg(ERROR,("calc_prerot: missing %d prerotation parameters.\n",iret)); goto calc_prerot_error; } } else { iret=-1; prmsg(ERROR,("calc_prerot: sx parameter transformation error %d.\n",err)); goto calc_prerot_error; } return( 0 ); calc_prerot_error: return(iret); } /* calc_prerot */ /*============================================================================== * The CORTYP header is updated with DSTRTVAL values using * upd_headval. Because the prerotations will be applied * after the distortion correction to the corrected image * the actual pixel size is copied from CORTYP to SDXTYP * and all prerotation parameters are copied from the * (previously mapped) SRCTYP header to SDXTYP. If not all * required prerotation parameters are now available in * SDXTYP it is tried to calculate them in agreement with * the following CORTYP header values: * * Center_1, Center_2, SamplDis * * The values of PreCenter_1, PreCenter_2 and PreSamplDis * are then updated with the calculated values. * * After prerotation the detector is perpendicular to the * beam, Center_1, Center_2 are equal to the beam center, * and SampleDistance is equal to the beam distance. * * int type : SDXTYP or SDYTYP * return value: 0 no error * -1 error */ int set_prerot_headval( int type ) { struct data_head *user_head; user_head = &img_head[type]; if (DO_PREROT!=2) upd_headval( CORTYP, TMPTYP, 1 ); else upd_headval( CORTYP, TMPTYP, 0 ); /* * calculate all prerotation parameters for user_head type */ if (calc_prerot( TMPTYP, 1, &(user_head->PSize_1), &(user_head->PSize_2), &(user_head->PreCenter_1), &(user_head->PreCenter_2), &(user_head->PreSamplDis), &(user_head->PreDetRot_1), &(user_head->PreDetRot_2), &(user_head->PreDetRot_3)) ) goto set_prerot_headval_error; user_head->init |= FL_PSIZ1; user_head->init |= FL_PSIZ2; user_head->init |= FL_PRECEN1; user_head->init |= FL_PRECEN2; user_head->init |= FL_PREDIS; user_head->init |= FL_PREROT1; user_head->init |= FL_PREROT2; user_head->init |= FL_PREROT3; return(0); set_prerot_headval_error: return(-1); } /* set_prerot_headval */ /*============================================================================== * Gets for all pixel points in the input image the corrected coordinates. * * There are several types of correction. Any combination of them can be * performed according to the options chosen by the user at program startup: * * - distortion correction * - dark image subtraction * - floodfield correction * - intensity normalization * - scattering background subtraction * * The buffer for the output values must have been allocated before calling * this routine in order to get any values back. If this buffer is a NULL * pointer, the routine will just free all buffers of the look-up-table * structure and return without any further action. * * If there are images for the dark image, floodfield or scattering background * corrections, then the corresponding buffers have to be set up before calling * this routine by calls to set_imgbuf(). These calls set the buffer pointers * DRK_IM, FLO_IM and BCKG_IM that are used in this routine. * * If any of the required corrections fails, the image will not be processed any * further and the routine returns with an error. * * Input : cor_im: (empty) buffer for the corrected input pixel values * src_im: buffer with the input image * Output: cor_im: buffer with the corrected pixel values for the input image * Return: -1 if any of the required corrections failed * -2 if there is no output buffer given * 0 else */ int correct_image(float *cor_im,float *src_im) { static int temp_siz = 0; static float drkconst; static float *temp_im = NULL; static struct lut_descript *lut_d = NULL; int drk_cor = DO_DARK && (DRK_IM || DRK_CONST != 0); float *ptemp,*inbuf,*outbuf; int lut_invalid = 0; /* * Free the buffers of the look-up-table structure if * - there is no buffer for the output, or * - the existing look-up table is no longer valid (then LUT_INVALID = 1, * this is in particular at program startup). * * If there is no output buffer, the routine just returns afterwards with * return status -2. */ if (LUT_INVALID || cor_im == NULL) { lut_invalid = 1; } else { if (img_head[SDXTYP].init) { if ( (DO_SPD) && (SDX_PREROT!=DO_PREROT) ) { lut_invalid = 1; } else if ( img_head[SDXTYP].Dim_1 != img_head[SRCTYP].Dim_1 + 1 || img_head[SDXTYP].Dim_2 != img_head[SRCTYP].Dim_2 + 1 || img_head[SDXTYP].BSize_1 != img_head[SRCTYP].BSize_1 || img_head[SDXTYP].BSize_2 != img_head[SRCTYP].BSize_2 || img_head[SDXTYP].Offset_1 != img_head[SRCTYP].Offset_1 - 0.5 || img_head[SDXTYP].Offset_2 != img_head[SRCTYP].Offset_2 - 0.5 ) { lut_invalid = 1; } else if (DO_PREROT) { float PSize_1, PSize_2, PreDetRot_1, PreDetRot_2, PreDetRot_3; float PreCenter_1, PreCenter_2, PreSamplDis; /* upd_headval reads from SDXTYP header. When it was never * read the flags are still 0 and nothing is done. If the shift * file was changed LUT_INVALID was already set by set_splinfil or * set_xycorin and upd_headval is not called here. * If upd_headval fails it is an error and the program * could be stopped. A return is avoided here to keep * this part of the program transparent to earlier versions. */ if (DO_PREROT!=2) upd_headval( CORTYP, TMPTYP, 1 ); else upd_headval( CORTYP, TMPTYP, 0 ); if ( calc_prerot( TMPTYP, DO_PREROT, &PSize_1, &PSize_2, &PreCenter_1, &PreCenter_2, &PreSamplDis, &PreDetRot_1, &PreDetRot_2, &PreDetRot_3 ) ) { lut_invalid = 1; } else if ( img_head[SDXTYP].PSize_1 != PSize_1 || img_head[SDXTYP].PSize_2 != PSize_2 || img_head[SDXTYP].PreCenter_1 != PreCenter_1 || img_head[SDXTYP].PreCenter_2 != PreCenter_2 || img_head[SDXTYP].PreSamplDis != PreSamplDis || img_head[SDXTYP].PreDetRot_1 != PreDetRot_1 || img_head[SDXTYP].PreDetRot_2 != PreDetRot_2 || img_head[SDXTYP].PreDetRot_3 != PreDetRot_3 ) { lut_invalid = 1; } } } } if (lut_invalid) { if(lut_d != NULL) { if(lut_d->lut) pfree(lut_d->lut); if(lut_d->prog) pfree(lut_d->prog); if(lut_d->offset_tab) pfree(lut_d->offset_tab); if(lut_d->rel_tab) pfree(lut_d->rel_tab); if(lut_d->relend_tab) pfree(lut_d->relend_tab); if(lut_d->abs_src) pfree(lut_d->abs_src); if(lut_d->xrel) pfree(lut_d->xrel); if(lut_d->yrel) pfree(lut_d->yrel); pfree(lut_d); lut_d = NULL; } if(cor_im == NULL) return(-2); LUT_INVALID = 1; } bench(NULL); /* * Calculate a new set of tables for the distortion correction, if necessary. */ if(LUT_INVALID && DO_SPD) { prmsg(DMSG,("Calculating look-up table: %d bit\n",LUT_BYTE ? 8 : 16)); if((lut_d = lut_calc()) == NULL) return(-1); LUT_INVALID = 0; bench("look-up-table calculation"); } /* * Allocate space for temporary image, if necessary. * * If there is already space allocated for it, check whether its size is * correct. Free and re-allocate if not. */ if(temp_im != NULL && (XSIZE * YSIZE * sizeof(float)) != temp_siz) { pfree(temp_im); temp_im = NULL; } if(temp_im == NULL) if((temp_im = (float *)pmalloc(XSIZE * YSIZE * sizeof(float))) == NULL) prmsg(FATAL,("no memory in correct_calc for temp src\n")); else temp_siz = XSIZE * YSIZE * sizeof(float); /* * Start the corrections: * - dark image; * - floodfield; * - distortion; * - intensity normalization; * - scattering background. * * All corrections are optional. If the corresponding files or parameters * are not defined, the correction will be skipped. * * First is the dark image correction. The image resulting from the dark image * correction can be scaled with a multiplicative and an additive input * scaling factor. * * If the user-defined flag DO_DARK is 0, the dark image correction is * suppressed. * * Afterwards is the floodfield correction, then intensity normalization and * last scattering background subtraction. * * The distortion correction can be done at various points during the * processing, depending on the DO_SPD flag set by the user: * - DO_SPD = 0 no distortion correction * = 1 after the dark subtraction, before flat field division * = 2 after the flat field division, before the normalization * = 3 after the normalization * * All corrections can be done in situ, i.e. the input and output buffer can * (but need not) be identical, with the exception of the distortion * correction, where the input and output buffer must be different. * * Therefore, in the following code, the idea is that if there is no * distortion correction, then the first correction copies the image from the * input to the output buffer, and all subsequent routines then work on the * output buffer. As there is always at least the input scaling correction * done, this guarantees that there is a valid image in the output buffer when * this routine returns. * * If there is a distortion correction, then the first correction (which might * be the input scaling correction) copies the input buffer to a temporary * buffer, all subsequent corrections before the distortion correction work in * this buffer, the distortion correction copies the temporary buffer to the * output buffer, and any corrections after that work on the output buffer. */ inbuf = src_im; outbuf = (DO_SPD != 0) ? temp_im : cor_im; /* * Dark image subtraction and scaling of input image. */ if(drk_cor) { drkconst = DRK_CONST; /* * Apply the dark image correction to the source image, then scale the * resulting image. */ prmsg(DMSG,("Correcting: dark image subtraction\n")); // ++++++++++ subtract_im(inbuf,DRK_IM,outbuf,0.,drkconst); subtract_drk(inbuf,DRK_IM,outbuf,drkconst); inbuf = outbuf; } scale_im(inbuf,outbuf,INPFACT,INPCONST,XSIZE * YSIZE); inbuf = outbuf; /* * Distortion and floodfield corrections (distortion before or after * floodfield). */ if(DO_SPD == 1) { prmsg(DMSG,("Correcting: distortion correction\n")); outbuf = cor_im; undistort_im(outbuf,inbuf,lut_d); } if(FLO_IM) { prmsg(DMSG,("Correcting: floodfield correction\n")); divide_insito_im(outbuf,FLO_IM); } if(DO_SPD == 2) { prmsg(DMSG,("Correcting: distortion correction\n")); inbuf = outbuf; outbuf = cor_im; undistort_im(outbuf,inbuf,lut_d); } /* * Intensity normalization, distortion after normalization, scattering * background corrections and distortion after background subtraction. */ if(NORM_INT) { prmsg(DMSG,("Correcting: intensity normalization\n")); if(normint_im(outbuf,outbuf,NORM_INT) != 0) return(-1); } if(DO_SPD == 3) { prmsg(DMSG,("Correcting: distortion correction\n")); inbuf = outbuf; outbuf = cor_im; undistort_im(outbuf,inbuf,lut_d); } if(BCKG_IM) { prmsg(DMSG,("Correcting: scattering background subtraction\n")); // ++++++++++++++scale_im(BCKG_IM,temp_im,BCKGFACT,BCKGCONST,XSIZE * YSIZE); // ++++++++++++++subtract_drk(cor_im,temp_im,cor_im,0.); subtract_im(outbuf,BCKG_IM,outbuf,BCKGFACT,BCKGCONST); } if(DO_SPD == 4) { prmsg(DMSG,("Correcting: distortion correction\n")); inbuf = outbuf; outbuf = cor_im; undistort_im(outbuf,inbuf,lut_d); } /* * Mark invalid pixels in the output image. * * Invalid pixels are those where at least one of the following conditions * is true: * 1) the value of the pixel in the source, dark current or scattering * background image is equal to the value of the "Dummy" keyword in the * corresponding image header; * 2) the value of the pixel in the source or dark current image is equal to * the value of the "overflow" command line argument; * 3) the value of the pixel in the source or dark current image is less * than the value of the "inp_min" command line argument or greater than * the value of the "inp_max" command line argument; * 4) the value of the pixel in the floodfield image is 0. or equal to the * value of the "Dummy" keyword in the floodfield image header. * * Pixels that correspond to conditions 1 to 3 for the source or dark * current image will be marked with the output image "Dummy" value by * mark_overflow_nocorr(). The marking is done in a temporary copy of the * input image. * * Pixels that correspond to condition 1 for the scattering background * image are marked directly in the corrected image. * * If the floodfield correction is done before the distortion correction, then * the pixels corresponding to condition 4 are marked in the temporary copy * of the input image mentioned above. If the floodfield correction is done * after the distortion correction, the corresponding pixels are marked * directly in the corrected image. * * Therefore, in this temporary copy of the input image, all invalid pixels * are now marked with the output image "Dummy" value. * * mark_overflow() takes this temporary copy of the input image, transfers * the illegal pixels to the corresponding distortion corrected pixels in * the corrected image and sets their values to the output image "Dummy" * value. Note that one input pixel may correspond to more than one output * pixel, in which case all the corresponding output pixels are set to * "Dummy". */ if ( DO_SPD != 0 ) { /* * avoid loop, because temp_in is not used for DO_SPD == 0 */ for(ptemp = temp_im + XSIZE * YSIZE - 1; ptemp >= temp_im; ptemp--) *ptemp = 0.; outbuf = temp_im; } else outbuf = cor_im; mark_overflow_nocorr(src_im,outbuf,NULL,SRCTYP); mark_overflow_nocorr(DRK_IM,outbuf,drdumlst,DRKTYP); if(DO_SPD == 1) { outbuf = cor_im; mark_overflow(temp_im,outbuf,lut_d,Dummy); } mark_overflow_nocorr(FLO_IM,outbuf,fldumlst,FLOTYP); if(DO_SPD == 2 || DO_SPD == 3) { outbuf = cor_im; mark_overflow(temp_im,outbuf,lut_d,Dummy); } if(BCKG_IM) mark_overflow_nocorr(BCKG_IM,outbuf,NULL,SBKTYP); if(DO_SPD == 4) { outbuf = cor_im; mark_overflow(temp_im,outbuf,lut_d,Dummy); } bench("image correction"); return(0); } /* correct_image */ /*============================================================================== * Exponentiates all values in the input image with an exponential constant and * stores the result in the output image. * * If the exponential constant is 1., the input image is just copied to the * output image. * * The calculation is done for each pixel of the image with the formula * * output = pow(input, exponent) * * As this calculation is slow, a lookup table "exptab" is used for all pixel * values between 0 and USHRT_MAX. The values in this table are calculated * (in the routine set_inpexp()) with the formula * * exptab(index) = pow(index, exponent) * * i.e., the exponential function is approximated in the value interval between * "index" and "index + 1" by the exponentiated value of the lower border of the * interval. The exponentiation of the input pixel values is then simply done by * * index = input * output = exptab(index) * * As the pixel values in the detector are unsigned short integers, this should * be a good approximation. Observation showed it to be correct to at least 5 * decimal digits. * * For pixel values outside this range, the real formula is used. In principle * there should be none, as the input image pixels should have the range of an * "unsigned short" integer. * * Input : src_im: buffer with the input image (float) * expconst: constant exponent for the values of the input image (float) * Output: out_im: buffer with output image (= corrected input) (float) * Return: -1 if src_im or out_im are NULL pointers * 0 else */ int expon_im(float *src_im,float *out_im,float expconst,int imgsize) { register int index; register float *tempptr,*templast; int count = 0; float *srcptr; if(src_im == NULL || out_im == NULL) return(-1); if(expconst != 1.) { /* * There is an exponential constant. Apply it to the input image. */ srcptr = src_im; tempptr = out_im; templast = out_im + imgsize - 1; while(tempptr <= templast) { index = *srcptr; if(index < 0 || index > USHRT_MAX) { *tempptr++ = pow((double)*srcptr,expconst); count++; } else *tempptr++ = *(exptab + index); srcptr++; } if(count != 0) prmsg(WARNING,("%d pixel values < 0 or > USHRT_MAX\n",count)); } else if(out_im != src_im) { /* * The exponential constant is 1., i.e. no exponentiation is to be done. * Just copy the input image to the output image. */ memcpy(out_im,src_im,imgsize * sizeof(float)); } return(0); } /* expon_im */ /*============================================================================== * Adjusts all values in the input image with an additive and a multiplicative * constant and stores the result into the output image. * * The adjustment is done for each pixel of the image with the formula * * output = input * multiplicative + additive * * It is perfectly possible for this to yield a negative value for any given * pixel, which is then written as such (i.e. negative) in the output image. * * Input : src_im: buffer with the input image (float) * mulconst: constant to be multiplied with the input image (float) * addconst: constant to be added to the input image (float) * Output: out_im: buffer with output image (= corrected input) (float) * Return: -1 if src_im or out_im are NULL pointers * 0 else */ int scale_im(float *src_im,float *out_im,register float mulconst, register float addconst,int imgsize) { register float *srcptr,*tempptr,*templast; if(src_im == NULL || out_im == NULL) return(-1); srcptr = src_im; tempptr = out_im; templast = out_im + imgsize - 1; if(addconst) { if(mulconst != 1.) { /* * There is an additive and a multiplicative constant. Multiply the input * image with the multiplicative constant, then add the additive constant. */ while(tempptr <= templast) *tempptr++ = *srcptr++ * mulconst + addconst; } else { /* * There is an additive constant, but the multiplicative constant is 1. * Add the additive constant to the input image. */ while(tempptr <= templast) *tempptr++ = *srcptr++ + addconst; } } else if(mulconst != 1.) { /* * There is no additive constant, but there is a multiplicative constant. * Multiply the the input image with the multiplicative constant. */ while(tempptr <= templast) *tempptr++ = *srcptr++ * mulconst; } else if(out_im != src_im) { /* * There is neither an additive nor a multiplicative constant. Just copy the * input image to the output image. */ memcpy(out_im,src_im,imgsize * sizeof(float)); } return(0); } /* scale_im */ /*============================================================================== * Performs a dark image subtraction for each pixel of the input image and * stores the result into the output image. * * It is perfectly possible for this subtraction to yield a negative value * for any given pixel, which is then written as such (i.e. negative) in the * output image. * * The background can be defined by the user at program startup on a pixel * basis and / or on a global basis. For the former, a background image has * to be specified that contains the pixel values for the background. For the * latter, a background constant has to be specified in the input arguments. * * There are three possibilities: * * 1) there is a background image (i.e., "drk_im" is not NULL), and the * background constant is 0. Then for each pixel the background values of * the background image are subtracted from the corresponding values in the * input image; * 2) there is no background image. Then the background constant is subtracted * from each pixel in the input image; * 3) there is a background image, but the background constant is not 0. Then * for each pixel in the input image first the background constant and then * the corresponding pixel value of the background image are subtracted from * it. * * Input : src_im: buffer with the input image (float) * drk_im: buffer with the dark image (float) * drkcin: dark image constant * Output: out_im: buffer with output image (= corrected input) (float) * Return: 0 if no errors (always at present) */ int subtract_drk(float *src_im,float *drk_im,float *out_im,float drkcin) { register float *drkptr,*srcptr,*tempptr,*templast; register float drk_const = drkcin; srcptr = src_im; tempptr = out_im; templast = out_im + XSIZE * YSIZE - 1; if(drk_im) { drkptr = drk_im; if(drk_const == 0.) { /* * There is a background image, but the global background variable is 0. * Subtract the background image from the input image. */ while(tempptr <= templast) { *tempptr++ = *srcptr++ - *drkptr++; } } else { /* * There is a background image, and the global background variable is not * 0. Subtract the global background variable and the background image * from the input image. */ while(tempptr <= templast) { *tempptr++ = *srcptr++ - drk_const - *drkptr++; } } } else { /* * There is no background image. Subtract the global background variable * from the input image. */ while(tempptr <= templast) { *tempptr++ = *srcptr++ - drk_const; } } return(0); } /* subtract_drk */ /*============================================================================== * Performs a pixel by pixel subtraction of sub_im from src_im and * writes the result into out_im. The values of sub_im are multiplied with * fac and con is added. * * It is perfectly possible for this subtraction to yield a negative value * for any given pixel, which is then written as such (i.e. negative) in the * output image. * * There are three possibilities: * * 1) sub_im != NULL, fac == 1., con == 0. * 2) sub_im != NULL * 3) sub_im == NULL * * 1) there is an image to subtract (i.e., "sub_im" is not NULL), fac is 1. * and con is 0. Then each pixel of the sub image is subtracted from * the input image and written to the output image. * 2) there is no image to subtract. Then con is subtracted from each pixel * in the input image and written to the output image. * 3) there is an image to subtract, the factor is not 1. or the constant * is not 0. Then each pixel of the sub image is multiplied with fac and * subtracted together with con from the input image. The values are * written to the output image. * * Input : src_im: buffer with the input image (float) * sub_im: buffer to be subtracted (float) * fac: multiplication factor * con: added constant * Output: out_im: buffer with output image (float) * Return: 0 if no errors (always at present) */ int subtract_im(float *src_im,float *sub_im,float *out_im,float fac,float con) { register float *subptr,*srcptr,*tempptr,*templast; register float factor, constant; srcptr = src_im; tempptr = out_im; templast = out_im + XSIZE * YSIZE - 1; if(sub_im) { subptr = sub_im; if((factor == 1.)&&(constant == 0.)) { /* * Subtract sub_im from src_im. */ while(tempptr <= templast) { *tempptr++ = *srcptr++ - *subptr++; } } else { /* * Subtract fac*sub_im+con from src_im */ while(tempptr <= templast) { *tempptr++ = *srcptr++ - constant - *subptr++*factor; } } } else { /* * There is no image to subtract. Subtract the global background variable * from the input image. */ while(tempptr <= templast) { *tempptr++ = *srcptr++ - constant; } } return(0); } /* subtract_im */ /*============================================================================== * Perform the floodfield (also called flatfield) correction and store the * result back into the input image. * * This takes into account the fact that a sample with absolutely uniform * scattering response does not necessarily produce a flat image (e.g. because * of a non-uniform detector response). If one takes a image of a real sample, * one has to correct for this non-uniformity. * * This is done by taking an image from an uniformly scattering probe (the * floodfield image) and then dividing the real image by the floodfield image. * * This routine multiplies each pixel of the input image with the value of the * corresponding pixel of the inverted floodfield image and stores the result * back into the input image. * * This routine is identical in functionality to the routine divide_im(), * except that this routine stores the result back into the input array. * * Input : src_im: buffer with the input image (float) * flo_im: buffer with the (inverted) floodfield image (float) * Output: src_im: buffer with corrected input image * Return: 0 if no errors (always at present) */ int divide_insito_im(float *src_im,float *flo_im) { register float *srclast,*srcptr,*floptr; srclast = src_im + XSIZE * YSIZE - 1; srcptr = src_im; floptr = flo_im; while(srcptr <= srclast) { *srcptr = *srcptr * *floptr++; srcptr++; } return(0); } /* divide_insito_im */ /*============================================================================== * Perform the floodfield (also called flatfield) correction and store the * result into the output image. * * This takes into account the fact that a sample with absolutely uniform * scattering response does not necessarily produce a flat image (e.g. because * of a non-uniform detector response). If one takes a image of a real sample, * one has to correct for this non-uniformity. * * This is done by taking an image from an uniformly scattering probe (the * floodfield image) and then dividing the real image by the floodfield image. * * This routine multiplies each pixel of the input image with the value of the * corresponding pixel of the inverted floodfield image and stores the result * into the output image. * * Pixels with an invalid value in the floodfield image are marked as invalid in * the output image by setting the value in the output image to "Dummy". For * details, see routine "prepare_flood()". * * This routine is identical in functionality to the routine divide_insito_im(), * except that this routine stores the result in a separate output array. * * Input : src_im: buffer with the input image (float) * flo_im: buffer with the floodfield image (float) * Output: cor_im: buffer with output image (=corrected input) (float) * Return: 0 if no errors (always at present) */ int divide_im(float *src_im,float *flo_im,float *cor_im) { register float *srcptr,*tempptr,*templast,*floptr; tempptr = cor_im; templast = cor_im + XSIZE * YSIZE - 1; srcptr = src_im; floptr = flo_im; while (tempptr <= templast) { *tempptr++ = *srcptr++ * *floptr++; } return(0); } /* divide_im */ /*============================================================================== * Normalize the input image to absolute scattering intensities, then multiply * each pixel value with the user-defined scattering intensity normalization * factor NORMFACT and store the result into the output image. * * The values for this calculation are taken from the data header parameters' * structure "img_head" for the corrected image (type == CORTYP). If this * structure does not contain all needed values, the routine returns with an * error. * * Input : src_im: buffer with the input image (float) * normint: 0: copy src_im to cor_im * 1: full normalization (I/DOmega/Intensity1*NORMFACT) * 2: normalization to Intensity1 (I/Intensity1*NORMFACT) * 3: normalization to DOmega (I/DOmega*NORMFACT) * Output: cor_im: buffer with corrected input image * Return: 0 if no errors * -1 if header parameter structure does not contain all needed values */ int normint_im(float *src_im,float *cor_im,int normint) { register int i1; register float *srcptr,*corptr; register float offcen_1,psize_1; register double rd2,rd2h,i2r_1,fact1; int i2,err; unsigned long reqflg=0; float offcen_2,psize_2; double dis,dis2,i2r_2,intens1,tmp; switch (normint) { case 1: reqflg = FL_PSIZ1 | FL_PSIZ2 | FL_OFFS1 | FL_OFFS2 | FL_CENT1 | FL_CENT2 | FL_INTE1 | FL_SAMDS; break; case 2: reqflg = FL_INTE1; break; case 3: reqflg = FL_PSIZ1 | FL_PSIZ2 | FL_OFFS1 | FL_OFFS2 | FL_CENT1 | FL_CENT2 | FL_SAMDS; break; } if((img_head[CORTYP].init & reqflg) != reqflg) { prmsg(ERROR, ("needed header parameters not set - cannot normalize intensities\n")); pr_headval(stdout, CORTYP); goto normint_im_error; } srcptr = src_im; corptr = cor_im; fact1 = NORMFACT; intens1 = 1.0; switch (normint) { case 1: // full normalization intens1 = num_str2double((img_head[CORTYP].Intens_1),NULL,&err); case 3: // normalize to DOmega psize_1 = img_head[CORTYP].PSize_1; psize_2 = img_head[CORTYP].PSize_2; offcen_1 = img_head[CORTYP].Offset_1 - img_head[CORTYP].Center_1; offcen_2 = img_head[CORTYP].Offset_2 - img_head[CORTYP].Center_2; dis = img_head[CORTYP].SamplDis; tmp = dis * psize_1 * psize_2 * intens1; if (tmp!=0.0) fact1 /= tmp; else fact1 = 0.0; // nan dis2 = dis * dis; for(i2 = 0; i2 < YSIZE; i2++) { i2r_2 = INDEX2R(i2,offcen_2,psize_2); rd2h = dis2 + i2r_2 * i2r_2; for(i1 = 0; i1 < XSIZE; i1++, corptr++, srcptr++) { i2r_1 = INDEX2R(i1,offcen_1,psize_1); rd2 = rd2h + i2r_1 * i2r_1; *corptr = *srcptr * sqrt(rd2) * rd2 * fact1; } } break; case 2: // normalize to Intensity1 intens1 = num_str2double((img_head[CORTYP].Intens_1),NULL,&err); if (intens1!=0.0) fact1 /= intens1; else fact1 = 0.0; // nan default: // just copy for(i2 = 0; i2 < YSIZE; i2++) { for(i1 = 0; i1 < XSIZE; i1++, corptr++, srcptr++) { *corptr = *srcptr * fact1; } } } return(0); normint_im_error: return(-1); } /* normint_im */ /*============================================================================== * Scans the input image for pixels marked as illegal (value = dummy) and marks * the corresponding pixels in the distortion corrected output image. * * It also marks all pixels in the corrected output image that have no * corresponding pixels in the input image. * * The value used for marking these pixels is "Dummy". This value can be defined * with the command line argument "dummy", otherwise the value of the "Dummy" * keyword in the source image header is taken. The default (if neither is * specified) is 0. * * The routine returns an error if any of the following conditions is true: * * - "dummy" is not a valid dummy value (i.e., DUMMYDEFINED() for "dummy" * returns "False"). The routine returns immediately without action; * - the pixels of the corrected output image cannot be determined (i.e., * spd_func() returns an error). * * Input : src_im: buffer with the input image (float) * lut_d: structure with the look-up-table for the distortion * corrections * dummy: value used to mark illegal pixels in the input image * Output: trg_im: buffer for the distortion corrected output image with all * pixels marked that correspond to illegal pixels in the * input image (float) * Return: 0 if successful * -1 else */ int mark_overflow(float *src_im,float *trg_im,struct lut_descript * lut_d, float dummy) { unsigned long starttidx = lut_d->starttidx; register unsigned char instruct; unsigned char *prog_ptr = lut_d->prog; float savepix; float *lastpix = src_im + XSIZE * YSIZE - 1; register float *srcptr,*trgptr; register float srcpix; short *xrel,*yrel; int i,j,multi,maxxpixel,maxypixel,sx,sy,x,y,xmin,xmax,ymin,ymax; int idx; float ddummy; #if !defined(WASTE4_FORSPEED) float dsx,dsy,dx,dy; float fx,fy; double active2 = ACTIVE_R * ACTIVE_R; double d; #endif prmsg(DMSG,("Set illegal pixels to dummy = %f\n",dummy)); ddummy = DDSET(dummy); if(!DUMMYDEFINED(dummy,ddummy)) return(-1); savepix = *lastpix; *lastpix = dummy; srcptr = src_im; maxxpixel = (lut_d->maxxpixel > 3) ? 2 : ((lut_d->maxxpixel > 1) ? 1 : 0); maxypixel = (lut_d->maxypixel > 3) ? 2 : ((lut_d->maxypixel > 1) ? 1 : 0); xrel = lut_d->xrel; yrel = lut_d->yrel; /* * Set all target pixels to "Dummy" that have no source pixel mapped onto * them. This has in principle already done by undistort_im(), but may have been * destroyed by divide_insito_im(), thus it needs to be redone here. */ trgptr = trg_im; for(i=0; i %f \n", d,dsx,dsy,active2)); if(d > active2) { srcptr++; continue; } } spd_calcspline(spline,1,1,&dsx,&dsy,&dx,&dy); x = dsx + dx + .5; y = dsy + dy + .5; #endif /* WASTE4_FORSPEED */ /* prmsg(DMSG,("Invalid pixel: [%d][%d] (%.1f) -> [%d][%d] (%.1f)\n", sx,sy,dummy,x,y,Dummy)); */ /* * One pixel in input image space can correspond to more than one pixel * in the corrected image space. Mark all corresponding pixels in the * corrected image space as "illegal". */ xmin = x - maxxpixel; if(xmin < 0) xmin = 0; xmax = x + maxxpixel; if(xmax >= XSIZE) xmax = XSIZE - 1; ymin = y - maxypixel; if(ymin < 0) ymin = 0; ymax = y + maxypixel; if(ymax >= YSIZE) ymax = YSIZE - 1; for(i = xmin; i <= xmax; i++) for(j = ymin * XSIZE; j <= ymax * XSIZE; j += XSIZE) *(trg_im + i + j) = Dummy; } srcptr++; } /* * This is just a repetition of the above code for the last pixel. Treating * this as a special case allows to make the above loop faster by having less * comparisons to make. */ *lastpix = savepix; if(DUMMY(*lastpix,dummy,ddummy)) { /* Same as above */ idx = srcptr - src_im; sx = XSIZE - 1; sy = YSIZE - 1; #if WASTE4_FORSPEED x = sx + xrel[idx]; y = sy + yrel[idx]; #else /* WASTE4_FORSPEED */ dsx = sx; dsy = sy; /* Don't do anything with illegal pixels outside the active area */ if(ACTIVE_R) { d = (dsx - XSIZE/2) * (dsx - XSIZE/2) + (dsy - YSIZE/2) * (dsy - YSIZE/2); prmsg(DMSG,("Pixel distance test : Is %f (%f,%f) > %f \n", d,dsx,dsy,active2)); if(d > active2) { return(0); } } spd_calcspline(spline,1,1,&dsx,&dsy,&dx,&dy); x = dsx + dx + .5; y = dsy + dy + .5; #endif /* WASTE4_FORSPEED */ /* prmsg(DMSG,("Invalid pixel: [%d][%d] (%.1f) -> [%d][%d] (%.1f)\n", sx,sy,dummy,x,y,Dummy)); */ xmin = x - maxxpixel; if (xmin < 0) xmin = 0; xmax = XSIZE - 1; ymin = y - maxypixel; if (ymin < 0) ymin = 0; ymax = YSIZE - 1; for(i = xmin; i <= xmax; i++) for(j = ymin * XSIZE; j <= ymax * XSIZE; j += XSIZE) trg_im[i + j] = Dummy; } return(0); } /* mark_overflow */ /*============================================================================== * Scans the input image for pixels with illegal values and marks the * corresponding pixels in the output image. * * The input image can be a source, dark current, scattering background, mask or * floodfield image (type = SRCTYP, DRKTYP, SBKTYP, MSKTYP or FLOTYP). * * If the input image is empty (NULL pointer), the routine returns without any * action. This is not an error condition. * * Illegal values are: * - "dummy" (pixels marked as dummy); * - "IMAGE_OVER" (pixels marked as overflow); * - all values smaller than "INP_MIN"; * - all values greater than "INP_MAX"; * - all values equal to zero ("0."). * * The illegal values "IMAGE_OVER", "INP_MIN" and "INP_MAX" are tested only for * source and dark current images. * * Values equal to zero are tested only for floodfield images. * * "dummy" is the value of the "Dummy" keyword in the image header of the input * image, if this is defined, otherwise it is 0. * * "IMAGE_OVER" is the value of the command line argument "overflow". The * default value is 0., meaning that there is no "IMAGE_OVER" value set. * * "INP_MIN" is the value of the command line argument "inp_min". The default * value is 0., meaning that there is no "INP_MIN" value set. * * "INP_MAX" is the value of the command line argument "inp_max". The default * value is 0., meaning that there is no "INP_MAX" value set. * * The value used for marking these pixels is "Dummy". This value can be defined * with the command line argument "dummy", otherwise the value of the "Dummy" * keyword in the source image header is taken. The default (if neither is * specified) is 0. * * If the exponentiation constant INPEXP is set, the various limits (overflow, * minimum, maximum) have to be scaled accordingly. * * Input : src_im: buffer with the input image (float) * type: type of input image * Output: trg_im: output image buffer with overflow pixels marked (float) * Return: 0 always */ int mark_overflow_nocorr(float *src_im,float *trg_im,long *dumlst,int type) { float savepix; float *lastpix = src_im + XSIZE * YSIZE - 1; register float *srcptr; register int idx; float image_over = IMAGE_OVER; float inp_max = INP_MAX, inp_min = INP_MIN; float dimage_over,dummy,ddummy; if(src_im == NULL) return(0); /* * Write the (possibly new) "Dummy" value into the header for the corrected * output image. */ img_head[CORTYP].Dummy = Dummy; img_head[CORTYP].init |= FL_DUMMY; /* * Define the "dummy" and "ddummy" values. */ if(img_head[type].init & FL_DUMMY) dummy = img_head[type].Dummy; else dummy = 0.; if(img_head[type].init & FL_DDUMM) ddummy = img_head[type].DDummy; else ddummy = DDSET(dummy); /* * For the floodfield image, a list of the pixels that have an invalid value * has been created in "prepare_flood()". Just mark the corresponding pixels * in the output image as "invalid" as well. */ if(type == FLOTYP) { if(dumlst != NULL) { register long *pdumlst; for(pdumlst = dumlst; *pdumlst != -1; pdumlst++) *(trg_im + *pdumlst) = Dummy; } return(0); } /* * Save the value of the last pixel, then set the last pixel to "dummy". * * Now test the image for the illegal value "dummy" (unless "dummy" is 0., * which indicates that it is not to be used). * * As the last pixel has been set to "dummy", the loop will terminate there. * This eliminates the need to test for the end of the image at each iteration * of the loop. */ savepix = *lastpix; if(DUMMYDEFINED(dummy,ddummy)) { *lastpix = dummy; srcptr = src_im; for(;;) { if(DUMMY(*srcptr,dummy,ddummy)) if(srcptr == lastpix) break; else { idx = srcptr - src_im; *(trg_im + idx) = Dummy; } srcptr++; } } /* * The other tests are done only for source and dark current data. * * Scale the various limits (overflow, minimum, maximum) with the * exponentiation constant INPEXP if it is set. */ if(type == SRCTYP || type == DRKTYP) { if(INPEXP != 1.) { image_over = pow((double)image_over,INPEXP); inp_max = pow((double)inp_max,INPEXP); inp_min = pow((double)inp_min,INPEXP); } /* * If "IMAGE_OVER" is set, test the image for pixels with this value. * * For terminating the loop the same trick as above is used. */ dimage_over = DDSET(image_over); if(image_over != 0.) { *lastpix = image_over; srcptr = src_im; for(;;) { if(DUMMY(*srcptr,image_over,dimage_over)) if(srcptr == lastpix) break; else { idx = srcptr - src_im; *(trg_im + idx) = Dummy; } srcptr++; } } /* * If "INP_MIN" is set, test the image for pixels with a smaller value. * * For terminating the loop the same trick as above is used. */ if(inp_min != 0.) { *lastpix = inp_min - 0.1 * fabs((double)inp_min); srcptr = src_im; for(;;) { if(*srcptr < inp_min) if(srcptr == lastpix) break; else { idx = srcptr - src_im; *(trg_im + idx) = Dummy; } srcptr++; } } /* * If "INP_MAX" is set, test the image for pixels with a greater value. * * For terminating the loop the same trick as above is used. */ if(inp_max != 0.) { *lastpix = inp_max + 0.1 * fabs((double)inp_max); srcptr = src_im; for(;;) { if(*srcptr > inp_max) if(srcptr == lastpix) break; else { idx = srcptr - src_im; *(trg_im + idx) = Dummy; } srcptr++; } } } /* * Restore the value of the last pixel and test it. */ *lastpix = savepix; if(DUMMY(*lastpix,dummy,ddummy) || (type == SRCTYP || type == DRKTYP) && (DUMMY(*lastpix,image_over,dimage_over) || (inp_min != 0. && *lastpix < inp_min) || (inp_max != 0. && *lastpix > inp_max))) { idx = srcptr - src_im; *(trg_im + idx) = Dummy; } return(0); } /* mark_overflow_nocorr */ /*============================================================================== * Map the geometry of the input image to the required form. This includes * binning in horizontal and vertical direction and calculation of the offset * and center coordinate values. * * The linearity correction is done first. For this, all values of the source * image are exponentiated with a constant. * * Input : inbuff: buffer with the input image * bin_1 : binning factor in x-direction * bin_2 : binning factor in y-direction * type : type of image * Output: outbuff: buffer with the mapped output image * Return: 0 if no errors * -1 else */ int map_imag(void *inbuff,void **outbuff,double bin_1,double bin_2,int type) { int i_1,i_2,iDim_1,iDim_2,oDim_1,oDim_2; unsigned long dispinit; float WReal1_1,WReal3_1,WReal1_2,WReal3_2,f1_1,f3_1,f1_2,f3_2; float idummy,iddummy,iOffset_1,iOffset_2,iBSize_1,iBSize_2,iPSize_1,iPSize_2, iCenter_1,iCenter_2,iPreCenter_1,iPreCenter_2; float odummy,oddummy,oOffset_1,oOffset_2,oBSize_1,oBSize_2,oPSize_1,oPSize_2, oCenter_1,oCenter_2,oPreCenter_1,oPreCenter_2; float iOff_1,iOff_2,iPs_1,iPs_2,oOff_1,oOff_2,oPs_1,oPs_2; float value,sum,weight,*pdata,*data; double oB_iB_1,oB_iB_2; struct data_head *pimghead; float none=0.; /* just a dummy */ pimghead = &img_head[type]; dispinit = pimghead->Dspinit; iDim_1 = pimghead->Dim_1; iDim_2 = pimghead->Dim_2; iOffset_1 = pimghead->Offset_1; iOffset_2 = pimghead->Offset_2; iBSize_1 = pimghead->BSize_1; iBSize_2 = pimghead->BSize_2; iPSize_1 = pimghead->PSize_1; iPSize_2 = pimghead->PSize_2; iCenter_1 = pimghead->Center_1; iCenter_2 = pimghead->Center_2; idummy = pimghead->Dummy; iddummy = pimghead->DDummy; odummy = idummy; oddummy = iddummy; iPreCenter_1 = pimghead->PreCenter_1; iPreCenter_2 = pimghead->PreCenter_2; if(type == SRCTYP || type == DRKTYP) { if(bin_1 <= 0. || bin_2 <= 0.) { prmsg(ERROR,("%s image: bin size <= 0.: x = %f, y = %f\n",typestr[type], bin_1,bin_2)); return(-1); } else { /* * Apply the linearity correction to the image. The new pixel values are: * * pix_new = pix_old ^ inp_exp */ expon_im(inbuff,inbuff,INPEXP,iDim_1 * iDim_2); if(bin_1 == 1. && bin_2 == 1.) { *outbuff = inbuff; return(0); } else prmsg(DMSG,("mapping %s image: x-bin = %f, y-bin = %f\n",typestr[type], bin_1,bin_2)); } oDim_1 = iDim_1 / bin_1; oDim_2 = iDim_2 / bin_2; oOffset_1 = iOffset_1; oOffset_2 = iOffset_2; oBSize_1 = iBSize_1; oBSize_2 = iBSize_2; oPSize_1 = iPSize_1; oPSize_2 = iPSize_2; oCenter_1 = iCenter_1; oCenter_2 = iCenter_2; AREBIN(oOffset_1,oBSize_1,oPSize_1,oCenter_1,bin_1); AREBIN(oOffset_2,oBSize_2,oPSize_2,oCenter_2,bin_2); oPreCenter_1 = iPreCenter_1; oPreCenter_2 = iPreCenter_2; AREBIN(none,none,none,oPreCenter_1,bin_1); AREBIN(none,none,none,oPreCenter_2,bin_2); } else { /* REM PB: AREBIN is designed for integer rebinning and can only be used for bin>=1. Therefore, it is not used here */ oDim_1 = img_head[SRCTYP].Dim_1; oDim_2 = img_head[SRCTYP].Dim_2; oOffset_1 = img_head[SRCTYP].Offset_1; oOffset_2 = img_head[SRCTYP].Offset_2; oBSize_1 = img_head[SRCTYP].BSize_1; oBSize_2 = img_head[SRCTYP].BSize_2; oB_iB_1 = oBSize_1 / iBSize_1; oB_iB_2 = oBSize_2 / iBSize_2; oPSize_1 = iPSize_1 * oB_iB_1; oPSize_2 = iPSize_2 * oB_iB_2; oCenter_1 = iCenter_1 / oB_iB_1; oCenter_2 = iCenter_2 / oB_iB_2; oPreCenter_1 = iPreCenter_1 / oB_iB_1; oPreCenter_2 = iPreCenter_2 / oB_iB_2; if(type == SDXTYP || type == SDYTYP) { if(dispinit & FL_OFFS1) pimghead->DspOffset_1 /= oB_iB_1; if(dispinit & FL_OFFS2) pimghead->DspOffset_2 /= oB_iB_2; if(dispinit & FL_BSIZ1) pimghead->DspBSize_1 *= oB_iB_1; if(dispinit & FL_BSIZ2) pimghead->DspBSize_2 *= oB_iB_2; if(dispinit & FL_PSIZ1) pimghead->DspPSize_1 *= oB_iB_1; if(dispinit & FL_PSIZ2) pimghead->DspPSize_2 *= oB_iB_2; if(dispinit & FL_CENT1) pimghead->DspCenter_1 /= oB_iB_1; if(dispinit & FL_CENT2) pimghead->DspCenter_2 /= oB_iB_2; if(dispinit & FL_PRECEN1) pimghead->DspPreCenter_1 /= oB_iB_1; if(dispinit & FL_PRECEN2) pimghead->DspPreCenter_2 /= oB_iB_2; /* * For displacement files, the dimensions have to be one bigger than those * of the source image, to store the displacement values of the right and * upper edge of the image. * * Also, the displacement files thus have an artificial offset of -0.5. */ oDim_1++; oDim_2++; oOffset_1 -= 0.5; oOffset_2 -= 0.5; } } if((data = (float *)pmalloc(oDim_1 * oDim_2 * sizeof(float))) == NULL) { prmsg(ERROR,("no memory for mapped %s image in map_imag\n",type)); return(-1); } if(type == SRCTYP || type == DRKTYP) { int tmp1,tmp2; tmp1 = iDim_1; tmp2 = iDim_2; IpolRebin2(inbuff,iDim_1,iDim_2,data,&tmp1,&tmp2,idummy,iddummy,bin_1, bin_2,0); } else { REALREF(iOff_1,iPs_1,iOffset_1,iBSize_1); REALREF(iOff_2,iPs_2,iOffset_2,iBSize_2); REALREF(oOff_1,oPs_1,oOffset_1,oBSize_1); REALREF(oOff_2,oPs_2,oOffset_2,oBSize_2); for(i_1 = 0; i_1 < oDim_1; i_1++) { WReal1_1 = WORLD(LOWERBORDER + i_1,oOff_1,oPs_1); WReal3_1 = WORLD(LOWERBORDER + i_1 + 1,oOff_1,oPs_1); f1_1 = INDEX(WReal1_1,iOff_1,iPs_1); f3_1 = INDEX(WReal3_1,iOff_1,iPs_1); for(i_2 = 0; i_2 < oDim_2; i_2++) { WReal1_2 = WORLD(LOWERBORDER + i_2,oOff_2,oPs_2); WReal3_2 = WORLD(LOWERBORDER + i_2 + 1,oOff_2,oPs_2); f1_2 = INDEX(WReal1_2,iOff_2,iPs_2); f3_2 = INDEX(WReal3_2,iOff_2,iPs_2); Isum2ldw(inbuff,iDim_1,iDim_2,idummy,iddummy,f1_1,f1_2,f3_1,f3_2,&sum, &weight); value = weight == 0. ? odummy : sum / weight; pdata = ABSPTR(data,oDim_1,oDim_2,i_1,i_2); *pdata = value; } } } pimghead->Dim_1 = oDim_1; pimghead->Dim_2 = oDim_2; pimghead->Offset_1 = oOffset_1; pimghead->Offset_2 = oOffset_2; pimghead->BSize_1 = oBSize_1; pimghead->BSize_2 = oBSize_2; pimghead->PSize_1 = oPSize_1; pimghead->PSize_2 = oPSize_2; pimghead->Center_1 = oCenter_1; pimghead->Center_2 = oCenter_2; pimghead->Dummy = odummy; pimghead->DDummy = oddummy; pimghead->PreCenter_1 = oPreCenter_1; pimghead->PreCenter_2 = oPreCenter_2; /* * Divide the displacement files by the mapping factor (as the image sizes are * now different by "mapping factor", the displacements have to be scaled * correspondingly as well). */ if(type == SRCTYP) set_headval(img_head[type],SRCTYP); else if(type == SDXTYP && iBSize_1 != oBSize_1) scale_im(data,data,iBSize_1 / oBSize_1,0.,oDim_1 * oDim_2); else if(type == SDYTYP && iBSize_2 != oBSize_2) scale_im(data,data,iBSize_2 / oBSize_2,0.,oDim_1 * oDim_2); *outbuff = data; return(0); } /* map_imag */ /*============================================================================== * Name * interval_compare * * Synopis * int interval_compare( float R1, float R3, float S1, float S3 ) * * Arguments * [R1, R3]: coordinate interval of correction image (e.g. interval covered * by spatial distortion correction, flatfield, background), * [S1, S3]: coordinate interval of source image (must be smaller or equal) * * Return value * 0: OK, interval R fully covers interval S * -1: BAD, interval R does not fully cover interval S * (some pixels in S cannot be corrected and must be replaced with dummies) */ int interval_compare(float R1,float R3,float S1,float S3) { float r1, r3, s1, s3; int value; // order coordinates if(R1<=R3) { r1 = R1; r3 = R3; } else { r1 = R3; r3 = R1; } if(S1<=S3) { s1 = S1; s3 = S3; } else { s1 = S3; s3 = S1; } // [r1,r3] must cover [s1,s3] if((r1<=s1)&&(s3<=r3)) value=0; else value = -1; return(value); } /* interval_compare */ /*============================================================================== * Name * region_compare * * Description * The return value is only 0 if the region coordinates of all pixels in * image R ("region R") fully cover the region coordinates of all pixels in * image S ("region S"). Image S is the image that should be corrected, i.e. * the source image. * * The test in the calling program should look like * * ... * if ( region_compare( ROffset_1, RBSize_1, RDim_1, * ... ) ) { printf("WARNING: ...\n"); } * ... * * This check should be applied to all correction images, whether they are * mapped or not. * * This check should also be applied to the distortion images that have been * calculated by a spatial distortion spline. For undefined Offset (0.0) and * BSize (1.0) values default values (in parentheses) should be used. * * Synopis * #include * int region_compare(int type, float ROffset_1, float RBSize_1, float RDim_1, * float ROffset_2, float RBSize_2, float RDim_2, * float SOffset_1, float SBSize_1, float SDim_1, * float SOffset_2, float SBSize_2, float SDim_2); * * Arguments * * int type: type of correction image * * float ROffset_1, float RBRize_1, float RDim_1, * float ROffset_2, float RBRize_2, float RDim_2: * Offset, BSize and Dim of correction image (e.g. distortion images (either * calculated from spatial distortion spline or read from distortion * file), flatfield, background) * * float SOffset_1, float SBSize_1, float SDim_1, * float SOffset_2, float SBSize_2, float SDim_2: * Offset, BSize and Dim of source image * * [R1, R3]: region of correction image * [S1, S3]: region of source image * * Return value * 0: OK, region R fully covers region S * -1: BAD, region R does not fully cover region S * (some pixels cannot be corrected and will be replaced with dummies) */ int region_compare(int type,float ROffset_1,float RBSize_1,float RDim_1, float ROffset_2,float RBSize_2,float RDim_2, float SOffset_1,float SBSize_1,float SDim_1, float SOffset_2,float SBSize_2,float SDim_2) { float R1_1,R1_2,R3_1,R3_2,S1_1,S1_2,S3_1,S3_2; float value=-1; /* correction image (to be tested) */ R1_1=INDEX2R(LOWERBORDER,ROffset_1,RBSize_1); R3_1=INDEX2R(LOWERBORDER+RDim_1,ROffset_1,RBSize_1); R1_2=INDEX2R(LOWERBORDER,ROffset_2,RBSize_2); R3_2=INDEX2R(LOWERBORDER+RDim_2,ROffset_2,RBSize_2); /* input image */ S1_1=INDEX2R(LOWERBORDER,SOffset_1,SBSize_1); S3_1=INDEX2R(LOWERBORDER+SDim_1,SOffset_1,SBSize_1); S1_2=INDEX2R(LOWERBORDER,SOffset_2,SBSize_2); S3_2=INDEX2R(LOWERBORDER+SDim_2,SOffset_2,SBSize_2); if(!(interval_compare(R1_1,R3_1,S1_1,S3_1) || interval_compare(R1_2,R3_2,S1_2,S3_2))) value=0; else { prmsg(ERROR,("inconsistent coordinate ranges\n")); prmsg(MSG, ("%s region coord. 1: [%6.1f, %6.1f], coord. 2: [%6.1f, %6.1f]\n", *(typestr + type),R1_1,R3_1,R1_2,R3_2)); prmsg(MSG, ("source region coord. 1: [%6.1f, %6.1f], coord. 2: [%6.1f, %6.1f]\n", S1_1,S3_1,S1_2,S3_2)); } return(value); } /* region_compare */ /*============================================================================== * Integrate and average the input image azimuthally. * * The values for this calculation are taken from the data header parameters' * structure "img_head" for the corrected image (type == CORTYP). If this * structure does not contain all needed values, the routine returns with an * error. * * Input : I1Data : buffer with the input image (float) * r0 : minimum radius for azimuthal integration (in meter) * rstep : dimension of the output array in radial direction * a0 : start angle for azimuthal integration (in radian) * da : angular interval for azimuthal integration (in radian) * astep : dimension of the output array in angular direction * apro : Projection type of azimuthally regrouped image if * different from 0 (IO_NoPro). * avesfac : scale factor for "s" values of the averaged image * verbose : verbose level * Output: I0Data : buffer with the azimuthal integrated image * avedata: buffer with the averaged image * Return: 0 if no errors * -1 if header parameter structure does not contain all needed values * -2 if illegal parameters for integration are given in the input */ int azim_int(float *I1Data,float *I0Data,float *avedata,float r0,int rstep, float a0,float da,int astep,int apro, float avesfac, int verbose) { int i_1,I0Dim_1,i_2,I0Dim_2,I1Dim_1,I1Dim_2; unsigned long reqflg; float *pI0Data, *pavedata = avedata; float *pavevardata=NULL; //avedata and avevardata have the same size float I0Offset_1,I0Offset_2,I1Offset_1,I1Offset_2; float I0PSize_1,I0PSize_2,I1PSize_1,I1PSize_2; float I0Center_1,I0Center_2,I1Center_1,I1Center_2; float I1DetRot1, I1DetRot2, I1DetRot3; float I0Dummy,I0DDummy,I1Dummy,I1DDummy; double samdis,wavlen=WaveLength0; int I1Pro, I0Pro; float Angle0, Angle1; float AngleMin, AngleMax; float dr; float *E0Data=NULL,*pE0Data; float *E1Data=NULL; int vsum=0, ave=1; // no sum, calculate azimuthal average int status; reqflg = FL_PSIZ1 | FL_PSIZ2 | FL_OFFS1 | FL_OFFS2 | FL_CENT1 | FL_CENT2 | FL_SAMDS | FL_WAVLN | FL_PRO; if((img_head[CORTYP].init & reqflg) != reqflg) { prmsg(ERROR, ("header parameters incomplete - cannot integrate over azimuth\n")); return(-1); } if(r0 < 0. || rstep <= 0 || da <= 0. || astep <= 0) { prmsg(ERROR,("wrong integration parameters r0 = %f, rstep = %d\n",r0, rstep)); prmsg(ERROR,(" da = %f, astep = %d\n",da, astep)); return(-2); } bench(NULL); img_head[AZITYP] = img_head[CORTYP]; /* * Variables starting with "I1" are for the input, those starting with "I0" * for the output image. */ I1Dim_1 = XSIZE; I1Dim_2 = YSIZE; I1Offset_1 = img_head[CORTYP].Offset_1; I1Offset_2 = img_head[CORTYP].Offset_2; I1PSize_1 = img_head[CORTYP].PSize_1; I1PSize_2 = img_head[CORTYP].PSize_2; I1Center_1 = img_head[CORTYP].Center_1; I1Center_2 = img_head[CORTYP].Center_2; I1Dummy = img_head[CORTYP].Dummy; I1DDummy = img_head[CORTYP].DDummy; samdis = img_head[CORTYP].SamplDis; wavlen = img_head[CORTYP].WaveLeng; I1DetRot1 = img_head[CORTYP].DetRot_1; I1DetRot2 = img_head[CORTYP].DetRot_2; I1DetRot3 = img_head[CORTYP].DetRot_3; if(strlib_ncasecmp("Saxs",img_head[CORTYP].ProjTyp,4) == 0) I1Pro = IO_ProSaxs; else { I1Pro = IO_ProWaxs; strcpy(img_head[AZITYP].ProjTyp,"Waxs"); } dr = PSIZE2N(MIN2(fabs(I1PSize_1),fabs(I1PSize_2))); I0Dim_1 = rstep; I0Dim_2 = astep; img_head[AZITYP].PSize_1 = I0PSize_1 = R2PSIZE(dr); img_head[AZITYP].PSize_2 = I0PSize_2 = R2PSIZE(da); img_head[AZITYP].BSize_1 = 1.; img_head[AZITYP].BSize_2 = 1.; img_head[AZITYP].Offset_1 = I0Offset_1 = 0.; img_head[AZITYP].Offset_2 = I0Offset_2 = 0.; img_head[AZITYP].Center_1 = I0Center_1 = -R2CENTER(r0,I0PSize_1); img_head[AZITYP].Center_2 = I0Center_2 = -R2CENTER(N2PSIZE(a0),I0PSize_2); img_head[AZITYP].Dummy = I0Dummy = I1Dummy; img_head[AZITYP].DDummy = I0DDummy = DDSET(I0Dummy); /* * Use input projection I1Pro as default for projection I0Pro of * azimuthally regrouped image (modification with command line * option azim_pro) */ if (apro) I0Pro = apro; else I0Pro = I1Pro; strcpy(img_head[AZITYP].ProjTyp,(I0Pro==IO_ProSaxs)?"Saxs":"Waxs"); img_head[AVETYP] = img_head[AZITYP]; // preset output arrays with dummies pI0Data=I0Data; for(i_2=0; i_2 < I0Dim_2; i_2++) for(i_1=0; i_1 < I0Dim_1; i_1++) *(pI0Data++)=I0Dummy; if (E0Data) { pE0Data=E0Data; for(i_2=0; i_2 < I0Dim_2; i_2++) for(i_1=0; i_1 < I0Dim_1; i_1++) *(pE0Data++)=VarDummy; } // azimuthal regrouping /* * angular reference system is always Normal */ Angle0=INDEX2N(LOWERBORDER,I0Offset_2,I0PSize_2,I0Center_2); Angle1=INDEX2N(LOWERBORDER+I0Dim_2,I0Offset_2,I0PSize_2,I0Center_2); AngleMin = MIN2(Angle0,Angle1); AngleMax = MAX2(Angle0,Angle1); /* * angular regrouping, use radial reference system Saxs to regroup image */ ang_sum ( IO_Saxs, I0Data, E0Data, I0Dim_1, I0Dim_2, I0Offset_1, I0PSize_1, I0Center_1, I0Offset_2, I0PSize_2, I0Center_2, samdis, wavlen, I0Pro, I0Dummy, I0DDummy, I1Data, E1Data, I1Dim_1, I1Dim_2, I1Offset_1, I1PSize_1, I1Center_1, I1Offset_2, I1PSize_2, I1Center_2, samdis, wavlen, I1DetRot1, I1DetRot2, I1DetRot3, I1Pro, I1Dummy, I1DDummy, AngleMin, AngleMax, 0.0, 0.0, vsum, ave, (verbose>=2)?1:0, &status ); // print debug info // azimuthal averaging // 1st row labels (modulus of scattering vector) for(i_1=0; i_1 < I0Dim_1; i_1++) { /* * "s" value calculation depends on projection type I0Pro: * - "Saxs" normal image * - "Waxs" image that has been projected to the Ewald sphere */ if(I0Pro == IO_ProSaxs) *pavedata = 2. * sin(0.5 * atan2((double)INDEX2N(i_1,I0Offset_1, I0PSize_1,I0Center_1),samdis)) * WAVENUMBER(wavlen) * avesfac; else *pavedata = INDEX2S(i_1,I0Offset_1,I0PSize_1,I0Center_1,samdis,wavlen) * avesfac; pavedata++; } // 2nd row data (angular average) /* angular averaging */ project_1 ( pavedata, pavevardata, I0Dim_1, 0, I0Dim_1-1, I0Dummy, 1.0, I0Data, E0Data, I0Dim_1, I0Dim_2, A2INDEX(0.0),A2INDEX(I0Dim_1),1.0, A2INDEX(0.0),A2INDEX(I0Dim_2), I0Dummy, I0DDummy, ave ); // next row pavedata += I0Dim_1; pavevardata += I0Dim_1; bench("azimuthal regrouping"); return(0); } /* azim_int */ /*============================================================================== * Performs the distortion correction on the input image. * * Determines for each pixel in the output image which pixels in the input * image contribute to it, and which fraction of the area of each of those * input pixels is mapped on the output pixel being processed. It then uses * these fractions to calculate the pixel value of the output pixel: for each * contributing input pixel, it multiplies the pixel's value with the * corresponding fraction, and sums these values over all contributing input * pixels. * * Input : cor_im: (empty) buffer for the corrected input pixel values * src_im: buffer with the input image * lut_d: structure with the look-up-table for the distortion * corrections * Output: cor_im: buffer with the corrected pixel values for the input image * Return: 0 if no errors */ int undistort_im(float *cor_im,float *src_im,struct lut_descript *lut_d) { /* * starttidx contains the number of empty pixels at the beginning of the * target image, i.e. it is the index of the first non-empty pixel * in the target image array. * startsidx is the index of the corresponding pixel in the source image * array */ unsigned long startsidx = lut_d->startsidx; unsigned long starttidx = lut_d->starttidx; unsigned char *prog = lut_d->prog; LUT_TYPE *lut = lut_d->lut; unsigned short *asrc = lut_d->abs_src; unsigned char *prog_ptr = prog; LUT_TYPE *lut_ptr = lut; int multi; int i = 0; register int *rel_tab,**relend_tab; register int *offset_tab; register int *r_ptr; register int *relend; register float *src_p; register float *cor_p; unsigned short *abs_ptr = asrc; register float add = 0.; register float fullscale = FULLSCALE; register float dummy = Dummy; register unsigned char instruct; offset_tab = lut_d->offset_tab; rel_tab = lut_d->rel_tab; relend_tab = lut_d->relend_tab; /* * Determine the starting point for processing in the source and target * images, skipping over all empty pixels at the beginning of the images. * * Set the value of these empty pixels in the target image to Dummy. */ src_p = src_im + startsidx; cor_p = cor_im; for(i=0; ilut" * (default type "unsigned short"). * * Now they have to be divided by this value to yield the correct image * values. * * The default value is: FULLSCALE = 0x800. */ *cor_p++ = add / fullscale; } if ( NORM_PREROT && DO_PREROT && (M_COR != NULL) ) { /* * multiply cor_im with M_COR (prerotation normalization) */ float *pcor_m=M_COR; float *pcor_im, *pend; prmsg(DMSG,("undistort_im: prerotation normalization\n")); pcor_im = cor_im; pend = pcor_im + (XSIZE * YSIZE); while (pcor_im x * | * 3 2 V y * * MARKER: IX+1, IY+1 */ idx = ix + iy * xsize1; fx[0] = x_trg[idx]; fy[0] = y_trg[idx]; fx[1] = x_trg[idx + 1]; fy[1] = y_trg[idx+1]; fx[2] = x_trg[idx + xsize1 + 1]; fy[2] = y_trg[idx + xsize1 + 1]; fx[3] = x_trg[idx + xsize1]; fy[3] = y_trg[idx + xsize1]; /* * Determine the x and y size in corrected pixel indices (integers) of the * mapped square (= mapped source pixel). */ minmax4(fx[0],fx[1],fx[2],fx[3],&fxmin,&fxmax); minmax4(fy[0],fy[1],fy[2],fy[3],&fymin,&fymax); if(fxmin < 0 || fymin < 0 || fxmax > XSIZE || fymax > YSIZE) continue; xmin = floor(fxmin); xmax = ceil(fxmax); ymin = floor(fymin); ymax = ceil(fymax); /* * Determine the minimum and maximum distortion as well as the maximum * size of all pixel squares in the image. */ if(xmax - xmin > MAX_PIXELSIZE || ymax - ymin > MAX_PIXELSIZE) continue; if(max_xdist < fabs(fx[0] - ix)) max_xdist = fabs(fx[0] - ix); if(max_ydist < fabs(fy[0] - iy)) max_ydist = fabs(fy[0] - iy); if(min_xdist > fabs(fx[0] - ix)) min_xdist = fabs(fx[0] - ix); if(min_ydist > fabs(fy[0] - iy)) min_ydist = fabs(fy[0] - iy); if(max_ysize < ymax - ymin) max_ysize = ymax - ymin; if(max_xsize < xmax - xmin) max_xsize = xmax - xmin; /* * Increase the contribution count for each target pixel to which this * source pixel contributes. * * At the end of the loop over the source pixels, "offsets" contains for * each target pixel the number of source pixels that contribute to it. */ for(j = ymin; j < ymax; j++) { for(i = xmin; i < xmax; i++) { tidx = i + XSIZE * j; offsets[tidx]++; } } } } /* * Prepare the look-up table "lut_tab", the look-up-table program "lut_prog" * and the source coordinate array "abs_src". * * The look-up table will contain for every source pixel the part (fraction) * of that pixel's area that is mapped into each of the target pixels. * * The look-up-table program will contain for every target pixel the * information which source pixels contributed to it. * * The source coordinate array will contain for every target pixel the (x,y) * coordinates of the first source pixel that contributes to it. * * In detail: * * look-up table "lut_tab": * - the look-up table contains for each target pixel a sequence of numbers. * The length of each sequence is the number of source pixels that are * mapped into this target pixel. If there are no source pixels mapped into * a particular target pixel, then the length is set to 1; * - each number in a given sequence corresponds to one of the source pixels. * It gives, for target pixel "i" and source pixel "j", the part (fraction) * of the area of "j" that maps into "i"; * - the beginning of each sequence is given by the indices in the offset * table "offsets" in the following form: * * lut_tab[offsets[tidx]] = first element of the sequence * for target pixel "tidx" * * - the values (fractions) stored in the look-up table are constrained to be * less than FULLSCALE (normally 0x8000); * - in the beginning of each sequence, the value to be stored is "OR"ed with * BITMASK (normally 0x8000). * * look-up-table program "lut_prog": * - the look-up-table program contains for each target pixel a sequence of * instructions. In this sequence, there is one instruction for every * source pixel that is mapped into this target pixel. If there are no * source pixels mapped into a particular target pixel, then there is * still one instruction; * - from the instructions, the coordinates of the source pixels can be * determined in the following way: * * -- the instructions are 8 bit long; * -- the information concerning the y coordinate is in the 4 high bits, * the one for the x coordinate in the 4 low bits; * -- the first instruction of a sequence is always 0x88, the coordinates * of the first source pixel are obtained from the source coordinate * array; * -- the (x,y) coordinates of all subsequent source pixels are stored in * the corresponding instructions as relative values to the last pixel. * For pixel "i" of a sequence, the instruction value as a hexadecimal * number "yx" is given by * y = y(i-1) - y(i) + 8 * x = x(i-1) - x(i) + 8 * -- the maximum difference in x or y that is allowed by the program is * +-7, i.e. the present pixel can be at most 7 pixels to the left or * 7 pixels to the right of the last one, and likewise 7 pixels above * or 7 pixels below the present one. As an additional restriction, the * difference in x and in y must not be +7 simultaneously (this is to * prevent a valid instruction from having the initialization value * 0xff); * -- if there is no source pixel mapped into a particular target pixel, the * (one) corresponding program instruction has the initialization value * 0xff. * * - the beginning of each sequence is given by the indices in the offset * table "offsets" in the following form: * * lut_prog[offsets[tidx]] = first instruction of the sequence * for target pixel "tidx" * * source coordinate array "abs_src": * - the source coordinate array contains for each target pixel the x and * the y coordinate of the first source pixel that contributes to it; * - if there is no source pixel that contributes to a given target pixel, * then the coordinates are 0xffff (= initialization value); * - for target pixel "tidx", "abs_src[2 * tidx]" contains the x coordinate * and "abs_src[2 * tidx + 1]" contains the y coordinate. * * First, fill the offset table. * * For each target pixel, the offset has to be incremented by the length of * its corresponding sequence in "lut_tab" and "lut_prog" (that is the number * of contributing source pixels, or one if there is no contributing source * pixel). * * The total length of all sequences thus is equal to the length of the * look-up table. */ max_ocount = 0; max_oidx = 0; for(count_parts = 0, offset_p = offsets, i = 0; i < xysize; i++) { if(*offset_p == 0) count_parts += 1; else count_parts += *offset_p; if(max_ocount < *offset_p) { max_ocount = *offset_p; max_oidx = i; } *offset_p++ = count_parts; } prmsg(MSG,("Max Distortion: x = %f y = %f\n",max_xdist,max_ydist)); prmsg(MSG,("Min Distortion: x = %f y = %f\n",min_xdist,min_ydist)); prmsg(MSG,("Max Pixel size: x = %d y = %d\n",max_xsize,max_ysize)); prmsg(MSG,("Max SRC Pixel in Target : %d at [%d,%d]\n", max_ocount,max_oidx % XSIZE,max_oidx / XSIZE)); prmsg(MSG,("Parts Count total: %d\n",count_parts)); lut_d->maxxpixel = max_xsize; lut_d->maxypixel = max_ysize; /* * Allocate memory for the look-up table, and initialize the parts sequences. * * The initialization is as follows: * - the beginning of each sequence is set to BITMASK; * - all other values are set to 0. */ prog_length = count_parts; lut_ptr = lut_tab = (LUT_TYPE *)pmalloc(sizeof(LUT_TYPE) * count_parts); if(lut_tab == NULL) { prmsg(FATAL,("no memory for lut\n")); } memset(lut_tab,0,prog_length * sizeof(LUT_TYPE)); lut_tab[0] = BITMASK; for(offset_p = offsets, i = 0; i < xysize - 1; i++) { lut_tab[*offset_p++] = BITMASK; } /* * Allocate memory for the look-up-table program, and initialize all * instructions to 0xff. */ if ((prog_ptr = lut_prog = (unsigned char *) pmalloc(sizeof(char) * prog_length)) == NULL) { prmsg(FATAL,("no memory for prog\n")); } memset(lut_prog,0xff,prog_length * sizeof(char)); /* * Allocate memory for the source coordinate array, and initialize all * coordinates to 0xffff. */ if((abs_src = (unsigned short *) pmalloc(2 * sizeof(short) * xysize)) == NULL) { prmsg(FATAL,("no memory for abs_src\n")); } memset(abs_src,0xff,2 * sizeof(short) * xysize); print_memsize(); prmsg(MSG,("Going to produce the correction program\n")); flush_interval = YSIZE / 64; flush_cnt = 0; /* * Loop over all source pixels and get the corresponding corrected coordinate * values (target pixels). * * Then determine for every target pixel how many source pixels contribute to * it, and what fraction of each source pixel's area goes into that particular * target pixel. */ for(iy = 0; iy < YSIZE; iy++) { if(flush_cnt++ > flush_interval) { flush_cnt = 0; prmsg(MSG | PRERR,(".")); } for(ix = 0; ix < XSIZE; ix++) { /* * Get the corrected (x,y) coordinate values (fx,fy) for the corners of * the square formed by the present point and the three neighboring ones. * * The present point has index 0, the others are arranged as follows: * * 0 1 |---> x * | * 3 2 V y */ idx = ix + iy * xsize1; fx[0] = x_trg[idx]; fy[0] = y_trg[idx]; fx[1] = x_trg[idx + 1]; fy[1] = y_trg[idx+1]; fx[2] = x_trg[idx + xsize1 + 1]; fy[2] = y_trg[idx + xsize1 + 1]; fx[3] = x_trg[idx + xsize1]; fy[3] = y_trg[idx + xsize1]; minmax4(fx[0],fx[1],fx[2],fx[3],&fxmin,&fxmax); minmax4(fy[0],fy[1],fy[2],fy[3],&fymin,&fymax); if(fxmin < 0 || fymin < 0 || fxmax > XSIZE || fymax > YSIZE) continue; /* * Determine for the source pixel whose corrected coordinates are in * (fx,fy) the target pixels that it is mapped on, and the area of the * source pixel that is mapped into each of the target pixels. * * On return from calcparts(), the array "parts" contains these areas. It * represents a two-dimensional array in target x and y pixel indices, * with x increasing fastest. The index ranges are xmin <= x <= xmax and * ymin <= y <= ymax. */ xmin = floor(fxmin); xmax = ceil(fxmax); ymin = floor(fymin); ymax = ceil(fymax); if(xmax - xmin > MAX_PIXELSIZE || ymax - ymin > MAX_PIXELSIZE) { prmsg(WARNING, ("target size of pixel (%d,%d) too big (>%d): siz=(%d,%d)\n",ix,iy, MAX_PIXELSIZE,xmax - xmin,ymax - ymin)); continue; } else { calcparts(fx,fy,0,parts,&xmin,&xmax,&ymin,&ymax,&total); if(total < 1E-6) { prmsg(WARNING,("pixel [%f,%f], [%f,%f], [%f,%f], [%f,%f] is 0\n", fx[0],fy[0],fx[1],fy[1],fx[2],fy[2],fx[3],fy[3])); prmsg(WARNING,(" ix: %d iy: %d\n",ix,iy)); continue; } } max_pixelpart = 0; max_pixellut = NULL; pidx = 0; psum = 0; #if BOUND_CHECK if(xmax >= XSIZE || xmin < 0 || ymax >= YSIZE || ymin < 0) prmsg(FATAL,("target pixel out of bounds %d %d %d %d\n", xmin,xmax,ymin,ymax)); #endif /* BOUND_CHECK */ /* * Loop over all target pixels that have contributions from the source * pixel being processed. */ for(j = ymin; j <= ymax; j++) { for(i = xmin; i <= xmax; i++) { /* * Determine for the target pixel the start locations in the look-up * table, the look-up-table program and the source coordinate array. */ if(i == 0 && j == 0) offset = 0; else offset = offsets[i + j * XSIZE - 1]; prog_ptr = lut_prog + offset; /* start point program */ lut_ptr = lut_tab + offset; /* start point LUT */ abs_ptr = abs_src + 2 * (i + j * XSIZE); /* start point coor. arr. */ #if BOUND_CHECK /* * Determine end location in look-up-table program (to prevent * overwriting of program). */ if(i == XSIZE - 1 && j == YSIZE - 1) lastoffset = prog_length - 1; else lastoffset = offsets[i + j * XSIZE] - 1; if(!(*lut_ptr & BITMASK)) prmsg(ERROR,("target bit is unset for %d (*lut_ptr = 0x%x)\n", offset,*lut_ptr)); #endif /* BOUND_CHECK */ /* * The contributions of each source pixel to each target pixel are so * far expressed as absolute area values. * * Convert them into relative values by dividing each of those area * values by the total area that the corresponding source pixel * covers in the target space. * * Technical remark: the fraction is expressed as an integer on a * scale from 0 to FULLSCALE (normally 0x8000 = 32768). */ part = (parts[pidx] / (float)total * (float)FULLSCALE + .5); /* * Fill the source coordinate array, the look-up table, and the * look-up-table program with the values for this particular target * pixel. * * If there is no source pixel contributing to this target pixel, * then skip this part. */ if(part == 0) { pidx++; continue; } /* * Fill the source coordinate array. * * If this is the first source pixel that contributes to this target * pixel, fill its x and y coordinates in the source coordinate * array. * * Otherwise, get the coordinates of the first contributing source * pixel from the source coordinate array. */ if(*abs_ptr == 0xffff) { first = 1; src_x = *abs_ptr++ = ix; src_y = *abs_ptr = iy; } else { first = 0; src_x = *abs_ptr++; src_y = *abs_ptr; } /* * Fill the look-up-table program. * * Go through the instructions of the look-up-table program for this * target pixel and calculate the (x,y) coordinates of all source * pixels that have already been processed for this target pixel. * * This loop ends when encountering an instruction that has still the * initialization value 0xff (note that this cannot be a valid * instruction for coordinate calculations). * * At the end of the loop, src_x and src_y contain the (x,y) * coordinates of the last source pixel already processed for this * target pixel. */ while((old_instruct = *prog_ptr) != 0xff) { prog_ptr++; lut_ptr++; src_x += (old_instruct & 0x0f) - 8; src_y += ((old_instruct & 0xf0) >> 4) - 8; } #if BOUND_CHECK if(src_x >= XSIZE || src_x < 0 || src_y >= YSIZE || src_y < 0) prmsg(MSG,("Source pixel out of bounds in %d %d %d (0x%x 0x%x)\n", prog_ptr - lut_prog,src_x,src_y,instruct,part)); #endif /* BOUND_CHECK */ /* * Calculate in x and y the difference between the last and the * present source pixel and store them in the instruction. For * details, see the description of the look-up-table program further * above. */ instruct = (ix - src_x + 8) + ((iy - src_y + 8) << 4); if(abs(src_x - ix) > 7 || abs(src_y - iy) > 7 || instruct == 0xff) { #if BOUND_CHECK prmsg(MSG,("Source pixel area too big in %d [%d,%d] [%d,%d]\n", prog_ptr - lut_prog,src_x,src_y,ix,iy)); #endif /* BOUND_CHECK */ count_deleted++; pidx++; if(first) { prmsg(FATAL,("cannot happen")); } continue; } #if BOUND_CHECK if(prog_ptr > lut_prog + lastoffset) prmsg(FATAL,("about to overwrite LUT program in %d (>%d)\n", prog_ptr - lut_prog,lastoffset)); #endif /* BOUND_CHECK */ *prog_ptr = instruct; /* * Fill the look-up table. * * The locations in the look-up table and the look-up-table program * must always be synchronized. The pointer for the look-up table * has been increased above simultaneously with the one for the * look-up-table program, thus it now points to the location in the * look-up table where the contribution from source pixel (ix,iy) to * target pixel (i,j) should go. * * Store this contribution in the look-up table. For details, see the * description of the look-up table further above. */ if(part > max_pixelpart) { max_pixelpart = part; max_pixellut = lut_ptr; } psum += part; if(part >= FULLSCALE) part = 0; if(first) part |= BITMASK; #if BOUND_CHECK if(first && !(*lut_ptr & BITMASK)) prmsg(ERROR,("target bit is unset for %d (*lut_ptr = 0x%x)\n", lut_ptr - lut_tab,*lut_ptr)); if(!first && (*lut_ptr & BITMASK)) prmsg(ERROR,("target bit is set for %d (*lut_ptr = 0x%x)\n", lut_ptr - lut_tab,*lut_ptr)); #endif /* BOUND_CHECK */ *lut_ptr = part; #if BOUND_CHECK /* * At the beginning of a sequence, the BITMASK flag must be set in * the look-up table and the corresponding look-up-table program * instruction must be 0x88. If not, exit with error. */ if(*lut_ptr & BITMASK) if(*prog_ptr != 0x88) prmsg(FATAL,("instruction != 0x88 but 0x%x (0x%x in %d)\n", *prog_ptr,*lut_ptr,prog_ptr - lut_prog)); else /* * count_ff only here for debugging */ count_ff++; #endif /* BOUND_CHECK */ pidx++; } } /* * End of the loop processing the target pixels for this source pixel. * * The sum of all contributions (parts) of this source pixel should be * equal to FULLSCALE (because of the way the parts are normalized). If * this is not the case, then there have been rounding errors. Attribute * the difference (i.e., FULLSCALE - sum of all parts) to the target pixel * that has the largest contribution from this source pixel - that seems * to be the best choice. Note that this difference can be negative, then * the content of this target pixel will get smaller. * * Note that no value in the look-up table must be equal to FULLSCALE * because it would create confusion with the meaning of BITMASK. * Therefore, if a pixel has really the value FULLSCALE, hide it as 0. * Real target pixels cannot have a 0 contribution, because then they * would not have been included in the list of pixels that the source * pixel contributes to. */ if(max_pixellut && psum != FULLSCALE) { int savelut; savelut = *max_pixellut & MAPSCALE; if(savelut == 0) savelut = FULLSCALE; part = savelut + FULLSCALE - psum; if(part >= FULLSCALE) part = 0; if(*max_pixellut & BITMASK) *max_pixellut = part | BITMASK; else *max_pixellut = part; #if BOUND_CHECK if(*max_pixellut & BITMASK) { instruct = lut_prog[max_pixellut - lut_tab]; if(instruct != 0x88) prmsg(FATAL,("prog != 0x88 max_p 0x%x (0x%x in %d) 0x%x %d\n", instruct,*max_pixellut,prog_ptr - lut_prog,savelut,psum)); else /* * count_ff only here for debugging */ count_ff++; } #endif /* BOUND_CHECK */ } } } prmsg(MSG,("\n")); /* * At this point we have finished the look-up-table program "lut_prog" with * all the relative source pixel coordinates and the look-up table "lut_tab" * with the fractional contributions of the source pixels to the target * pixels. The values in the look-up table have the highest bit set if at the * beginning of a new target pixel sequence. * * Beginning of a new sequence: * * look-up table program * * 1vvv vvvv vvvv vvvv 10001000 * 0vvv vvvv vvvv vvvv yyyyxxxx * 0vvv vvvv vvvv vvvv yyyyxxxx */ if(count_deleted) prmsg(WARNING, ("\n%d target pixels deleted, too many source pixels contribute\n", count_deleted)); #if BOUND_CHECK /* * Test whether the arrays are correctly set up for the number of target * pixels in the image: * * - the number of entries in the look-up table that have the BITMASK flag * set should be equal to the number of target pixels (BITMASK signals the * begin of a new target pixel sequence); * - the number of entries in the source coordinate array that still have * the initialization value should be equal to the number of target pixels * that do not receive any contribution from any of the source pixels; * - all entries in the look-up table that correspond to an index value in * the offset table should be at the beginning of a new sequence and thus * have the BITMASK flag set. */ { int count_case = 0, i, idx; prog_end = lut_prog + prog_length; lut_ptr = lut_tab; for(prog_ptr = lut_prog; prog_ptr != prog_end; prog_ptr++, lut_ptr++) { if(*lut_ptr & BITMASK) count_case++; } if(count_case != xysize) prmsg(ERROR,("lost some target pixels (now only %d)\n",count_case)); for(count_case = 0, i = 0; i < xysize; i++) if(abs_src[2*i] == 0xffff && abs_src[2*i+1] == 0xffff) count_case++; prmsg(DMSG,("Empty targets via abs_src count: %d\n",count_case)); for(offset_p = offsets, i = 0; i < xysize - 1; i++) { if(!(lut_tab[*offset_p++] & BITMASK)) { prmsg(ERROR,("target advance for %d lost\n",i)); for(idx = *(offset_p-1); idx < *offset_p; idx++) prmsg(DMSG,(" %d: 0x%4x 0x%2x\n",idx,lut_tab[idx],lut_prog[idx])); } } } #endif /* BOUND_CHECK */ /* * * Step 2: remove the empty target pixels at the beginning of the target * image, and mark the other empty target pixels with the flag * INCTARGET in the look-up table. The look-up table and the * look-up-table-program are shortened according to the number of * empty pixels removed. * */ prmsg(MSG,("Delete untouched pixels\n")); /* * Go through the look-up table and the look-up-table program to find empty * target pixels, i.e. target pixels that do not receive a contribution from * any source pixel. * * Delete all consecutive empty target pixels at the beginning of the image, * and mark all other empty target pixels as an exception of type INCTARGET. */ abs_ptr = abs_src; prog_end = lut_prog + prog_length; lut_ptr = lut_tab; start_ff = 1; start_tidx = 0; /* * Find all empty target pixels. These pixels still contain the * initialization value 0xff as look-up-table program instruction. * * Count how many consecutive empty target pixels are at the beginning of the * image array. * * Mark all other empty target pixels * - by setting the look-up-table program instruction to 0x0 (signifies * exception), * - and by setting the flags BITMASK and INCTARGET as value in the look-up- * table (signifies beginning of a new target sequence with an empty target * pixel). */ for(prog_ptr = lut_prog; prog_ptr != prog_end; prog_ptr++, lut_ptr++) { if(*prog_ptr == 0xff) { /* Nothing will be put in this target */ if(*lut_ptr & BITMASK) { if(start_ff) start_tidx++; else { *prog_ptr = 0x0; *lut_ptr = BITMASK | INCTARGET; count_inc++; } } } else start_ff = 0; } /* * Remove the consecutive empty target pixels from the beginning of the * look-up table and the look-up-table program. * * Then re-adjust the size of the look-up table and the look-up-table * program. */ new_prog_ptr = lut_prog; new_lut_ptr = lut_tab; lut_ptr = lut_tab; for(prog_ptr = lut_prog; prog_ptr != prog_end; prog_ptr++, lut_ptr++) { *new_prog_ptr = *prog_ptr; *new_lut_ptr = *lut_ptr; if(*prog_ptr != 0xff) { new_prog_ptr++; new_lut_ptr++; } } prog_length = new_prog_ptr - lut_prog; if(count_parts != prog_length) prmsg(DMSG,("%d deleted - start offset %d\n",count_parts - prog_length, start_tidx)); if((prog_ptr = lut_prog = (unsigned char *)prealloc(lut_prog,sizeof(char) * prog_length)) == NULL) prmsg(FATAL,("realloc failed\n")); if((lut_ptr = lut_tab = (LUT_TYPE *)prealloc(lut_tab,sizeof(LUT_TYPE) * prog_length)) == NULL) prmsg(FATAL,("realloc failed\n")); /* * At this point the empty target pixels have been marked in the look-up * table and the program in the following way: * * program look-up table * * 00000000 1000 0000 0000 0001 (= BITMASK | INCTARGET) * * This indicates a pure target advance, i.e. a target pixel that can be * skipped over. * * For non-empty target pixels, the contents of look-up table and program * have not changed. */ #if BOUND_CHECK { int count_case = 0,count_case1 = 0,count_case2 = 0; prog_end = lut_prog + prog_length; lut_ptr = lut_tab; /* * At the beginning of a sequence, there are now two possibilities: * - either the flag INCTARGET is set and the program instruction is 0, * this marks an empty target pixel; * - or the program instruction is 0x88 as it should be at the beginning of * a sequence with source pixels. * * Give a warning if this is not the case. */ for(prog_ptr = lut_prog; prog_ptr < prog_end; prog_ptr++, lut_ptr++) { if(*lut_ptr & BITMASK) { if((*lut_ptr != (BITMASK | INCTARGET) || *prog_ptr != 0) && (*prog_ptr != 0x88)) prmsg(ERROR,("cannot be *lut_ptr = 0x%x *prog_ptr = 0x%x\n", *lut_ptr,*prog_ptr)); if(*prog_ptr == 0) count_case1++; else count_case2++; } else count_case++; } /* * Verify the program length: * - count_case1 contains the number of empty target pixel instructions * (INCTARGET exceptions), i.e. all target pixels (except * those at the beginning) with no contributing source pixel; * - count_case2 contains all other instructions that mark the beginning * of a new sequence, i.e. all target pixels that have at * least one contributing source pixel; * - count_case contains the number of all instructions that are not at * the beginning of a new sequence. * * The empty target pixels at the beginning of the target image have already * been removed from the program and are thus not counted in "count_case1". * * The sum of the three should equal the program length. If not, give an * error message. * * Furthermore, the total number of target pixels should be * * count_case1 + count_case2 + (number of empty target pixels at beginning) */ prmsg(DMSG, ("INCTARGET pix = %d other new pix = %d contributing parts = %d\n", count_case1,count_case2,count_case)); if(count_case + count_case1 + count_case2 != prog_length) prmsg(ERROR,("lost some events somewhere\n")); } #endif /* BOUND_CHECK */ /* * * Step 3: optional: if the user-definable global variable "DO_FLAT" is set, * the target image is normalized to a flat image. The structure of * the tables (look-up table, etc.) is not changed. * * Going to normalize to flat target image. This means that when this code is * run a peak with 10000 pixels in the source image will not be 10000 pixels * in the target image any more. On the other hand a constant image will now * become another constant image. */ if(DO_FLAT) { LUT_TYPE *lp,*start_lut; unsigned long partsum, newpartsum; unsigned long part; LUT_TYPE bitmask; int count_case = 0, count_case1 = 0, count_case2 = 0; prmsg(DMSG,("Normalizing for flat output image\n")); prog_end = lut_prog + prog_length; lut_ptr = lut_tab; start_lut = lut_tab; /* * Loop through the look-up table, add for each target pixel all fractional * contributions from the source pixels, rescale them and store them back * in the look-up table. * * To do so, start with the first target pixel and skip forward through the * look-up-table program until the next target pixel is found. This defines * the start point "start_lut" and the end point "lut_ptr" of the summing * for the first target pixel. * * The following target pixels are processed in an analog manner. * * Note that the loop will go too far, as it has to go all the way to the * end of the program. "lut_ptr" does therefore not point to a valid * location of the look-up table on the last turn - careful. */ for(prog_ptr = lut_prog; prog_ptr <= prog_end; prog_ptr++, lut_ptr++) { if(prog_ptr == prog_end || (*lut_ptr & BITMASK)) { /* * Calculate the sum of the fractional contributions in the look-up * table for this target pixel. * * As this sums over all source pixels that contribute to a given * target pixel, this sum can of course be different from * 100 % (= FULLSCALE), in particular it can also be bigger than * 100 %. On the other hand, the sum of all parts that a given source * pixel contributes to all target pixels should always be equal to * FULLSCALE (= 100 %). * * Note that a value of 0 in the look-up table really means a value * of FULLSCALE. For a detailed explanation, see above at the end of * the loop processing the target pixels for a given source pixel. */ partsum = 0; max_pixelpart = 0; max_pixellut = NULL; for(lp = start_lut; lp < lut_ptr; lp++) { if(*lp & MAPSCALE) part = (*lp & MAPSCALE); else part = FULLSCALE; if(part > max_pixelpart) { max_pixelpart = part; max_pixellut = lp; } partsum += part; } #if BOUND_CHECK /* * Because of the way the loop through the look-up table is processed, * "start_lut" can only point at locations that correspond to the * beginning of a new sequence. * * Give an error message if this is not the case. */ if(start_lut != lut_tab && start_lut < lut_tab + prog_length && (*start_lut & BITMASK) == 0) prmsg(ERROR,("cannot be: *start_lut is 0x%x *prog = 0x%x in %d\n", *start_lut,*prog_ptr,prog_ptr - lut_prog)); #endif /* BOUND_CHECK */ /* * partsum should be approximately FULLSCALE on the average. * The value is normally not simply FULLSCALE as we are counting * here the sum of percentages of the source pixel contribution to * the target pixel (i.e. this could be 300 % if 3 source pixels * contribute each to 100 %). * * Rescale the fractional contributions to make partsum equal to * FULLSCALE. */ bitmask = BITMASK; newpartsum = 0; for(lp = start_lut; lp < lut_ptr; lp++) { part = *lp & MAPSCALE; if(part == 0) part = FULLSCALE; part = (part << SHIFT) / partsum; /* * A contribution of 0 is not supposed to happen for a contributing * pixel. Thus, if the rescaling leads to a contribution of 0 (trough * truncating in the integer calculation), set the contribution to 1. */ if(part == 0) { count_case++; part = 1; } /* * Store the rescaled values back into the look-up table. Set the * BITMASK flag for the first pixel of a sequence. Note that * "bitmask" is BITMASK for the starting pixel of a sequence and 0 * for all other pixels. * * As before, a value of FULLSCALE is hidden in an artificial 0. */ newpartsum += part; if(part >= FULLSCALE) *lp = 0 | bitmask; else *lp = part | bitmask; bitmask = 0; } /* * The sum of the rescaled contributions for this target pixel must be * equal to FULLSCALE. If this is not the case, then there have been * rounding errors. Attribute the difference (i.e., FULLSCALE - sum of * all parts) to that source pixel that gives the largest contribution * to this target pixel - that seems to be the best choice possible. */ if(max_pixellut && newpartsum != FULLSCALE) { int savelut; savelut = *max_pixellut & MAPSCALE; if(savelut == 0) savelut = FULLSCALE; part = savelut + FULLSCALE - newpartsum; if(part >= FULLSCALE) part = 0; if(*max_pixellut & BITMASK) *max_pixellut = part | BITMASK; else *max_pixellut = part; } #if BOUND_CHECK /* * Test to see if the "start_lut" location still has the BITMASK flag * set after the rescaling. * * Give an error message if this is not the case. */ if(start_lut != lut_tab && start_lut < lut_tab + prog_length && (*start_lut & BITMASK) == 0) prmsg(ERROR,("cannot be: *start_lut is 0x%x *prog = 0x%x in %d\n", *start_lut,*prog_ptr,prog_ptr - lut_prog)); #endif /* BOUND_CHECK */ /* * Set the start pointer "start_lut" for the next target pixel. Usually * it will just be the end pointer "lut_ptr" of the present pixel, but * if the next target pixel(s) is (are) empty (INCTARGET flag set), * then it (they) will just be skipped. */ if(prog_ptr != prog_end && *prog_ptr == 0) { #if BOUND_CHECK /* * A look-up-table instruction of 0 signals an exception. The only * type of exception defined so far is the INCTARGET exception, which * can only occur at the beginning of a new sequence. Give an error * message if this is not the case. */ if(*lut_ptr != (INCTARGET | BITMASK)) prmsg(ERROR,("cannot be: *lut_ptr is 0x%x\n",*lut_ptr)); count_case1++; #endif /* BOUND_CHECK */ start_lut = lut_ptr + 1; /* Ignore the empty target. */ } else { start_lut = lut_ptr; #if BOUND_CHECK count_case2++; #endif /* BOUND_CHECK */ } } } /* * Print statistics on the target pixels: * - count_case is the number of source pixels that got a 0 * contribution through the rescaling; * - count_case1 is the number of empty target pixels; * - count_case2 - 1 is the number of the non-empty target pixels * (-1 as the case prog_ptr == prog_end is counted also) */ prmsg(DMSG,("Counted %d part == 0 (LOOP count %d %d)\n", count_case,count_case1,count_case2 - 1)); } /* * Step 4: the absolute addressing scheme for the first contributing source * pixel is replaced by relative addressing whenever possible. Where * it is not possible, the flag ABSSRC is set in the corresponding * location in the look-up table. At the end of this step, the source * coordinate table has its final form. * * At present, the first program instruction for a new target pixel sequence * contains always 0x88. This location can be used to store the position of * the first source pixel in this target pixel sequence relative to the last * source pixel of the previous target pixel. * * The intention is to obtain the coordinates of the source pixels by * specifying the relative distance of the new source pixel with respect to * the source pixel treated last. This relative distance will then be stored * in the look-up-table program instruction for this source pixel. * * As the length of a program instruction is fixed (8 bit), there is a * maximum of 16 values that can be stored as difference for x and for y. * Moreover, the instruction values 0 and 0xff have a special meaning, thus * the difference can only have 15 values. These are chosen to be symmetric * around 0, i.e. the difference in x and in y must be between -7 and +7. * * If this maximum difference is exceeded, absolute source coordinates must * be used. A 0 will be stored in the look-up-table instruction to mark an * exception, and the type of the exception will be ABSSRC. * * starttidx contains the number of empty pixels at the beginning of the * target image, i.e. it is the index of the first non-empty pixel * in the target image array. * abs_src contains the x and y coordinates of the source image pixel that * corresponds to the target image pixel being processed. * The array is in principle a two-dimensional pixel array * organized for speed as an one-dimensional array with line-order * (i.e., the x coordinate increases fastest). For each pixel there * are two short integers, the first with the x and the second * with the y coordinate. * src_x and src_y are the x and y coordinates of the source image pixel * that corresponds to the first non-empty target pixel. * startsidx contains for this source image pixel the index into the source * image array. */ prmsg(DMSG,("Going to relative pixels\n")); lut_d->starttidx = start_tidx; src_x = abs_src[2 * start_tidx]; src_y = abs_src[2 * start_tidx + 1]; lut_d->startsidx = src_x + XSIZE * src_y; /* * The first valid (non-empty) target pixel must be treated separately, as * for it there is no "last source pixel of the previous target pixel". * Mark it in the look-up table as if it was not the beginning of a new * sequence. * This will leave the instruction 0x88 in the corresponding look-up-table * program. */ lut_tab[0] &= MAPSCALE; new_abssrc = abs_src; abs_ptr = abs_src + 2 * start_tidx + 2; count_trg = start_tidx + 1; lut_ptr = lut_tab; prog_end = lut_prog + prog_length; /* * Loop through the program and look for the beginnings of new target pixel * sequences. * * If one is found, then the look-up-table program instruction for the first * source pixel will be modified as described above. * * For the other source pixels in the program (subsequent pixels for an * already found target pixel), just calculate their source coordinates. Thus * (src_x, src_y) will contain the "coordinates of the last source pixel from * the previous target pixel". */ for(prog_ptr = lut_prog; prog_ptr != prog_end; prog_ptr++, lut_ptr++){ instruct = *prog_ptr; /* * Case 1: source pixel at the beginning of a new target pixel sequence. */ if((part = *lut_ptr) & BITMASK) { #if BOUND_CHECK /* * At the beginning of a new target pixel sequence, the look-up-table * program instruction must be either 0x88 for a normal sequence or 0 for * an exception. * * If this is not the case, give an error message. */ if(instruct != 0x88 && instruct != 0) { prmsg(ERROR,("corrupted tables prog = 0x%x lut = 0x%x in %d\n", instruct,part,prog_ptr - lut_prog)); continue; } #endif /* BOUND_CHECK */ new_x = *abs_ptr++; new_y = *abs_ptr++; #if BOUND_CHECK count_trg++; #endif /* BOUND_CHECK */ /* * Skip empty target pixels. */ if(instruct == 0) continue; #if BOUND_CHECK /* * For non-empty target pixels, the corresponding coordinates in the * source coordinate array must have a real value, not any longer the * initialization value. * * If they do, exit with error. */ if(new_x == 0xffff) prmsg(FATAL,("no absolute src coordinate for %d in %d\n", count_trg,prog_ptr - lut_prog)); #endif /* BOUND_CHECK */ diff_x = new_x - src_x; diff_y = new_y - src_y; /* * The first source pixel for this new target pixel might be wrapped * around the end of the line with respect to the last source pixel of * the previous target pixel, e.g. (new_x,new_y) = (XSIZE - 1, 3) and * (src_x, src_y) = (1, 2). * * Adding or subtracting XSIZE to the x-difference and modifying the * y-difference accordingly allows these cases to be treated as described * above (maximum difference +-7). This way the use of absolute * coordinates can be avoided here as well. */ if(diff_x >= 8) { diff_x -= XSIZE; diff_y++; } if(diff_x <= -8) { diff_x += XSIZE; diff_y--; } /* * Test if the difference between the new and the old source pixel * coordinates can be stored in the 8 bits of the look-up-table program * instruction, i.e. if it is between -7 and +7 for both x and y. * * If yes, store the difference in the look-up-table program instruction. * * If no, then absolute source coordinates must be used. Mark this event * as exception of type ABSSRC. Store the x and y source coordinates in * two subsequent locations in the source coordinate array. Store the * relative contribution of this source pixel to the target pixel also in * the source coordinate array, immediately behind the coordinates. */ if(diff_x >= 8 || diff_x <= -8 || diff_y >= 8 || diff_y <= -8) { *prog_ptr = 0x0; *lut_ptr = BITMASK | ABSSRC; *new_abssrc++ = new_x; *new_abssrc++ = new_y; /* * As the new set of data is written in the same array as the old * coordinates, make sure that this does not overwrite old coordinates * that have not been processed yet. * * This is not that likely to happen, as there should be room at the * beginning of the source coordinate array due to empty target pixels * at the beginning of the image. * * However, if it does happen, exit with error. */ if(new_abssrc >= abs_ptr) prmsg(FATAL,("about to overwrite source coordinate array\n")); *new_abssrc++ = part & MAPSCALE; count_abs++; } else { instruct = (diff_x + 8) + ((diff_y + 8) << 4); *prog_ptr = instruct; #if BOUND_CHECK /* * As the differences have been tested to be between -7 and +7, the * resulting instruction cannot be 0. * * If it is, exit with error. */ if(*prog_ptr == 0) prmsg(FATAL,("instruction is 0 - cannot be\n")); #endif /* BOUND_CHECK */ } src_x = new_x; src_y = new_y; #if BOUND_CHECK if(src_x >= XSIZE || src_x < 0 || src_y >= YSIZE || src_y < 0) prmsg(DMSG,("src pixel out of bounds in %d a.) %d %d (0x%x 0x%x)\n", prog_ptr - lut_prog,src_x,src_y,instruct,part)); #endif /* BOUND_CHECK */ } else { /* * Case 2: source pixel that is not at the beginning of a new target pixel * sequence. */ /* ??? can instruct == 0 happen here at all ??? */ if(instruct != 0) { src_x += (instruct & 0x0f) - 8; src_y += (((int) (instruct & 0xf0)) >> 4) - 8; #if BOUND_CHECK if(src_x >= XSIZE || src_x < 0 || src_y >= YSIZE || src_y < 0) prmsg(DMSG, ("source pixel out of bounds in %d b.) %d %d (0x%x 0x%x)\n", prog_ptr - lut_prog,src_x,src_y,instruct,part)); #endif /* BOUND_CHECK */ } } } #if BOUND_CHECK if(count_trg != xysize) prmsg(FATAL,("not all target pixels treated - cannot be %d\n",count_trg)); #endif /* BOUND_CHECK */ prmsg(DMSG,("Treated: %d empty target increments %d abs. source indices\n", count_inc,count_abs)); /* * Re-adjust the size of the source coordinate array. It is also possible * that this array is no longer needed, because no target pixel needs * absolute source coordinates. Then the source coordinate array is just * freed. */ if(new_abssrc == abs_src) { pfree(abs_src); abs_src = lut_d->abs_src = NULL; noabs = 0; } else { if((abs_src = lut_d->abs_src = (unsigned short *)prealloc(abs_src, (noabs = new_abssrc - abs_src) * sizeof(short))) == NULL) prmsg(FATAL,("realloc fails\n")); } pfree(offsets); #if WASTE4_FORSPEED /* * Save relative integer target position. This is used later for the overflow * correction. x_trg and y_trg contain the the target pixel coordinates. * We store here the differences in the short arrays lut_d->xrel and * lut_d->yrel. (i.e. if the pixel (100, 100) is distorted to position * (103.4, 101.6) then x_trg[100] is 103.4, y_trg[100] is 101.6, * spd_func(100,100,&x,&y) would return (103.4, 101.6) and lut_d->xrel * is 3, and lut_d->yrel is 2.) * * Note that x_trg, y_trg are floats and lut_d->xrel,yrel are shorts. The * reason for that is that we will only need approximate values for the * shift to blot out a square around overflow pixels. */ if((lut_d->xrel = (short*)pmalloc(xysize * sizeof(short))) == NULL || (lut_d->yrel = (short*)pmalloc(xysize * sizeof(short))) == NULL) prmsg(FATAL,("no memory for xrel and yrel\n")); for(idx = 0, j = 0; j < YSIZE; j++) for(i = 0; i < XSIZE; i++) { /* * Note that x_trg and y_trg have dimensions [XSIZE + 1,YSIZE + 1] */ lut_d->xrel[idx] = x_trg[i + j * xsize1] - i; lut_d->yrel[idx] = y_trg[i + j * xsize1] - j; idx++; } #endif /* WASTE4_FORSPEED */ #if !BOUND_SUPER pfree(x_trg); pfree(y_trg); #endif /* !BOUND_SUPER */ /* * Step 5: the relative addressing is replaced by the compressed addressing * scheme whenever possible. * * At the end of this step, all tables (look-up table, etc.) have * their final form. */ { unsigned char *start_ptr,*end_ptr,*c_ptr; int sx,sy,bito,compress,newmask; unsigned char *new_prog,*new_p; LUT_TYPE *start_lutptr; LUT_TYPE *newlut; int v; int oldidx; unsigned int *histo,*histo2; int count_hist,hist_max; unsigned int seq_value; int len,abs,old; int *rel_ptr,*rel_tab,**relend_tab; int *offset_tab; int seq_code; prmsg(DMSG,("Compressing program\n")); /* * At this point, the coordinates of a source pixel that contributes to a * given target pixel can be calculated in one of two ways: * * - relative: if the new source pixel is not too far away from the last * source pixel processed, then the look-up-table program * instruction for this new pixel contains the relative * distance in x and y between the new and the previous * source pixel; * - absolute: if the new source pixel is too far away, then the * corresponding look-up-table program instruction contains a 0 * to mark an exception. The exception type is ABSSRC, and the * coordinates of the new pixel are in the source coordinate * array. * * However, in many cases the image will not be strongly distorted. This * means that the positions of the source pixels that contribute to a given * target pixel will be near that pixel's position. Also, the correction * function that maps the source pixel coordinates to the target pixel * coordinates is not likely to vary a lot from one pixel to the next. * * Therefore, the group of source pixels that contribute to a given target * pixel is likely to have a similar shape as one moves from one target * pixel to the next; or, expressed in a different way, the sequence of * source pixel movements is likely to show a similar pattern. * * This can be used to shorten the look-up-table program. The idea is to * define a certain number of these possible movement patterns and then * look at all target pixels to find out whether the corresponding source * pixels are described by one of the defined patterns. If this is the * case, the sequence of look-up-table program instructions that describe * the movement from one source pixel to the next can be replaced by a * reference to the corresponding pattern. As the hope is to end up with a * smaller program, the process is called "compressing the program". * * The technical implementation of this idea is described in the following. * * Scan all source pixel sequences in the look-up-table program for short * sequences in the immediate neighborhood of the starting source pixel. * "Short" is here defined as reaching any combination of the pixels that * are in one of 18 locations mainly "below and to the right" of the * starting pixel. More precisely, if the starting pixel is marked by "x", * then all the pixels marked with a "." in the following diagram can be * reached: * * x . . . (the three pixels to the right) * . . . . . (line below: 1 left to 3 right) * . . . . . (two lines below: 1 left to 3 right) * . . . . . (three lines below: 1 left to 3 right) * * Note that the order in which the pixels are reached is not important. * Note also that this is not restricting the general case. The starting * pixel is simply defined to be in the upper left corner of the pattern. * Because of this definition it is sometimes possible that there is a * pixel in the pattern which is one unit more to the left in the next * line, but almost never two units. * * There are (2 power 18) possible pixel sequences that can be constructed * with 18 pixels. Each sequence can thus be described unambiguously by an * 18-bit sequence mask pattern in that way that the bit "i" is set if the * pixel "i" is part of the sequence. * * Determine for each of these sequences the frequency with which it occurs * in the look-up-table program. * * First allocate (2 power MAXHIST) integers of memory for the frequency * counters (MAXHIST = 1 << 18). */ if((histo = (unsigned int *)pmalloc(MAXHIST * sizeof(int))) == NULL) prmsg(FATAL,("no memory")); memset(histo,0,MAXHIST * sizeof(int)); /* * Loop through the program and search for the the next target pixel (= end * point of the present source pixel sequence and starting point of the * next sequence). This is marked by the flag BITMASK being set. * * Note that the first program instruction is already at a target pixel, * thus there is a "present pixel sequence" at the start of the loop. */ lut_ptr = lut_tab; prog_end = lut_prog + prog_length; start_ptr = lut_prog; for(prog_ptr = lut_prog; prog_ptr != prog_end;) { start_ptr = prog_ptr; start_lutptr = lut_ptr; lut_ptr++; prog_ptr++; while(prog_ptr < prog_end && !(*lut_ptr & BITMASK)) { lut_ptr++; prog_ptr++; } /* * End of sequence found. Now analyze the pixels involved in the * sequence: do they all belong to the 18 positions defined above? * * If yes, the sequence is one of the short sequences that is being * looked for: increase the frequency count of the corresponding counter. * * If no, stop the analysis of this sequence and look for the next one. */ end_ptr = prog_ptr - 1; compress = -1; if(start_ptr <= end_ptr) { sx = 0; sy = 0; compress = 0; for(c_ptr = start_ptr + 1; c_ptr <= end_ptr; c_ptr++) { instruct = *c_ptr; sx += (instruct & 0x0f) - 8; sy += (((int)(instruct & 0xf0)) >> 4) - 8; bito = (sy == 0) ? (sx - 1) : sy * 5 - 1 + sx; /* 0..17 */ if(sx < -1 || sx > 3 || sy < 0 || sy > 3 || bito < 0 || bito > 17 || (sy == 0 && sx < 1)) { /* * It is not one of the short sequences. We cannot compress this * series. */ compress = -1; break; } compress |= 1 << bito; } } /* * Ignore target pixels which have no corresponding source points (empty * source pixel sequence). */ if(*start_ptr == 0 && (*start_lutptr & INCTARGET)) continue; #if BOUND_CHECK if(compress >= MAXHIST) prmsg(FATAL,("compress out of bounds\n")); #endif /* BOUND_CHECK */ if(compress >= 0) histo[compress]++; } /* * histo holds now for every possible sequence pattern the number of * occurrences of this pattern. Determine the total number of patterns that * are actually used. */ count_hist = 0; for(i = 0; i < MAXHIST; i++) if(histo[i]) count_hist++; /* * Allocate array histo2 and fill it with two pieces of information for * each sequence pattern found: * 1) the bitfield of the pattern; * 2) the number of occurrences for non 0 patterns. * * Then sort the array in descending order of the number of occurrences and * keep only the first 256 patterns (i.e., those 256 patterns that occur * most frequently). */ if((histo2 = (unsigned int *)pmalloc(count_hist * 2 * sizeof(int))) == NULL) prmsg(FATAL,("no memory")); for(j=0, i = 0; i < MAXHIST; i++) if(histo[i]) { histo2[j++] = i; histo2[j++] = histo[i]; } qsort(histo2,count_hist,2 * sizeof(int),histcompare_count); /* * Throw away excess patterns (if there are more than 256), and readjust * the total count of the number of patterns. */ if(count_hist > 256) if((histo2 = (unsigned int *)prealloc(histo2,sizeof(int) * 2 * 256)) == NULL) { prmsg(FATAL,("realloc failed\n")); } hist_max = count_hist > 256 ? 256 : count_hist; /* * Reuse the array histo2: the number of occurrences is no longer needed * and is replaced by the order number of the field. Remember that the * order in histo2 is the result of it being sorted in number of * occurrences, i.e., the sequence pattern with the highest number of * occurrences has order number 0, the one with the next highest number of * occurrences has order number 1, etc. * * histo2 thus contains now for each sequence pattern: * 1) the bitfield of the pattern; * 2) the order number of the pattern. */ for(i=0; i x x . . . (the three pixels to the right) * | . . . . . (line below: 1 left to 3 right) * | . . . . . (two lines below: 1 left to 3 right) * V y . . . . . (three lines below: 1 left to 3 right) * * The element 0 of each sequence contains the position of the next pixel * relative to the present pixel. All subsequent elements of the sequence * then contain the position of the next pixel relative to the previous * one. * * relend_tab contains the actual length for each sequence stored in * rel_tab in the following way: * * for the sequence starting in rel_tab[i << RELTABSH] * * relend_tab[i] = pointer to the end location of that sequence in * rel_tab */ offset_tab = (int *)pmalloc(sizeof(int) * 256); rel_tab = (int *)pmalloc(sizeof(int *) * (hist_max << RELTABSH)); relend_tab = (int **)pmalloc(sizeof(int **) * hist_max); for(i=0; i<256; i++) offset_tab[i] = ((i & 0x0f) - 8) + (((i & 0xf0) >> 4) - 8) * XSIZE; for(i=0; i < hist_max; i++) { rel_ptr = rel_tab + (i << RELTABSH); old = 0; len = 0; seq_code = histo2[2*i]; for(j = 0; j< 18; j++) if(seq_code & (1<relend_tab = relend_tab; lut_d->rel_tab = rel_tab; lut_d->offset_tab = offset_tab; qsort(histo2,hist_max,2 * sizeof(int),histcompare_idx); prmsg(DMSG,("Sequence histogrammed\n")); /* * Later on we want to find for an arbitrary compress value if we should * compress this sequence and what is the code (from 0 to 254). To avoid to * loop through the histo2 array at every sequence (and therefore at every * pixel) we set histo up in a way to simply do * seq_value = histo[compress]; * * The "qsort" call sorts "histo2" in ascending bitfield order number. This * avoids having to use 1 MB of memory (1 << MAXHIST integers = 4 * 256 KB) * and makes the filling of the table "histo" faster. */ memset(histo,0,MAXHIST * sizeof(int)); for(i = 0; i< hist_max; i++) histo[histo2[2*i]] = histo2[2*i+1]+1; /* * The second element of each "histo2" field holds the bitfield order * number --> histo holds for every bitfield "order number + 1" or 0 if * not set. */ /* * Now use the above defined sequences of predefined movements to compress * the look-up-table program. * * Go through the program and see for every sequence of movements if it is * one of the predefined ones. If so, then replace the program instructions * for this sequence by a single one giving the corresponding index into * the rel_tab table ("compress the sequence"). * * A new look-up-table program is thus built that will replace the old one. * * First allocate memory for the new look-up-table program. */ if((new_prog = new_p = (unsigned char *)pmalloc(prog_length * sizeof(char))) == NULL) prmsg(FATAL,("no memory")); lut_ptr = lut_tab; prog_end = lut_prog + prog_length; new_plen = prog_length; prmsg(DMSG,("Current prog length 1: %d\n",prog_end - lut_prog)); for(i=0; i < MAXSTAT; i++) stat_case[i] = 0; for(prog_ptr = lut_prog; prog_ptr != prog_end;) { /* * Here we are at the start of a target pixel sequence. Find the end of * the sequence, i.e. the beginning of the next target pixel (or the end * of the look-up-table program). */ start_ptr = prog_ptr; start_lutptr = lut_ptr; lut_ptr++; prog_ptr++; stat_case[0]++; while(prog_ptr < prog_end && !(*lut_ptr & BITMASK)) { lut_ptr++; prog_ptr++; stat_case[1]++; } end_ptr = prog_ptr - 1; /* * start_ptr points to the start of the target pixel sequence, end_ptr to * the end. */ compress = -1; if(start_ptr <= end_ptr) { oldidx = 0; sx = 0; sy = 0; compress = 0; /* * Run with the pointer c_ptr through the target pixel sequence to * evaluate the relative moves. */ for(c_ptr = start_ptr + 1; c_ptr <= end_ptr; c_ptr++) { stat_case[2]++; instruct = *c_ptr; sx += (instruct & 0x0f) - 8; sy += (((int) (instruct & 0xf0)) >> 4) - 8; /* * Find out which bit (0..17) to set for this pixel in the sequence * mask. */ bito = (sy == 0) ? (sx - 1) : sy * 5 - 1 + sx; if(sx < -1 || sx > 3 || sy < 0 || sy > 3 || bito < 0 || bito > 17 || (sy == 0 && sx < 1)) { /* * We cannot compress this sequence, as it does not fit the allowed * patterns (see description above). */ compress = -1; stat_case[3]++; break; } #if BOUND_CHECK /* * Test if the new pixel to be added is already contained in the * sequence mask. If yes, give error message. */ newmask = 1 << bito; if(compress & newmask) prmsg(FATAL,("source pixel referenced twice - cannot be\n")); /* * Test if the new pixel has a smaller array index for the source * image than the previous one. If yes, give error message. */ if(oldidx >= sx + sy * XSIZE) prmsg(FATAL,("source not sorted - cannot be\n")); oldidx = sx + sy * XSIZE; #endif /* BOUND_CHECK */ /* * Build the sequence bitmask for all contributing source pixels. */ compress |= 1 << bito; } } /* * Test if the new program is about to overflow the allocated buffer. * If so, give warning and increase buffer size. */ if(new_p > new_prog + new_plen - 20) { prmsg(WARNING, ("allocated buffer for compressed program to small - increasing\n")); new_plen += prog_length; old = new_p - new_prog; if((new_prog = (unsigned char *)prealloc(new_prog, new_plen * sizeof(char))) == NULL) prmsg(FATAL,("no memory")); new_p = new_prog + old; } /* * If the look-up-table program instruction = 0 and the look-up-table * contains INCTARGET, then we have a target pixel without corresponding * source pixels. * * Set up an exception sequence in the look-up-table program: * - the first element of the sequence contains 0 to indicate an * exception; * - the second element contains the type of exception, here INCTARGET. * * Then jump to the end of the "compress" loop. */ if(*start_ptr == 0 && (*start_lutptr & INCTARGET)) { stat_case[4]++; /* * There should be only one element in the look-up-table program * -> no compress anyway. * * If there is more than one element, exit with error. */ #if BOUND_CHECK if(end_ptr != start_ptr) prmsg(FATAL,("table is corrupted somehow\n")); #endif /* BOUND_CHECK */ *new_p++ = 0; *new_p++ = INCTARGET; continue; } /* * This is a sequence that can possibly be compressed. Get the * corresponding index into the rel_tab table. If it is 0, then the * sequence corresponds to one of those that were not included in the 256 * possible entries of the rel_tab table - this should be a rare case. */ if(compress >= 0) { seq_value = histo[compress]; /* get the index for this sequence */ stat_case[5]++; if(seq_value == 0) { compress = -1; stat_case[6]++; } else { seq_value--; /* restore "true" index */ #if BOUND_CHECK if(seq_value >= hist_max || seq_value < 0) prmsg(FATAL,("seq value > 256 cannot be\n")); #endif /* BOUND_CHECK */ } } if(compress >= 0) { /* * Now it is certain that this sequence can be compressed. There are * two possible cases: * * - the first pixel of the sequence is "near" the source pixel that * was processed last (i.e., it is in one of the 256 positions * around the last one). * * Then the look-up-table program instruction is != 0 and contains * the index into the offset table lut_d->offset_tab where the * relative address of the first source image pixel can be found. * This is the "normal" case; * * - the first pixel of the sequence is not "near" the last source * pixel. Then the look-up-table program instruction is 0 to indicate * an exception, the following instruction will contain ABSSRC to * indicate the type of exception, and the address of the first * source image pixel is in the table lut_d->abs_src. * * In both cases, the then next program instruction will contain the * index that points to the corresponding predefined sequence in the * lut_d->rel_tab table. */ stat_case[7]++; *new_p++ = *start_ptr; if(*start_ptr == 0) { *new_p++ = ABSSRC; stat_case[8]++; } *new_p++ = seq_value & 0xff; } else { /* * This sequence cannot be compressed. There are the same two * possibilities for the address of the first pixel as in the * compressed case above: * * - it is near the last pixel processed. Then the present lookup-table * instruction is != 0 and contains the index into the offset table. * * This instruction will be replaced by a 0 to indicate an exception, * followed by UNCOMPRESSED to indicate the type of exception, and * then followed by the old "present" instruction (i.e., by the index * into the offset table); * * - it is not "near" the last pixel. Then the look-up-table program * instruction is 0 to indicate an exception, the following * instruction will contain both the flags ABSSRC and UNCOMPRESSED to * indicate the type of exception, and the address of the first source * image pixel is in the absolute address table lut_d->abs_src. * * In both cases, the then following program instructions contain the * indices into the offset table lut_d->offset_tab where the relative * address of the following source image pixels can be found. This * sequence of source image pixels is ended by a program instruction * containing 0. */ stat_case[9]++; if(*start_ptr == 0) { stat_case[10]++; *new_p++ = *start_ptr; *new_p++ = ABSSRC | UNCOMPRESSED; } else { stat_case[11]++; *new_p++ = 0; *new_p++ = UNCOMPRESSED; *new_p++ = *start_ptr; } for(c_ptr = start_ptr + 1; c_ptr <= end_ptr; c_ptr++) { stat_case[12]++; *new_p++ = *c_ptr; } *new_p++ = 0; /* End uncompressed data with 0 */ } } /* End of the compression loop. */ /* * Print statistical information on the compression: * 0: target pixels processed (instructions starting a new target pixel * sequence) * 1: other contributing source pixel parts processed (instructions not * starting a new target pixel sequence) * 2: total length of all source pixel sequences * 3: source sequences that cannot be compressed as they exceed the 18 * allowed positions * 4: target pixels with no corresponding source pixels * 5: source sequences that could be compressed as they are contained in * the 18 allowed positions * 6: source sequences that could be compressed, but are not among the * 256 most frequent sequences and are thus not compressed * 7: source sequences that will be compressed * 8: source sequences that will be compressed and where the first source * pixel is not near the last source pixel (exception ABSSCR) * 9: source sequences that will not be compressed * 10: source sequences that will not be compressed and where the first * source pixel is not near the last source pixel (exceptions ABSSCR * and UNCOMPRESSED) * 11: source sequences that will not be compressed and where the first * source pixel is near the last source pixel (exception UNCOMPRESSED) * 12: total length of all UNCOMPRESSED source pixel sequences * * Note: the following relations should hold: * * - stat_case[0] = stat_case[3] + stat_case[4] + stat_case[5]; * - stat_case[5] = stat_case[6] + stat_case[7]; * - stat_case[9] = stat_case[10] + stat_case[11]; * - stat_case[0] + start_tidx (from "Step 2") = output image size; * - stat_case[0] = count_case1 + count_case2 (both from "Step 2"); * - stat_case[1] = count_case (from "Step 2") * - stat_case[4] = count_case1 (from "Step 2"); * - stat_case[3] + stat_case[5] = count_case2 (from "Step 2"); * * - new program length: new_p - new_prog = * 2*stat_case[4] + 2*stat_case[7] + stat_case[8] + stat_case[9] + * 2*stat_case[10] + 3*stat_case[11] + stat_case[12]; */ prmsg(DMSG,("Compress inter.: %d targ pix %d oth src part %d len src seq\n", stat_case[0],stat_case[1],stat_case[2])); prmsg(DMSG,(" %d uncompr %d targ inc\n", stat_case[3],stat_case[4])); prmsg(DMSG,(" compressed: %d poss %d not freq %d real %d ABSSCR\n", stat_case[5],stat_case[6],stat_case[7],stat_case[8])); prmsg(DMSG,(" uncompressed: %d tot %d ABSSCR %d near %d total length\n", stat_case[9],stat_case[10],stat_case[11],stat_case[12])); /* * The look-up table entry corresponding to an "exception" instruction is * no longer needed and can be removed. * * Also, the BITMASK bit in the look-up table is no longer needed. The * value FULLSCALE had before been put as an artificial 0 in the table (to * avoid having a value creating the BITMASK meaning "start of a new * sequence"). * Now the value FULLSCALE can be stored correctly in the look-up table. */ prmsg(DMSG,("Current prog length 2: %d\n",prog_end - lut_prog)); lut_ptr = newlut = lut_tab; for(prog_ptr = lut_prog; prog_ptr != prog_end; lut_ptr++, prog_ptr++) { if(*prog_ptr == 0) continue; v = *lut_ptr & MAPSCALE; *newlut++ = v ? v : FULLSCALE; } prmsg(DMSG,("Current prog length 3: %d\n",new_p - new_prog)); count_inc = 0; for(i = 0; i < MAXSTAT; i++) stat_case[i] = 0; /* * Loop over the program. * * Write the modified version over the old uncompressed one, which is no * longer needed. Normally the compressed version is smaller than the * uncompressed, thus this works fine. If not, provide a bigger buffer here. * * Also, modify the processing of target pixels without corresponding source * pixel. Up to this point each such target pixel has its own INCTARGET * exception. If there are successive target pixels without source pixel, * these sequence of exceptions will now be replaced by one single * "multipixel" exception. * * Finally, add a PROGEND exception at the end of the program. */ if(prog_length < new_plen) { pfree(lut_prog); if((lut_prog = (unsigned char *)pmalloc(new_plen * sizeof(char))) == NULL) prmsg(FATAL,("no memory")); } for(prog_ptr = new_prog, new_inc = lut_prog; ;) { /* * Test for the end of a target advance sequence, and create the * corresponding exception if necessary. * * Target advance sequences are started by an "INCTARGET" exception, and * then the chain of uninterrupted following "INCTARGET" exceptions is * just counted. * * The end of such a sequence is reached when something else than a target * advance instruction is encountered, or when the counter for multiple * target instructions has reached its maximum (0xffff for an unsigned * short). */ if(prog_ptr >= new_p || *prog_ptr != 0 || !(*(prog_ptr + 1) & INCTARGET) || count_inc == 0xffff) { /* * End of target advance sequence. * * Terminate this target advance sequence properly before proceeding * further: * * - if it is a single pixel target advance, add a 0 instruction to * the program for an exception and then add an instruction with the * exception type INCTARGET; * * - if there is a target advance with several pixels, add a 0 * instruction to the program for an exception, add an instruction * with the exception type flags INCTARGET and MULTIINC set, and * then add the number of pixels concerned in the next two * instructions (LSB first). */ if(count_inc > 1) { stat_case[2]++; *new_inc++ = 0; *new_inc++ = INCTARGET | MULTIINC; *new_inc++ = count_inc % 256; *new_inc++ = count_inc / 256; count_inc = 0; } else if(count_inc == 1) { stat_case[3]++; *new_inc++ = 0; *new_inc++ = INCTARGET; count_inc = 0; } /* * Terminate loop if end of program reached. */ if(prog_ptr >= new_p) break; } /* * Now investigate the new instruction. * * Treat all exceptions (value of prog_ptr == 0) first. */ if(*prog_ptr == 0) { if(*(prog_ptr + 1) & INCTARGET) { /* * Found a target advance instruction. Count the number of successive * occurrences, and skip the next two instructions (0 for exception * and INCTARGET for exception type). */ stat_case[1]++; count_inc++; prog_ptr += 2; } else if(*(prog_ptr + 1) & UNCOMPRESSED) { /* * Not a predefined source pixel sequence. * * Copy the present instruction (0 for exception), and all following * instructions up to and including the 0 that terminates the * uncompressed sequence. */ stat_case[4]++; *new_inc++ = *prog_ptr++; while(*new_inc++ = *prog_ptr++) stat_case[5]++; } else if(*(prog_ptr + 1) & ABSSRC) { /* * Predefined source pixel sequence and first pixel is not near the * last one processed. * * Just copy the next three instructions (0 for exception, ABSSRC for * exception type and the index for the absolute address table. */ stat_case[6]++; *new_inc++ = *prog_ptr++; *new_inc++ = *prog_ptr++; *new_inc++ = *prog_ptr++; } } else { /* * Normal case (i.e. no exception): predefined source pixel sequence and * first pixel near the last one processed. * * Just copy the next two instructions (offset index for first pixel * and sequence index). */ stat_case[7]++; *new_inc++ = *prog_ptr++; *new_inc++ = *prog_ptr++; } } /* * End of the old program reached. * * Print statistical information on the final state of compression: * 1: target pixels with no corresponding source pixels (target advances) * 2: multipixel target advance sequences * 3: single pixel target advances * 4: source sequences that will not be compressed * 5: total length of uncompressed program sequences * 6: compressed source sequences where the first source pixel is not near * the last source pixel (exception ABSSCR) * 7: compressed source sequences where the first source pixel is near the * last source pixel * * The following relations should hold between the new stat_case values * (left side) and the ones calculated previously (right side): * * stat_case[1] = stat_case[4] * stat_case[4] = stat_case[9] * stat_case[5] = stat_case[10] + 2 * stat_case[11] + stat_case[12] * stat_case[6] = stat_case[8] * stat_case[7] = stat_case[7] - stat_case[8] */ prmsg(DMSG, ("Compress final: %d total inc %d multi inc %d single inc\n", stat_case[1],stat_case[2],stat_case[3])); prmsg(DMSG,(" %d uncompr %d total length uncompr\n", stat_case[4],stat_case[5])); prmsg(DMSG,(" %d compr ABSSCR %d compr near\n", stat_case[6],stat_case[7])); /* * End of the compression. * * Mark the end of the look-up-table program by an exception of type * PROGEND. * * Re-allocate the tables for the look-up-table program and the * look-up-table (they are smaller now), then free the auxiliary buffers. */ prog_length = new_inc - lut_prog + 2; prmsg(DMSG,("Current prog length 4: %d\n",prog_length)); lut_prog[prog_length-2] = 0; lut_prog[prog_length-1] = PROGEND; if((prog_ptr = lut_prog = (unsigned char *) prealloc(lut_prog,sizeof(char) * prog_length)) == NULL) { prmsg(FATAL,("realloc failed\n")); } lutsize = newlut - lut_tab; if((lut_ptr = lut_tab = (LUT_TYPE *) prealloc(lut_tab,sizeof(LUT_TYPE) * lutsize)) == NULL) { prmsg(FATAL,("realloc failed\n")); } pfree(new_prog); pfree(histo); pfree(histo2); } #if BOUND_CHECK /* * Make a dry run to check for source and target pixel boundaries as well as * inconsistencies in the look-up table or the look-up-table program. */ { register unsigned char compress,instruct; register int *r_ptr,*rel_tab,**relend_tab; register int cor_p,src_p; unsigned char *prog_ptr = lut_prog; unsigned char *lastprog = lut_prog + prog_length - 1; unsigned short *abs_ptr = abs_src; int *offset_tab; int count_abs1 = 0,count_abs2 = 0,count_unc = 0; unsigned long count_inc = 0,count_exc = 0,count_abs = 0; unsigned long multi,count_multi = 0,count_multi_t = 0; LUT_TYPE *lut_ptr = lut_tab; LUT_TYPE *lastlut = lut_tab + lutsize; lut_ptr = lut_tab; offset_tab = lut_d->offset_tab; rel_tab = lut_d->rel_tab; relend_tab = lut_d->relend_tab; src_p = lut_d->startsidx; cor_p = lut_d->starttidx; for(;;) { instruct = *prog_ptr++; if(instruct != 0) { /* * Begin of a normal target pixel, i.e. one with a compressed source * pixel sequence. * * Test if the first source pixel is outside the image boundaries, or if * there are attempts to exceed the range of the look-up table and the * look-up-table program. */ src_p += offset_tab[instruct]; lut_ptr++; if(src_p > xysize || src_p < 0) prmsg(FATAL,("table corrupted 1 src out of bounds\n")); if(lut_ptr > lastlut) prmsg(FATAL,("table corrupted 1 lut out of bounds\n")); if(prog_ptr > lastprog) prmsg(FATAL,("table corrupted 1 prog out of bounds\n")); #if BOUND_SUPER { /* * Test if the corrected target pixel coordinates agree with the ones * obtained from the target pixel index (within rounding errors). */ float x = x_trg[src_p % XSIZE + (src_p / XSIZE) * xsize1]; float y = y_trg[src_p % XSIZE + (src_p / XSIZE) * xsize1]; if(fabs(x - cor_p % XSIZE) > 1 || fabs(y - cor_p / XSIZE) > 1) prmsg(DMSG,("a.) %3d %3d %3d %3d %3d %3d %3f %3f\n", src_p % XSIZE,src_p / XSIZE,cor_p % XSIZE,cor_p / XSIZE, src_p % XSIZE - cor_p % XSIZE,src_p / XSIZE - cor_p / XSIZE,x,y)); } #endif /* BOUND_SUPER */ /* * Go through the subsequent source pixels of this sequence and do the * same tests as for the first source pixel. */ compress = *prog_ptr++; for(r_ptr = rel_tab + (compress << RELTABSH); r_ptr < relend_tab[compress]; r_ptr++) { src_p += *r_ptr; lut_ptr++; if(src_p > xysize || src_p < 0) prmsg(FATAL,("table corrupted 2 src out of bounds\n")); if(cor_p > xysize || cor_p < 0) prmsg(FATAL,("table corrupted 2 cor out of bounds\n")); if(lut_ptr > lastlut) prmsg(FATAL,("table corrupted 2 lut out of bounds\n")); if(prog_ptr > lastprog) prmsg(FATAL,("table corrupted 2 prog out of bounds\n")); } } else { /* * We have to treat an exception. */ count_exc++; if(prog_ptr > lastprog) prmsg(FATAL,("table corrupted 3 prog out of bounds\n")); instruct = *prog_ptr++; /* * Exception of type "empty target pixel" (one or several). * * Test if the target pixels are within the image boundaries. */ if(instruct & INCTARGET) { if(instruct & MULTIINC) { count_multi++; multi = *prog_ptr++; multi += *prog_ptr++ * 256; count_multi_t += multi; cor_p += multi; } else { count_inc++; cor_p++; } if(cor_p > xysize || cor_p < 0) prmsg(FATAL,("table corrupted 3 cor out of bounds\n")); continue; } /* * Exception of type "absolute source pixel address" (for compressed or * uncompressed pixel sequence). * * Test if the source pixels are within the image boundaries, or if * there are attempts to exceed the range of the look-up table. */ if(instruct & ABSSRC) { int x = *abs_ptr++; int y = *abs_ptr++; count_abs++; src_p = (x + y * XSIZE); abs_ptr++; if(src_p > xysize || src_p < 0) prmsg(FATAL,("table corrupted 3 src out of bounds\n")); if(instruct & UNCOMPRESSED) { count_abs1++; while(instruct = *prog_ptr++) { src_p += offset_tab[instruct]; lut_ptr++; if(src_p > xysize || src_p < 0) prmsg(FATAL,("table corrupted 4 src out of bounds\n")); if(lut_ptr > lastlut) prmsg(FATAL,("table corrupted 4 lut out of bounds\n")); } } else { count_abs2++; compress = *prog_ptr++; for(r_ptr = rel_tab + (compress << RELTABSH); r_ptr < relend_tab[compress]; r_ptr++) { src_p += *r_ptr; lut_ptr++; if(src_p > xysize || src_p < 0) prmsg(FATAL,("table corrupted 5 src out of bounds\n")); if(lut_ptr > lastlut) prmsg(FATAL,("table corrupted 5 lut out of bounds\n")); } } } else if(instruct & UNCOMPRESSED) { /* * Exception of type "uncompressed source pixel sequence" (with * relative pixel addressing). * * Test if the source pixels are within the image boundaries, or if * there are attempts to exceed the range of the look-up table. */ count_unc++; while(instruct = *prog_ptr++) { src_p += offset_tab[instruct]; lut_ptr++; if(src_p > xysize || src_p < 0) prmsg(FATAL,("table corrupted 6 src out of bounds\n")); if(lut_ptr > lastlut) prmsg(FATAL,("table corrupted 6 lut out of bounds\n")); } } else if(instruct & PROGEND) break; } cor_p++; /* * The target pixel index must not exceed the image boundaries. */ if(cor_p > xysize || cor_p < 0) prmsg(FATAL,("table corrupted 6 cor_p out of bounds\n")); } /* * At the end, the target pixel index should point to the last pixel in the * image. */ if(cor_p != xysize) prmsg(FATAL,("missed some target pixels, %d\n",cor_p)); /* * There must be three entries for each pixel that is in the source * coordinate array (but not all pixels need to be in this array!). */ if(count_abs != noabs/3) prmsg(FATAL,("missed some absolute coord, %d != %d\n",count_abs,noabs/3)); /* * Print statistics on the exceptions. */ prmsg(DMSG, ("Exceptions: %d (%d absolute source: %d uncompr., %d compr.),\n", count_exc,count_abs,count_abs1,count_abs2)); prmsg(DMSG, (" %d single inc, %d multi inc (with %d inc), %d uncompr.)\n", count_inc,count_multi,count_multi_t,count_unc)); } #endif /* BOUND_CHECK */ print_memsize(); lut_d->prog_length = prog_length; lut_d->prog = lut_prog; lut_d->lut = lut_tab; #if BOUND_SUPER pfree(x_trg); pfree(y_trg); #endif /* BOUND_SUPER */ return(lut_d); } /* lut_calc */ /*============================================================================== * Prints for debugging purposes various pieces of information from the look-up * table, the look-up table program and the source coordinate array. * * Printed are, for a selectable section of the look-up-table program, the * following items: * - the program instruction and the content of the look-up-table; * - the target pixel coordinates; * - the coordinates of the contributing source pixels and their area * contributions to the target pixel. * * The section to be printed is selected by the input variables "start" and * "end". * * This routine is at present not called from within the program, but can be * called from the debugger. * * Note that this routine expects an "intermediate state" of the look-up table * and associated program, i.e. the state when the exceptions and the beginning * of a new target pixel sequence are still marked in the look-up table and not * in the look-up-table program. * * Input : prog: the look-up-table program * lut: the look-up table * asrc: the source coordinate array * prog_length: the length of the look-up-table program * startsidx: the pixel index of the first source pixel * starttidx: the pixel index of the first target pixel * start: the sequence number (= array index) of the lookup-table * program instruction where the printing is to start * end: the corresponding number for the end of printing * Output: none * Return: 0 */ int debug_print(unsigned char *prog,LUT_TYPE *lut,unsigned short *asrc, int prog_length,int startsidx,int starttidx,int start,int end) { LUT_TYPE *lut_ptr = lut; unsigned char* prog_ptr = prog; int i; unsigned char instruct; int trg_x,trg_y; int src_x, src_y; int tidx,part; unsigned short *abs_ptr = asrc; tidx = starttidx; src_x = startsidx % XSIZE; src_y = startsidx / XSIZE; for(i = 0; i < prog_length; i++, prog_ptr++, lut_ptr++) { /* * Print look-up-table program instruction and look-up table content. */ if(i >= start && i <= end) prmsg(MSG,("0x%2x 0x%4x :",*prog_ptr,*lut_ptr)); if((part = *lut_ptr) & BITMASK) { tidx++; if(*prog_ptr == 0 && (*lut_ptr & ABSSRC)) { src_x = *abs_ptr++; src_y = *abs_ptr++; instruct = 0x88; part = *abs_ptr++; } trg_x = tidx % XSIZE; trg_y = tidx / XSIZE; /* * Print target pixel coordinates. */ if(i >= start && i <= end) prmsg(MSG,("%4d %4d :",trg_x,trg_y)); if(*prog_ptr == 0 && *lut_ptr & INCTARGET) { /* * Print source pixel coordinates for an empty target. * ??? they can not be very meaningful. Is this only to make sure that * they did not get messed up ??? */ part = 0; if(i >= start && i <= end) prmsg(MSG,("%4d %4d 0x%4x\n",src_x,src_y,part)); continue; } part &= MAPSCALE; } else if(i >= start && i <= end) prmsg(MSG,(" ")); instruct = *prog_ptr; src_x += (instruct & 0x0f) - 8; src_y += (((int) (instruct & 0xf0)) >> 4) - 8; /* * Print source pixel coordinates and contributing area fraction. */ if(i >= start && i <= end) { if(part == 0) part = FULLSCALE; prmsg(MSG,("%4d %4d 0x%4x\n",src_x,src_y,part)); } } return(0); } /* debug_print */ #if 0 /*============================================================================== * Tests the spline function parameters. * * The parameters are read in from the spline function parameter file, and the * spline function is evaluated at one arbitrary coordinate point. The * coordinates of this point and the calculated spline function values for x * and y are then printed. * * Note that this function is currently not called from within this package. * * Input : distfile: name of the file that contains the spline function * parameters * Output: none * Return: none */ gtest(char *distfile) { /* * Test for an arbitrary point (358,230). */ float xin=358, yin=230, xout, yout; spline = spd_loadspline(distfile); spd_calcspline(spline,1,1,&xin,&yin,&xout,&yout); printf("%f %f %f %f\n",xin,yin,xout,yout); } #endif /*============================================================================== * Prepare the floodfield (also called flatfield) image for the floodfield * correction. * * The floodfield correction takes into account the fact that a sample with * absolutely uniform scattering response does not necessarily produce a flat * image (e.g. because of a non-uniform detector response). If one takes an * image of a real sample, one has to correct for this non-uniformity. * * This is done by taking an image from an uniformly scattering probe (the * floodfield image) and then dividing the real image by the floodfield image. * * To make the actual correction calculation in divide_insito_im() and * divide_im() faster, the floodfield image calculated here is inverted. Thus * the correction routines can multiply with instead of divide by the floodfield * image. * * The input floodfield image can be either of type "unsigned short" or of * type "float". If it is of type "unsigned short", then it is handed over * in the argument "in_im". If the input floodfield image is of type "float", * then "in_im" must be a NULL pointer, and the input floodfield image is handed * over in "out_im". * * The output floodfield image is always of type "float" and returned in the * argument "out_im". * * Invalid pixels in the floodfield image (those with pixel value == 0. or pixel * value == dummy) will be stored in a list and dealt with later when the actual * division by the floodfield image is made. "dummy" is either the value of the * "Dummy" keyword in the floodfield header, if this is defined, or the value of * the "dummy" command line argument. If the latter is not defined by the user, * its default value is 0. * * Input : in_im: array with the input floodfield image (unsigned short) * out_im: array with the input floodfield image (float) * Output: out_im: array with the inverted floodfield image (float) * Return: 0 */ int prepare_flood(unsigned short *in_im,float *out_im) { float *float_flood; unsigned short *short_flood,dim_1,dim_2; long *pfldum; int dummycnt = 0,i; float dummy,ddummy; struct data_head flo_head = img_head[FLOTYP]; if(out_im == NULL) return(0); /* * Define the "dummy" and "ddummy" values. */ dummy = flo_head.init & FL_DUMMY ? flo_head.Dummy : 0.; ddummy = flo_head.init & FL_DDUMM ? flo_head.DDummy : DDSET(dummy); dim_1 = flo_head.init & FL_DIM1 ? flo_head.Dim_1 : XSIZE; dim_2 = flo_head.init & FL_DIM2 ? flo_head.Dim_2 : YSIZE; /* * If the image is of type "unsigned short", copy it from the "in_im" buffer * to the (float-type) "out_im" buffer. */ if(in_im != NULL) { short_flood = in_im + dim_1 * dim_2 - 1; float_flood = out_im + dim_1 * dim_2 - 1; for(; float_flood >= out_im; short_flood--, float_flood--) *float_flood = (float)*short_flood; } /* * Invert the image on a pixel-to-pixel basis. * * Count the pixels with invalid values (0. or "dummy"). Values of 0. are * replaced by "dummy". */ float_flood = out_im + dim_1 * dim_2 - 1; for(; float_flood >= out_im; float_flood--) if(*float_flood == 0. || DUMMY(*float_flood,dummy,ddummy)) { *float_flood = dummy; dummycnt++; } else *float_flood = 1. / *float_flood; if(fldumlst != NULL) { pfree(fldumlst); fldumlst = NULL; } if(dummycnt == 0) return(0); /* * Make the list with the pixel indices of the invalid pixels. */ fldumlst = (long *)pmalloc((dummycnt + 1) * sizeof(long)); pfldum = fldumlst; for(i = 0; i < dim_1 * dim_2; i++) if(*(out_im + i) == dummy) *pfldum++ = i; *pfldum = -1; return(0); } /* prepare_flood */ /*============================================================================== * Prints for debugging purposes various pieces of information from the look-up * table and the look-up table program. * * Printed are the following items: * - if the look-up-table program instruction is 0, but it is not at the * begining of a new target pixel: the contents of the look-up-table program * and of the look-up table as well as the present address in the look-up- * table program; * - if the look-up table contains 0xff: the content of the look-up-table * program. * * The routine also counts * - the number of INCTARGET exceptions; * - the number of ABSSRC exceptions; * - the total number of exceptions (i.e., when program instruction == 0); * - the number of occurrences of 0xff in the look-up table. * ??? what does this mean ??? * * This routine is at present not called from within the program, but can be * called from the debugger. * * Note that this routine expects an "intermediate state" of the look-up table * and associated program, i.e. the state when the exceptions and the beginning * of a new target pixel sequence are still marked in the look-up table and not * in the look-up-table program. * * Input : prog: the start address in the look-up-table program * lut: the start address in the look-up table * prog_length: the length of the look-up-table program * Output: none * Return: 0 */ int despair(unsigned char *lut_prog,LUT_TYPE *lut_tab,int prog_length) { unsigned char *prog_end; unsigned char *prog_ptr; unsigned long count_abs = 0,count_ff = 0,count_null = 0,count_inc = 0; LUT_TYPE *lut_ptr; prog_end = lut_prog + prog_length; lut_ptr = lut_tab; for(prog_ptr = lut_prog; prog_ptr != prog_end; prog_ptr++, lut_ptr++) { if(*prog_ptr == 0 && !(*lut_ptr & BITMASK)) prmsg(MSG,("%d %d %d \n",*prog_ptr,*lut_ptr,prog_ptr-lut_prog)); if(*prog_ptr == 0 && (*lut_ptr & INCTARGET)) count_inc++; if(*prog_ptr == 0 && (*lut_ptr & ABSSRC)) count_abs++; /* ??? what does 0xff in the look-up table mean ??? */ if(*lut_ptr == 0xff) { prmsg(MSG,("<0x%x>",*prog_ptr)); count_ff++; } if(*prog_ptr == 0) count_null++; } prmsg(MSG,("\nInc Abs Null LUT==FF %d %d %d %d\n",count_inc,count_abs, count_null,count_ff)); return(0); } /* despair */ spd-1.3.0/src/Makefile.in0000644000175000017500000003443311650556154012075 00000000000000# Makefile.in generated by automake 1.11.1 from Makefile.am. # @configure_input@ # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, # 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, # Inc. # This Makefile.in is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY, to the extent permitted by law; without # even the implied warranty of MERCHANTABILITY or FITNESS FOR A # PARTICULAR PURPOSE. @SET_MAKE@ VPATH = @srcdir@ pkgdatadir = $(datadir)/@PACKAGE@ pkgincludedir = $(includedir)/@PACKAGE@ pkglibdir = $(libdir)/@PACKAGE@ pkglibexecdir = $(libexecdir)/@PACKAGE@ am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd install_sh_DATA = $(install_sh) -c -m 644 install_sh_PROGRAM = $(install_sh) -c install_sh_SCRIPT = $(install_sh) -c INSTALL_HEADER = $(INSTALL_DATA) transform = $(program_transform_name) NORMAL_INSTALL = : PRE_INSTALL = : POST_INSTALL = : NORMAL_UNINSTALL = : PRE_UNINSTALL = : POST_UNINSTALL = : bin_PROGRAMS = spd$(EXEEXT) subdir = src DIST_COMMON = $(srcdir)/Makefile.am $(srcdir)/Makefile.in ACLOCAL_M4 = $(top_srcdir)/aclocal.m4 am__aclocal_m4_deps = $(top_srcdir)/configure.ac am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \ $(ACLOCAL_M4) mkinstalldirs = $(install_sh) -d CONFIG_HEADER = $(top_builddir)/config.h CONFIG_CLEAN_FILES = CONFIG_CLEAN_VPATH_FILES = am__installdirs = "$(DESTDIR)$(bindir)" PROGRAMS = $(bin_PROGRAMS) am_spd_OBJECTS = correct.$(OBJEXT) inout.$(OBJEXT) util.$(OBJEXT) \ version.$(OBJEXT) spd_OBJECTS = $(am_spd_OBJECTS) am__DEPENDENCIES_1 = spd_DEPENDENCIES = $(am__DEPENDENCIES_1) ../edfpack/libedfpack.a \ ../fitpack/libfitpack.a DEFAULT_INCLUDES = -I.@am__isrc@ -I$(top_builddir) depcomp = $(SHELL) $(top_srcdir)/depcomp am__depfiles_maybe = depfiles am__mv = mv -f COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) CCLD = $(CC) LINK = $(CCLD) $(AM_CFLAGS) $(CFLAGS) $(AM_LDFLAGS) $(LDFLAGS) -o $@ SOURCES = $(spd_SOURCES) DIST_SOURCES = $(spd_SOURCES) ETAGS = etags CTAGS = ctags DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST) ACLOCAL = @ACLOCAL@ AMTAR = @AMTAR@ AUTOCONF = @AUTOCONF@ AUTOHEADER = @AUTOHEADER@ AUTOMAKE = @AUTOMAKE@ AWK = @AWK@ CC = @CC@ CCDEPMODE = @CCDEPMODE@ CFLAGS = @CFLAGS@ CPP = @CPP@ CPPFLAGS = @CPPFLAGS@ CYGPATH_W = @CYGPATH_W@ DEFS = @DEFS@ DEPDIR = @DEPDIR@ ECHO_C = @ECHO_C@ ECHO_N = @ECHO_N@ ECHO_T = @ECHO_T@ EGREP = @EGREP@ EXEEXT = @EXEEXT@ F77 = @F77@ FFLAGS = @FFLAGS@ FLIBS = @FLIBS@ GREP = @GREP@ INSTALL = @INSTALL@ INSTALL_DATA = @INSTALL_DATA@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ INSTALL_SCRIPT = @INSTALL_SCRIPT@ INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@ LDFLAGS = @LDFLAGS@ LIBOBJS = @LIBOBJS@ LIBS = @LIBS@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MKDIR_P = @MKDIR_P@ OBJEXT = @OBJEXT@ PACKAGE = @PACKAGE@ PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@ PACKAGE_NAME = @PACKAGE_NAME@ PACKAGE_STRING = @PACKAGE_STRING@ PACKAGE_TARNAME = @PACKAGE_TARNAME@ PACKAGE_URL = @PACKAGE_URL@ PACKAGE_VERSION = @PACKAGE_VERSION@ PATH_SEPARATOR = @PATH_SEPARATOR@ POW_LIB = @POW_LIB@ RANLIB = @RANLIB@ SET_MAKE = @SET_MAKE@ SHELL = @SHELL@ STRIP = @STRIP@ VERSION = @VERSION@ abs_builddir = @abs_builddir@ abs_srcdir = @abs_srcdir@ abs_top_builddir = @abs_top_builddir@ abs_top_srcdir = @abs_top_srcdir@ ac_ct_CC = @ac_ct_CC@ ac_ct_F77 = @ac_ct_F77@ am__include = @am__include@ am__leading_dot = @am__leading_dot@ am__quote = @am__quote@ am__tar = @am__tar@ am__untar = @am__untar@ bindir = @bindir@ build_alias = @build_alias@ builddir = @builddir@ datadir = @datadir@ datarootdir = @datarootdir@ docdir = @docdir@ dvidir = @dvidir@ exec_prefix = @exec_prefix@ host_alias = @host_alias@ htmldir = @htmldir@ includedir = @includedir@ infodir = @infodir@ install_sh = @install_sh@ libdir = @libdir@ libexecdir = @libexecdir@ localedir = @localedir@ localstatedir = @localstatedir@ mandir = @mandir@ mkdir_p = @mkdir_p@ oldincludedir = @oldincludedir@ pdfdir = @pdfdir@ prefix = @prefix@ program_transform_name = @program_transform_name@ psdir = @psdir@ sbindir = @sbindir@ sharedstatedir = @sharedstatedir@ srcdir = @srcdir@ sysconfdir = @sysconfdir@ target_alias = @target_alias@ top_build_prefix = @top_build_prefix@ top_builddir = @top_builddir@ top_srcdir = @top_srcdir@ AM_CPPFLAGS = -Wall -static -Wno-parentheses \ -I$(top_srcdir)/edfpack -I$(top_srcdir)/fitpack \ -DANDY_CORR -DVERSION=\""SPD=1.3 SAXS=2.445 EDF=2.188"\" -DUNDERSCORE spd_LDADD = -lz -lm $(FLIBS) \ ../edfpack/libedfpack.a \ ../fitpack/libfitpack.a spd_SOURCES = correct.c inout.c util.c version.c spd.h spec_shm.h all: all-am .SUFFIXES: .SUFFIXES: .c .o .obj $(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps) @for dep in $?; do \ case '$(am__configure_deps)' in \ *$$dep*) \ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \ && { if test -f $@; then exit 0; else break; fi; }; \ exit 1;; \ esac; \ done; \ echo ' cd $(top_srcdir) && $(AUTOMAKE) --gnu src/Makefile'; \ $(am__cd) $(top_srcdir) && \ $(AUTOMAKE) --gnu src/Makefile .PRECIOUS: Makefile Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status @case '$?' in \ *config.status*) \ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \ *) \ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \ esac; $(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(top_srcdir)/configure: $(am__configure_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(ACLOCAL_M4): $(am__aclocal_m4_deps) cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh $(am__aclocal_m4_deps): install-binPROGRAMS: $(bin_PROGRAMS) @$(NORMAL_INSTALL) test -z "$(bindir)" || $(MKDIR_P) "$(DESTDIR)$(bindir)" @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \ for p in $$list; do echo "$$p $$p"; done | \ sed 's/$(EXEEXT)$$//' | \ while read p p1; do if test -f $$p; \ then echo "$$p"; echo "$$p"; else :; fi; \ done | \ sed -e 'p;s,.*/,,;n;h' -e 's|.*|.|' \ -e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \ sed 'N;N;N;s,\n, ,g' | \ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \ if ($$2 == $$4) files[d] = files[d] " " $$1; \ else { print "f", $$3 "/" $$4, $$1; } } \ END { for (d in files) print "f", d, files[d] }' | \ while read type dir files; do \ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \ test -z "$$files" || { \ echo " $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files '$(DESTDIR)$(bindir)$$dir'"; \ $(INSTALL_PROGRAM_ENV) $(INSTALL_PROGRAM) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \ } \ ; done uninstall-binPROGRAMS: @$(NORMAL_UNINSTALL) @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \ files=`for p in $$list; do echo "$$p"; done | \ sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \ -e 's/$$/$(EXEEXT)/' `; \ test -n "$$list" || exit 0; \ echo " ( cd '$(DESTDIR)$(bindir)' && rm -f" $$files ")"; \ cd "$(DESTDIR)$(bindir)" && rm -f $$files clean-binPROGRAMS: -test -z "$(bin_PROGRAMS)" || rm -f $(bin_PROGRAMS) spd$(EXEEXT): $(spd_OBJECTS) $(spd_DEPENDENCIES) @rm -f spd$(EXEEXT) $(LINK) $(spd_OBJECTS) $(spd_LDADD) $(LIBS) mostlyclean-compile: -rm -f *.$(OBJEXT) distclean-compile: -rm -f *.tab.c @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/correct.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/inout.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/util.Po@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/version.Po@am__quote@ .c.o: @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $< @am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(COMPILE) -c $< .c.obj: @am__fastdepCC_TRUE@ $(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'` @am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po @AMDEP_TRUE@@am__fastdepCC_FALSE@ source='$<' object='$@' libtool=no @AMDEPBACKSLASH@ @AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@ @am__fastdepCC_FALSE@ $(COMPILE) -c `$(CYGPATH_W) '$<'` ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES) list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ mkid -fID $$unique tags: TAGS TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) set x; \ here=`pwd`; \ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ shift; \ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \ test -n "$$unique" || unique=$$empty_fix; \ if test $$# -gt 0; then \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ "$$@" $$unique; \ else \ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \ $$unique; \ fi; \ fi ctags: CTAGS CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \ $(TAGS_FILES) $(LISP) list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \ unique=`for i in $$list; do \ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \ done | \ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \ END { if (nonempty) { for (i in files) print i; }; }'`; \ test -z "$(CTAGS_ARGS)$$unique" \ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \ $$unique GTAGS: here=`$(am__cd) $(top_builddir) && pwd` \ && $(am__cd) $(top_srcdir) \ && gtags -i $(GTAGS_ARGS) "$$here" distclean-tags: -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags distdir: $(DISTFILES) @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \ list='$(DISTFILES)'; \ dist_files=`for file in $$list; do echo $$file; done | \ sed -e "s|^$$srcdirstrip/||;t" \ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \ case $$dist_files in \ */*) $(MKDIR_P) `echo "$$dist_files" | \ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \ sort -u` ;; \ esac; \ for file in $$dist_files; do \ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \ if test -d $$d/$$file; then \ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \ if test -d "$(distdir)/$$file"; then \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \ fi; \ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \ else \ test -f "$(distdir)/$$file" \ || cp -p $$d/$$file "$(distdir)/$$file" \ || exit 1; \ fi; \ done check-am: all-am check: check-am all-am: Makefile $(PROGRAMS) installdirs: for dir in "$(DESTDIR)$(bindir)"; do \ test -z "$$dir" || $(MKDIR_P) "$$dir"; \ done install: install-am install-exec: install-exec-am install-data: install-data-am uninstall: uninstall-am install-am: all-am @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am installcheck: installcheck-am install-strip: $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \ `test -z '$(STRIP)' || \ echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install mostlyclean-generic: clean-generic: distclean-generic: -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES) -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES) maintainer-clean-generic: @echo "This command is intended for maintainers to use" @echo "it deletes files that may require special tools to rebuild." clean: clean-am clean-am: clean-binPROGRAMS clean-generic mostlyclean-am distclean: distclean-am -rm -rf ./$(DEPDIR) -rm -f Makefile distclean-am: clean-am distclean-compile distclean-generic \ distclean-tags dvi: dvi-am dvi-am: html: html-am html-am: info: info-am info-am: install-data-am: install-dvi: install-dvi-am install-dvi-am: install-exec-am: install-binPROGRAMS install-html: install-html-am install-html-am: install-info: install-info-am install-info-am: install-man: install-pdf: install-pdf-am install-pdf-am: install-ps: install-ps-am install-ps-am: installcheck-am: maintainer-clean: maintainer-clean-am -rm -rf ./$(DEPDIR) -rm -f Makefile maintainer-clean-am: distclean-am maintainer-clean-generic mostlyclean: mostlyclean-am mostlyclean-am: mostlyclean-compile mostlyclean-generic pdf: pdf-am pdf-am: ps: ps-am ps-am: uninstall-am: uninstall-binPROGRAMS .MAKE: install-am install-strip .PHONY: CTAGS GTAGS all all-am check check-am clean clean-binPROGRAMS \ clean-generic ctags distclean distclean-compile \ distclean-generic distclean-tags distdir dvi dvi-am html \ html-am info info-am install install-am install-binPROGRAMS \ install-data install-data-am install-dvi install-dvi-am \ install-exec install-exec-am install-html install-html-am \ install-info install-info-am install-man install-pdf \ install-pdf-am install-ps install-ps-am install-strip \ installcheck installcheck-am installdirs maintainer-clean \ maintainer-clean-generic mostlyclean mostlyclean-compile \ mostlyclean-generic pdf pdf-am ps ps-am tags uninstall \ uninstall-am uninstall-binPROGRAMS # Tell versions [3.59,3.63) of GNU make to not export all variables. # Otherwise a system limit (for SysV at least) may be exceeded. .NOEXPORT: spd-1.3.0/src/version.c0000644000175000017500000000404311633462461011651 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2009-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /* Update 24/08/2009 R. Wilcke (wilcke@esrf.fr) first working version. Update 30/09/2009 R. Wilcke (wilcke@esrf.fr) prntvers(): add input argument "progname" and print it in the version information; prntvers(): add date and time of compilation to the version information. */ #include "spd.h" char versistr[] = VERSION; /*============================================================================== * This routine prints the version string of the program. * * The version string is handed over to the program in the C-preprocessor macro * "VERSION", which is defined as part of the compilation process. * * The routine is automatically recompiled when the version string changes. * * For details, see the corresponding Makefile. * * Input : none * Output: none * Return: none */ void prntvers(char *progname) { prmsg(MSG,("%s version %s\n",progname,versistr)); prmsg(MSG,("compiled %s, %s\n",__DATE__,__TIME__)); return; } spd-1.3.0/src/spec_shm.h0000644000175000017500000001016711633462461011776 00000000000000/**************************************************************************** * @(#)spec_shm.h 5.6 02/24/10 CSS * * "Spec" Release 5 * * Copyright (c) 1995-2010 Certified Scientific Software * * The software contained in this file "spec_shm.h" describes the * shared-data structures used and defined by the CSS "spec" package. * * Permission is hereby granted, free of charge, to any person obtaining a * copy of the software in this file (the "Software"), to deal in the * Software without restriction, including without limitation the rights to * use, copy, modify, merge, publish, distribute, sublicense, and/or sell * copies of the Software, and to permit persons to whom the Software is * furnished to do so, subject to the following conditions: * * The above copyright notice and this permission notice shall be included * in all copies or substantial portions of the Software. * * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY * CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE * SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. * ****************************************************************************/ #define SHM_MAGIC 0xCEBEC000 /* * Difference between SHM_VERSION 3 and 4 is the increase in * header size from 1024 to 4096 to put the data portion * on a memory page boundary. * * Difference between SHM_VERSION 4 and 5 is the addition of * the SHM_IS_FRAMES tag and the frame_size and latest_frames * elements of the shm_head structure. */ #define SHM_VERSION 5 /* structure flags */ #define SHM_IS_STATUS 0x0001 #define SHM_IS_ARRAY 0x0002 #define SHM_IS_MASK 0x000F /* User can't change these bits */ #define SHM_IS_MCA 0x0010 #define SHM_IS_IMAGE 0x0020 #define SHM_IS_SCAN 0x0040 #define SHM_IS_INFO 0x0080 #define SHM_IS_FRAMES 0x0100 /* array data types */ #define SHM_DOUBLE 0 #define SHM_FLOAT 1 #define SHM_LONG 2 #define SHM_ULONG 3 #define SHM_SHORT 4 #define SHM_USHORT 5 #define SHM_CHAR 6 #define SHM_UCHAR 7 #define SHM_STRING 8 #define NAME_LENGTH 32 #define SHM_OHEAD_SIZE 1024 /* Old header size */ #define SHM_HEAD_SIZE 4096 /* Header size puts data on page boundary */ #ifndef SPEC_TYPE_DEFS typedef int s32_t; typedef unsigned int u32_t; #endif struct shm_head { u32_t magic; /* magic number (SHM_MAGIC) */ u32_t type; /* one of the array data types */ u32_t version; /* version number of this struct */ u32_t rows; /* number of rows of array data */ u32_t cols; /* number of cols of array data */ u32_t utime; /* last-updated counter */ char name[NAME_LENGTH]; /* name of spec variable */ char spec_version[NAME_LENGTH]; /* name of spec process */ s32_t shmid; /* shared mem ID */ u32_t flags; /* more type info */ u32_t pid; /* process id of spec process */ /* * A frame can be a single MCA acquisition or a single image. * A 2D array can be considered a succession of MCA frames or * a succession of images. Since data is stored row-wise, * frames are defined by a number of rows. */ u32_t frame_size; /* number of rows per frame */ u32_t latest_frame; /* most recently updated frame */ }; #define SHM_MAX_IDS 128 struct shm_status { u32_t spec_state; u32_t utime; /* updated when ids[] changes */ s32_t ids[SHM_MAX_IDS]; /* shm ids for shared arrays */ /* more later */ }; struct shm_oheader { union { struct shm_head head; char pad[SHM_OHEAD_SIZE]; } head; void *data; }; struct shm_header { union { struct shm_head head; char pad[SHM_HEAD_SIZE]; } head; void *data; }; spd-1.3.0/src/Makefile.am0000644000175000017500000000052411644024471012051 00000000000000AM_CPPFLAGS = -Wall -static -Wno-parentheses \ -I$(top_srcdir)/edfpack -I$(top_srcdir)/fitpack \ -DANDY_CORR -DVERSION=\""SPD=1.3 SAXS=2.445 EDF=2.188"\" -DUNDERSCORE bin_PROGRAMS = spd spd_LDADD = -lz -lm $(FLIBS) \ ../edfpack/libedfpack.a \ ../fitpack/libfitpack.a spd_SOURCES= correct.c inout.c util.c version.c spd.h spec_shm.h spd-1.3.0/src/inout.c0000644000175000017500000073217511655560076011345 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2001-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * J. Kieffer (kieffer@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /* Update 24/10/2011 P. Boesecke (boesecke@esrf.fr) Default value of do_dark changed to 0. If not set explicitely on the command line do_dark will be set to 1 by giving either dark_file, dark_const or dark_id different from -1. Flag NO_SHARED_MEMORY added to allow compilation on Windows. strtok_r -> strlib_tok_r, cor_ext default changed to ".cor.edf" (originally ".cor"), because ".cor" cannot be opened by fit2d, azim_ext default changed to ".azim.edf" (originally "") Update 18/10/2011 P. Boesecke (boesecke@esrf.fr) INVALID_TYP added, TMPTYP added. Update 14/10/2011 P. Boesecke (boesecke@esrf.fr) is_not_prerotpar added, put_buffer: special condition to pass prerotation parameters Update 29/09/2011 P. Boesecke (boesecke@esrf.fr) SDMTYP and moutfile added Update 23/09/2011 P. Boesecke (boesecke@esrf.fr) do_dist = 4 added Update 12/09/2011 P. Boesecke (boesecke@esrf.fr) get_buffer: offset-0.5 corrected for SDXTYP, SDYTYP Update 10/09/2011 P. Boesecke (boesecke@esrf.fr) sx parameters are only calculated in correct.c when all header values are updated. Update 09/09/2011 P. Boesecke (boesecke@esrf.fr) get_buffer: if now buffer is specified for AZITYP, defaults are used (but currently only rough estimations). The data type of the overflow parameter has been changed from unsigned short to unsigned long. Otherwise, it could not be used with detectors having more than two byte integers per pixel (e.g. pixel detectors). Because the overflow value is now detector dependent its default value has been changed from 0xffff to 0. Otherwise it would have been necessary to set it explicitely to 0. Update 05/09/2011 P. Boesecke (boesecke@esrf.fr) put_buffer: valset variable added analyse_args: do_dist is only set to 0 if do_prerot is 0 get_buffer: default parameters for SDXTYP and SDYTYP from SRCTYP Update 02/09/2011 P. Boesecke (boesecke@esrf.fr) Currently defined values of the raw data compression option raw_cmpr (DCompression values of cmpr.h): "none" | "UnCompressed" : no compression (default) "gzip" | "GzipCompression : gzip compression "z" | "ZCompression : Z compression All unknown values set raw_cmpr to no compression. The option "clear" resets now also the options "raw_cmpr" and "do_prerotion". Update 31/08/2011 P. Boesecke (boesecke@esrf.fr) Add new option "raw_cmpr" Update 19/08/2011 P. Boesecke (boesecke@esrf.fr) current_shm_data[MAXTYP] added to avoid calls to getShmData when the shared memory is possibly already detached (see 27/07/2011). current_shm_data is updated and modified like current_shm. Update 01/08/2011 P. Boesecke (boesecke@esrf.fr) label error_ret -> get_buffer_error. In all headers the default prerotation angles are 0. The prerotation parameters are only read for SRC and DRK headers. This allows to write the actual prerotation parameters into the internal header of the SDX and SDY images. The validity of the LUT can then be checked by comparing them with the prerotation parameters in the SRC header: if do_prerotation is set all prerotation parameters must coincide, otherwise all preroation angles must be 0. Update 27/07/2011 P. Boesecke (boesecke@esrf.fr) getShmDataPtr can be called with a version number. The data pointer needs sometimes to be determined when the shared memory in not accessible any more. This is a dirty workaround which should be fixed. %x changed to %p for pointers. Update 23/07/2011 P. Boesecke (boesecke@esrf.fr) prerotation parameters imported by scanhead Update 09/07/2011 P. Boesecke (boesecke@esrf.fr) getShmDataPtr: This version of spd distinguishes automatically between different shared memory versions. The function getShmDataPtr returns the start of the data section depending on the shared memory version. analyse_args: only a single return point for debugging Update 23/09/2010 R. Wilcke (wilcke@esrf.fr) put_buffer(): add SPEC types SHM_ULONG and SHM_LONG to the allowed data types and use edf_datatype2machinetype() to convert them to the correct type for the computer used; get_buffer(): add SPEC types SHM_ULONG and SHM_LONG to the allowed data types for input buffers. Update 03/06/2010 P. Boesecke (boesecke@esrf.fr) command line option azim_pro added, azim_int updated, azim_da, azim_a0, azim_a1 are expressed in degrees, Because the arguments of azim_int need to be in radian they are multiplied with NUM_PI/180.0, in put_buffer exception for AZITYP updated. Update 02/12/2009 R. Wilcke (wilcke@esrf.fr) replace the term "azimuthally integrated" by "azimuthally regrouped" (likewise "integration" by "regrouping"). Update 16/11/2009 R. Wilcke (wilcke@esrf.fr) analyse_args(): pass a copy of "tmpnam1" to the "basename()" routine (the routine can change its argument); analyse_args(): add command line option "ave_ext"; analyse_args(): put the prefix "SPD_" in front of the macros for the return code (ERRFLG, BASUSE, ...) and move the definitions to the file "spd.h". Update J. Kieffer get_time(), --server command line option added in MAIN Update 06/10/2009 P. Boesecke (boesecke@esrf.fr) SAXS_PI => NUM_PI Update 30/09/2009 R. Wilcke (wilcke@esrf.fr) add argument "progname" to all prntvers() calls. Update 09/09/2009 R. Wilcke (wilcke@esrf.fr) analyse_args(): set "inptbusy" to 0 when shared memories have been copied (was set to 1 by mistake). Update 27/08/2009 R. Wilcke (wilcke@esrf.fr) get_buffer(): copy shared memory types SRCTYP, DRKTYP and SBKTYP always to a newly allocated internal buffer; define new global variable "inptbusy"; analyse_args(): set and reset "inptbusy" at the start and end of the input data acquisition; add routine getstate() to return the value of "inptbusy". Update 24/08/2009 R. Wilcke (wilcke@esrf.fr) analyse_args(): get version of the program from the new routine "prntvers()", no longer from __DATE__ and __TIME__; analyse_args(): add command line option "version" to print the version string of the program. Update 06/05/2009 R. Wilcke (wilcke@esrf.fr) analyse_args(): change "flat_distortion" default from 0 to 1; analyse_args(): use the "outdir" value also for the "xoutfile" and "youtfile" names. Update 04/05/2009 R. Wilcke (wilcke@esrf.fr) analyse_args(): rename variables: "do_later" to "flat_aft", "do_spd" to "do_dist" and "do_flat" to "flat_dist"; set default values: "cor_ext" = ".cor" and "src_ext" = ".edf"; do not use directory path of source file for corrected file; set directory path of "base_name" as default for "outdir". Update 24/04/2009 R. Wilcke (wilcke@esrf.fr) analyse_args(): modify code for the obsolete options "to_ext" and "from"ext"; analyse_args(): add new command line argument "outdir" and code to define a directory path for the output files. Update 17/04/2009 R. Wilcke (wilcke@esrf.fr) get_filnam(): there may now be a prefix and postfix string before and after the keyword string; analyse_args(): if the dark file name does not contain a path, use the one from the source image file. Update 25/03/2009 P. Boesecke (boesecke@esrf.fr) set_type(): add code to set type to default if input argument is empty or NULL. Update 16/02/2009 A. Gotz (andy.gotz@esrf.fr) flag MAKE_FUNCTION added Update 18/11/2008 R. Wilcke (wilcke@esrf.fr) analyse_args(): acquire buffer for dark image only if needed. Update 24/06/2008 R. Wilcke (wilcke@esrf.fr) reset the values of the command line arguments "type" and "dvo" to their defaults when input argument "clear" is given. Update 16/06/2008 P. Boesecke (boesecke@esrf.fr) analyse_args(): add new command line arguments "type" and "dvo" and code (new routines set_type(), set_dvo()). Update 22/01/2008 R. Wilcke (wilcke@esrf.fr) slightly modify many error messages in the program; _prmsg(): change the message text for WARNING, ERROR and FATAL messages by printing the message type in front of the text; get_buffer(): change test for incompatible image sizes: before they had to be identical modulo binning, now the correction images (e.g. dark, flood...) can be bigger than the source image as long as they contain the source image fully. Update 14/01/2008 R. Wilcke (wilcke@esrf.fr) analyse_args(): multiply inp_max and inp_min with the software binning factors. Update 11/01/2008 R. Wilcke (wilcke@esrf.fr) get_buffer(): change compatibility test of image to acquire with source image: instead of requesting identical dimensions modulo binning, test if source image is fully contained in the image to be acquired. Update 17/12/2007 R. Wilcke (wilcke@esrf.fr) get_buffer(): correct x-scaling argument of map_imag() call; put_buffer(): write PSize_2 value for AZITYP data in radian. Update 11/12/2007 R. Wilcke (wilcke@esrf.fr) analyse_args(): if there are several input files, do each time a test for re-allocation of all other file buffers as well. This may be necessary because of different binnings of the input source file. Update 06/12/2007 R. Wilcke (wilcke@esrf.fr) analyse_args(): change code to obtain the name of the input source file from a filename pattern template. Update 28/11/2007 R. Wilcke (wilcke@esrf.fr) get_buffer() and analyse_args(): change code to account for the fact that map_imag() now also does the linearity correction; analyse_args(): apply linearity correction to dark constant. Update 23/11/2007 R. Wilcke (wilcke@esrf.fr) analyse_args(): correct error in getting the darkfile name. Update 09/10/2007 R. Wilcke (wilcke@esrf.fr) add new function get_filnam() to get the name of a file from a keyword in the source image file; analyse_args(): add code to read the name of the distortion file from a keyword in the source image file, and read a separate distortion file for each source image if this feature is used. Update 26/09/2007 R. Wilcke (wilcke@esrf.fr) analyse_args(): add code to read the name of the flood field image file from a keyword in the source image file, and read a separate flood field image file for each source image if this feature is used. Update 18/04/2007 R. Wilcke (wilcke@esrf.fr) get_buffer(): test if the dimensions of the image processed (modulo binning) do agree with the ones of the source image; analyse_args(): change default value for "distfile" from "spatial.dat" to the empty string; analyse_args(): do not make distortion correction if neither "distortion_file" nor "xfile" and "yfile" are specified. Update 10/04/2007 R. Wilcke (wilcke@esrf.fr) analyse_args(): add code to read the name of the dark image file from a keyword in the source image file, and read a separate dark image file for each source image if this feature is used; analyse_args(): add new command line argument "do_dark" and code to suppress dark image correction. Update 13/02/2007 R. Wilcke (wilcke@esrf.fr) analyse_args(): for the update of the output image header, do no longer use the special enumerated data, but the general flags for the user data header; analyse_args(): introduce a new image type CMDTYP to store the header values that are defined on the command line; analyse_args() and scanhead(): set the command-line defined values for source and dark image header in scanhead() instead of analyse_args(). Update 26/09/2006 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new command line argument "inp_exp" and code for linearity correction (apply a constant exponent to all values of an input image); analyse_args(): modify calls of mark_overflow_nocorr() to add new argument containing the list with the dummy pixels. Update 07/06/2006 R. Wilcke (wilcke@esrf.fr) user_code(): declare function as "int" and return a value (to be consistent with the declaration in "spd.h"); get_buffer(): for AVETYP data from shared memory: add check for the "rows" size of the buffer; analyse_args(): add new command line argument "azim_a1" and code for the azimuthal averaging over the second angle range; analyse_args(): for dark image data coming from a shared memory buffer and then saved to a file, add the name of this file to the header values of the source file (this will also put it into the header of the corrected image file); analyse_args(): correct an error in the freeing of the source image buffer after re-mapping. Update 26/05/2005 R. Wilcke (wilcke@esrf.fr) get_buffer(): force mapping of image also if dimension is different from the source image. Update 04/04/2005 R. Wilcke (wilcke@esrf.fr) analyse_args(), put_buffer() and help_arg(): add new command line argument "azim_pass" to pass the full source image header to the azimuthally regrouped output file. Update 01/04/2005 R. Wilcke (wilcke@esrf.fr) scanhead(), analyse_args() and read_esrf_file(): print info concerning header values directly in scanhead(); scanhead(): move to this routine from routine set_headval() (file "correct.c") the initialization of header values that are not set by the input data. Update 24/03/2005 R. Wilcke (wilcke@esrf.fr) get_buffer(): force re-acquisition of image also if dimension has changed. Update 22/03/2005 R. Wilcke (wilcke@esrf.fr) analyse_args(): write the file name of the input image to the history only if input is indeed from a file; get_buffer(): change how type == HD_TYP is skipped in the test for undefined dimensions. Update 09/03/2005 R. Wilcke (wilcke@esrf.fr) get_buffer(): force re-acquisition of image not only if binning has changed, but also if offset has changed. Update 15/02/2005 R. Wilcke (wilcke@esrf.fr) main(): return exit code EXIT_SUCCESS if the call to analyse_args() is successful or EXIT_FAILURE if not. Update 25/01/2005 R. Wilcke (wilcke@esrf.fr) analyse_args(): handle new header update values "ofs1", "ofs2", "bsz1" and "bsz2"; scanhead(): for data type SDXTYP and SDYTYP, store the values for the displaced parameters into the user header. Update 24/01/2005 R. Wilcke (wilcke@esrf.fr) __main(): declare function as type "int" and do "return(0)"; put_buffer(): write "DetectorRotation_n" values to EDF header in degree with "_deg" suffix. Update 13/01/2005 R. Wilcke (wilcke@esrf.fr) change header key words back: Psize_1 -> PSize_1, Psize_2 -> PSize_2; analyse_args(): remove "ave_waxs" command line argument and all code referring to it, including as argument to the azim_int() call (was replaced by "pro", see below); analyse_args(): remove command line arguments "flat_after" (replaced by new values of "do_distortion") and "center_distort" (replaced by new values of "psize_distort"); analyse_args(): add new values "2" and "3" for command line argument "do_distortion" and code to process them; analyse_args(): add new values "2" for command line argument "psize_distort" and code to process it; analyse_args(): add header keys "ProjectionType", "DetectorRotation_1", "DetectorRotation_2" and "DetectorRotation_3", add command line arguments "pro", "rot_1", "rot_2" and "rot_3" to set them from the command line and hand them to the correction routines; scanhead(): get the values for the new header keys from the header; put_buffer(): add the new header keys to the output data; help_arg(): add help text for the new arguments. Update 21/09/2004 R. Wilcke (wilcke@esrf.fr) change bin_imag() call to map_imag(); get_buffer(): re-map the geometry of the image also in the case that the offsets are different from the source image. Update 14/09/2004 R. Wilcke (wilcke@esrf.fr) get_buffer(): use clean_buffer() to remove data buffer if no input source for input data types. Update 07/09/2004 R. Wilcke (wilcke@esrf.fr) get_buffer(): always set old_where[type] = no_stor if there is neither a file nor a shared memory for an output data type. Update 30/08/2004 R. Wilcke (wilcke@esrf.fr) analyse_args(): call set_imgbuf() only if the buffer pointer has been updated by get_buffer(); get_buffer(): move the prepare_flood() call to set_imgbuf() (file correct.c). Update 25/08/2004 R. Wilcke (wilcke@esrf.fr) put_buffer(): do not copy all of online header to saved dark image file header; analyse_args(): add commandline option header_min to set minimum data header length for output files; analyse_args(): add command line option ave_waxs and add it as input parameter to the azim_int() call; analyse_args(): add command line option center_distort and modify the code to allow setting of center coordinates and sample distance in addition to pixel size. Update 24/08/2004 R. Wilcke (wilcke@esrf.fr) fprint_first_el(): corrected format for "printf(); put_buffer(): remove unused variables; main(), clean_buffer(): add "return(0)" at the end of the routine; analyse_args(): the code that copies the input arguments to the history header has been moved into scan_argument() (file util.c). Update 15/06/2004 R. Wilcke (wilcke@esrf.fr) get_buffer(): modify tests for "cols" and "rows"; scanhead(): replace calls to atof() by calls to num_str2long() or num_str2double(). Update 29/03/2004 R. Wilcke (wilcke@esrf.fr) scanhead(): get header values BSize_1, BSize_2, Dim_1 and Dim_2; put_buffer(): update header information with the values of BSize_1, BSize_2, Dim_1 and Dim_2 in the user's header structure. Update 19/03/2004 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new commandline options to set data header values: bis_1, bis_2; analyse_args(): get buffer for corrected image after the buffers for dark, floodfield and scattering background images; read_esrf_file(): remove test for image dimensions (is done in get_buffer()); get_buffer(): add code for binning; use function set_imgbuf() instead of separate calls to set_bckgim(), set_drkim() and set_floim(). Update 02/02/2004 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new command line option header_ext to save the header of the input source image to a file; put_buffer(): allow type HD_TYP to save the header data to a special output file. Update 14/01/2004 R. Wilcke (wilcke@esrf.fr) _prmsg(): add handling of variable length argument list with "stdarg" for ANSI C compilers. Update 04/11/2003 R. Wilcke (wilcke@esrf.fr) analyse_args(): correct format for writing arguments "dummy" and "src_id" into history. Update 16/09/2003 R. Wilcke (wilcke@esrf.fr) analyse_args(): write history parameters in the same form as they are specified on the command line; analyse_args(): add "dummy" command line argument to history. Update 31/07/2003 R. Wilcke (wilcke@esrf.fr) put_buffer() and save_esrf_file(): write the history already in put_buffer() to the internal header structure. Update 21/07/2003 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new command line option norm_factor to set a multiplication factor for the scattering intensity normalization; analyse_args(): add the scattering intensity normalization factor as second argument to the set_normint() function. Update 18/07/2003 R. Wilcke (wilcke@esrf.fr) analyse_args(): correct error in the construction of the history for the corrected image. Update 12/03/2003 R. Wilcke (wilcke@esrf.fr) analyse_args(): correct error in the logic for looping over several input source image files. Update 11/03/2003 R. Wilcke (wilcke@esrf.fr) analyse_args(): if there are header values defined on the command line, get the present value of the header flags first before ORing with the flags for the command line values. Update 27/02/2003 R. Wilcke (wilcke@esrf.fr) analyse_args(): set BASUSE flag only if the output buffer was successfully written; analyse_args(): write corrected output file only if command line option "cor_ext" is set. Update 17/12/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new commandline options to set data header values i0 and i1. Update 12/12/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): correct file name for azimuthal regrouping for the online case; analyse_args(): correct the loop over the input data files; Update 28/11/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): put the help text for command line arguments in a new function help_arg(); help_arg(): do the printout with two new macros PRNTHELP and PRNTHLPN. Update 26/11/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): change code to integrate both the "files input" and the "shared memory input" into one correction loop; analyse_args(): add new commandline options to set data header values: cen_1, cen_2, off_1, off_2, pix_1, pix_2, dis, ori, tit, wvl; analyse_args(): change argument values in set_psizdist() call. analyse_args(): add new commandline option mask_file to define a mask of pixels to ignore for the azimuthal calculations. Update 24/10/2002 R. Wilcke (wilcke@esrf.fr) put_buffer() and get_buffer(): add code to handle image data of type "unsigned character". Update 11/10/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): close all open EDF data files when "clear"; Update 26/09/2002 R. Wilcke (wilcke@esrf.fr) move routine _prmsg() from "correct.c" to "inout.c"; make "verbose" a global variable; analyse_args(): remove calls to set_verbose(); _prmsg(): add code to handle the new message flag PRERR. Update 17/09/2002 R. Wilcke (wilcke@esrf.fr) put_buffer(): return with error if save_esrf_file() fails. Update 16/09/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): give error message if requested number of rows or columns is different from the one found in shared memory; reallocate the message levels for the prmsg() calls. Update 05/09/2002 R. Wilcke (wilcke@esrf.fr) scanhead() and put_buffer(): add code for new "data_head" member "ExpTime"; scanhead() and put_buffer(): change code to treat "data_head" members "Intens_0" and "Intens_1" as string instead of "float". Update 03/09/2002 R. Wilcke (wilcke@esrf.fr) change references from "background correction" to "dark image correction, this includes changing the parameter names bkg_const, bkg_file, bkg_id to dark_const, dark_file, dark_id; rename enumerated variable BKGTYP to DRKTYP; change function calls set_bkgconst() and set_bkgim() to set_drkconst() and set_drkim(); change parameter and variable names for "scattering background correction", this includes changing the parameter names scat_const, scat_fact, scat_file, scat_id to bckg_const, bckg_fact, bckg_file, bckg_id; rename enumerated variable SCATYP to SBKTYP; change function calls set_scaconst(), set_scafact() and set_scaim() to set_bckgconst(), set_bckgfact and set_bckgim(). Update 13/06/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): change default of "psize_distort" from 1 to 0; analyse_args(): put as program name the content of the input argument "progname" instead of the fixed string "corimg_corr" into the history. Update 10/06/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): added parameters "-min", "-max", "-pass" and "-pix_file" to the history string. Update 10/06/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): changed the syntax of the history string. Update 05/06/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): added dark constant to history. Update 04/06/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): create a character string describing the processing that is done with the image and write it to the "History" keywords of the output data file; analyse_args(): initialize "inpfact" to 1. (was 0. before). Update 03/06/2002 R. Wilcke (wilcke@esrf.fr) read_esrf_file(): declare "bytebuf" as a buffer with length "EdfMaxLinLen + 1" instead of declaring it a pointer and assigning memory later; get_buffer() and put_buffer(): declare "id" and "val" buffers with length "EdfMaxKeyLen + 1" and "EdfMaxValLen + 1". Update 31/05/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): free HD_TYP buffers if there is no online header for the image; read_esrf_file(): replace machine_sizeof() call by edf_machine_sizeof() (change in "edfio" library); get_buffer(), analyse_args(), save_esrf_file() and read_esrf_file(): add calls to read, modify and write the HISTORY keywords in the data header. Update 21/05/2002 R. Wilcke (wilcke@esrf.fr) clean_buffer(): free buffer only if "free_flag" is set (before buffer was always freed for shared memory access); get_buffer(): set "current_shm[type]" to NULL if the file has changed, and also in case of error return; Update 14/03/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): force reading of the input file if the data buffer is a NULL pointer. Update 13/03/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): allow "spatial distortion displacement" data types; put_buffer(): do no longer create / reset the internal header and history buffer for "spatial distortion displacement" data types; Update 12/03/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): change values for "old_where" from integer to enumeration constants; move declaration of global variable "typestr" and definition of macro MAXTYP to "spd.h"; get_buffer(): use 0 and MAXTYP to test for valid values of the "type" input argument; get_buffer() and put_buffer(): replace data type SPDTYP by the two new data types SDXTYP and SDYTYP. Update 11/03/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): return error if file name given for output or header buffer; get_buffer(): correct return status (1 if buffer has changed, 0 if not, code -1 for error has not changed); analyse_args(): use corrected return status of get_buffer(); get_buffer(): create or reset an internal history buffer for each data buffer; read_esrf_file(): read the history information from the file into the internal history buffer; analyse_args(): add information about the processing of the corrected and azimuthally regrouped images to the internal history buffer; save_esrf_file(): write the internal history buffer to the output file. Update 06/03/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): put in maximum field width in the sscanf() calls to prevent buffer overflow. Update 05/03/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): change test for new file; get_buffer(): reset internal header buffer only if input data have changed; analyse_args(): obtain values from the online header only if there is also an online source image; scanhead() and put_buffer(): add code for new "data_head" members "Title" and "Time". Update 04/03/2002 R. Wilcke (wilcke@esrf.fr) rename global variable NO_TYP to HD_TYP; put_buffer() and save_esrf_file(): change code to allow the SPDTYP data type. Update 01/03/2002 R. Wilcke (wilcke@esrf.fr) read_esrf_file(): allocate a new data buffer only if needed, i.e. if the buffer pointer is NULL. Update 21/02/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): set "distortion_file" value only if "xfile" and "yfile" are not specified; analyse_args(): set the values for "distortion_file", "xfile", "yfile", "xoutfile" and "youtfile" only if "do_distortion" is set. Update 24/01/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): correct the determination of the return value; analyse_args(): compare with -1 instead of NULL when testing for a not defined "bkgid" and "srcid"; analyse_args(): set the SPD_ERRFLG if a requested data buffer cannot be obtained; analyse_args(): set new flag BASUSE in the return value to indicate if the "base_name" was used in creating a file; Update 16/01/2002 R. Wilcke (wilcke@esrf.fr) analyse_args(): do not call the correction routines if there is no filename or shared memory specified for the results; redefine the return value to specify which files were created. Update 10/01/2002 R. Wilcke (wilcke@esrf.fr) remove routine fprint_header(). Update 09/01/2002 R. Wilcke (wilcke@esrf.fr) scanhead(): use new EDF-routine edf_search_header_element() instead of find_header_element(); remove routine find_header_element(). Update 08/01/2002 R. Wilcke (wilcke@esrf.fr) get_buffer(): do not free the internal header buffer for the online header before reading the header; analyse_args(): correct handling of "save_dark" parameter; find_header_element(): correct arguments to strcasecmp() call: second argument must be "key", not "value"; scanhead(): change "val" from (const char **) to (const char *). Update 20/12/2001 R. Wilcke (wilcke@esrf.fr) save_esrf_file(): remove last input argument (title), add "type" as new 5th argument, and change code accordingly; save_esrf_file(): do not access internal header for SPDTYP; put_buffer(): remove last argument (title) in save_esrf_file() call and add "type" as new 5th argument. get_buffer(): do no longer create a header stream for the online header information, put it directly into the internal header buffer; remove global variable HDSTREAM (no longer needed); make global variable HEADER_BUF a local one in get_buffer(), rename it to "head_buf" and change code accordingly; analyse_args(): set default of "dark_ext" to empty string; get_buffer(): add new return value "1", return "0" if a new data buffer was obtained and "1" if the old buffer is still valid; analyse_args(): change code to account for new return value of get_buffer(); Update 19/12/2001 R. Wilcke (wilcke@esrf.fr) add new routine find_header_element() to find the value of a specified keyword in the header buffer; scanhead(): change code to use the new find_header_element() routine, and change first input argument to the type of the image instead of the data stream; analyse_args() and read_esrf_file(): change the arguments in the call to scanhead(); read_esrf_file(): put the file header always in the corresponding internal header buffer, and for SRCTYP also into the NO_TYP header buffer; save_esrf_file(): remove the input argument HDSTREAM; put_buffer(): remove the input argument HDSTREAM in the call to save_esrf_file(); analyse_args(): change the "while" loop over the input files to a "do ... while" loop, and "continue" if the output file name for a particlular input file could not be constructed; analyse_args(): copy a restricted set of the source image header values to the dark image. Update 18/12/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): make "headrows" and "headcols" non-static and do not initialize them. Update 17/12/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): move the azimuthal regrouping and averaging directly behind the correct_image() calls (2 locations!!!); put_buffer(): modify outptr from (void **) to (void *) and change code accordingly (old version crashed the program). Update 13/12/2001 R. Wilcke (wilcke@esrf.fr) put_buffer(): write units after the header values; put_buffer(): write the full header of the input image only to the corrected image and the source image, not to e.g. the azimuthal regrouped image. Update 13/12/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(), put_buffer() and read_esrf_file(): write the header information into the "NO_TYP" instead into the "SRCTYP" buffer and get it back from there for the output. Update 11/12/2001 R. Wilcke (wilcke@esrf.fr) put_buffer(): read online header values from the internal buffer; scanhead(): modify the way the header keywords are read; put_buffer(): write all values of the CORTYP header back to the online header; Update 10/12/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(), put_buffer() and save_esrf_file(): create the internal header buffer only in get_buffer() with edf_new_header(); put_buffer(): write the elements of the header structure directly with edf_add_header_element() into the internal header buffer; put_buffer() and save_esrf_file(): decide in put_buffer() if the online header information is written to the output file. Update 04/12/2001 R. Wilcke (wilcke@esrf.fr) set errno = 0 for all calls to prmsg() with error types FATAL and ERROR that do not correspond to system errors; analyse_args(): add new options "src_ext" and "cor_ext", remove option "save_src" and mark options "cor_file", "from_ext" and "to_ext" as obsolete; Update 03/12/2001 R. Wilcke (wilcke@esrf.fr) use the size of the array "typestr" to set the dimensions of "current_shm", "old_file", "old_where", "last_mtime" and "last_utime"; analyse_args(): use __DATE__ and __TIME__ for the printout of the current version; analyse_args(): add command line options "ave_id" and "ave_scf"; add new type "averaged" to the array "typestr"; analyse_args(), get_buffer() and put_buffer(): add code to handle the new buffer type AVETYP; analyse_args(): add the "averaged buffer" and the scale factor to the azim_int() input arguments. Update 30/11/2001 R. Wilcke (wilcke@esrf.fr) get_buffer() and analyse_args(): move the set_xysize() call from get_buffer() to analyse_args(); get_buffer(): modify the tests for the dimensions of the image buffer to be acquired; analyse_args(): change command line options save_raw -> save_src, raw_ext ->src_ext; analyse_args(): add command line option "azim_id"; analyse_args(): always detach from SRCTYP buffers at the end of the routine (was only for srcid != -1). Update 29/11/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): add "rows" and "cols" as input arguments; change all calls to get_buffer() by adding "rows" and "cols"; get_buffer() and read_esrf_file(): test input "rows" and "cols" against values of the image and return with error if they do not agree; get_buffer(): add AZITYP to the allowed data types and tread it as CORTYP; change some header key words: PSize_1 -> Psize_1, PSize_2 -> Psize_2, Orientation -> RasterOrientation; analyse_args(): add command line option "azim_ext". Update 28/11/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add command line option "base_name"; Update 27/11/2001 R. Wilcke (wilcke@esrf.fr) put_buffer() and get_buffer(): make "typestr" a global array; put_buffer(), get_buffer() and save_esrf_file(): replace the fixed header name "src_head" by the string in "typestr"; put_buffer(): change code to put the correct header values for source and dark images into the file; put_buffer(): change code to save AZITYP images; analyse_args(): made the allocated AZITYP buffer 4 rows bigger to store the "s" and averaged values. Update 26/11/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): for the azimuthal regrouping, use the radial and angular dimensions instead of the end values, replace the command line arguments azim_a1 and azim_r1 by azim_a_num and azim_r_num, and change the input arguments to azim_int() accordingly; add two new arguments to the put_buffer() call to define the dimensions of the buffer, and change the calls accordingly; Update 20/11/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): protect against a NULL return from outname(); Update 19/11/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new additive and multiplicative constants to adjust the values of the input image and of the scattering background image; analyse_args(): replace variable names "in_ext" and "out_ext" by "from_ext" and "to_ext"; Update 16/11/2001 R. Wilcke (wilcke@esrf.fr) add new command line argument "psize_distort" and the code to get it from the user and hand it to the correction routines. Update 15/11/2001 R. Wilcke (wilcke@esrf.fr) get_buffer() and save_esrf_file(): replace references to the "onl_head" buffer by "src_head"; put_buffer() and save_esrf_file(): move creation of the internal header buffer and copying of the online header from save_esrf_file() to put_buffer(); put_buffer(): change the way the header keywords and values are handled for the updating of the internal header buffer and the online header; analyse_args(): save the source and dark current shared memory segments to files if requested. Update 13/11/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): improve the loop processing for the reading of the online header; put_buffer(): write the current values of the CORTYP header structure back to the online header, if it exists; Update 12/11/2001 R. Wilcke (wilcke@esrf.fr) save_esrf_file(): change the way the header values from the user's header structure are written into the data file: write them into a buffer with sprintf(), then use edf_write_header_line(). Update 08/11/2001 R. Wilcke (wilcke@esrf.fr) split the code of "util.c" in two files: - "inout.c" contains all input/output related routines, - "util.c" contains the other routines of the old "util.c". Update 08/11/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new command line arguments "inp_min" and "inp_max" and code to hand them to the correction routines. Update 05/11/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add 2 more new arguments to azim_int() call and code to get their values from the user. Update 31/10/2001 R. Wilcke (wilcke@esrf.fr) user_code(): add call to set_return_value() to return a status to the calling program (i.e. "spec). Update 22/10/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add 3 new arguments to azim_int() call and code to get their values from the user; Update 19/10/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): change test for correct_image() return value; analyse_args(): add code to implement azimuthal regrouping. Update 16/10/2001 R. Wilcke (wilcke@esrf.fr) read_esrf_file(): create a new header module for the source image header before reading values into it; move the closing of the source image header module from save_esrf_file() to get_buffer(); save_esrf_file(): create a new header module for the online image header before reading values into it; get_buffer(): close both the source and the online header module whenever the input source file or the online header has changed; read_esrf_file(): always read new values into the header module, even if "headpass" is 0. Update 03/10/2001 R. Wilcke (wilcke@esrf.fr) save_esrf_file(): change last input argument to contain the EDF I/O stream for the temporary online header and modify code accordingly; put_buffer(): change last argument in save_esrf_call() to the EDF I/O stream for the temporary online header; Update 02/10/2001 R. Wilcke (wilcke@esrf.fr) scanhead(): get the values for the header structure from the temporary "HDSTREAM" header; scanhead(): change the first input argument from a pointer to the header buffer ("char *header") to the stream descriptor for the EDF data I/O ("int stream"), and change function declaration accordingly; analyse_args(): change the first argument of the scanhead() call from the buffer pointer to the header stream descriptor; analyse_args(): pre-set "Dummy" for the corrected image from the online header; read_esrf_file(): replace the code to read the header keywords by a call to scanhead(); rename HEADER_NO and HEADER_LEN to "headrows" and "headcols", make them local variables in scanhead() and remove them anywhere else; save_esrf_file(): remove the last two input arguments and test for "HDSTREAM != -1" to find out if there is an online header; put_buffer(): remove the last two arguments in the call to save_esrf_file(). Update 01/10/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): free temporary header when "HDSTREAM" is closed. Update 28/09/2001 R. Wilcke (wilcke@esrf.fr) added new global variable "HDSTREAM" for a temporary EDF header; get_buffer(): added code to read the online header and to put it into the temporary EDF header; analyse_args(): set "HDSTREAM" to -1 if "clear" parameter is given on the command line; save_esrf_file(): add code to get the online header from the temporary EDF header and write it to the output file header; Update 25/09/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add new command line parameter "pass" and the code to set it; read_esrf_file() and save_esrf_file(): add code to read the entire header from the source file and to write it to the corrected image file; scanhead() and save_esrf_file(): replace edf_maxkeylen() and edf_maxvallen() calls by macros EdfMaxKeyLen and EdfMaxValLen; read_esrf_file(): replace edf_maxlinlen() call by macro EdfMaxLinLen. Update 24/09/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): do no longer test the return value of scanhead(); analyse_args(): change code to have correct setting of header values and output "Dummy" value; read_esrf_file(): move the code with the label "badheader" to the end of the routine. Update 14/09/2001 R. Wilcke (wilcke@esrf.fr) read_esrf_file(): change the opening mode for the file in the edf_open_data_file() call from "old" to "read"; analyse_args(): write an output file only if correct_image() was successful; analyse_args(): clear the flags of the SRCTYP header structure before getting the new header values if the image is from a shared memory. Update 20/08/2001 R. Wilcke (wilcke@esrf.fr) add declaration for function scanhead(); save_esrf_file(): put the initialized values of the CORTYP header structure in the output file; analyse_args(): declare "src_im" as static and do not free the buffer when processing input source files; analyse_args(): set HEADER_NO and HEADER_LEN to 0 if no online header; analyse_args(): test if the command line argument "dummy" is set, and replace "Dummy" by the value in the input file only if it is not set; get_buffer() and analyse_args(): set the "Dummy" value from the input source file, and reset it again to the value of the command line if this is set. This is a kludge! It should be done with a proper flag signaling when "Dummy" is set; Update 17/08/2001 R. Wilcke (wilcke@esrf.fr) read_esrf_file() and scanhead(): fill the "init" member of the header structure with the new flags indicating which keywords have been found; read_esrf_file(): transfer the header structure also for type "SPDTYP"; analyse_args(): read input source image before all other images to define the dimensions of the images to process; get_buffer(): call prepare_flood() only after testing for the correct size of the flood field image; analyse_args(): do not reset the image buffers to NULL when executing "clear"; get_buffer(): add variable "shm_changed" to flag if the shared memory segment has changed, and call prepare_flood() only if "shm_changed || file_changed" is true; scanhead(): do no longer return an error if not all header elements are found; scanhead() and read_esrf_file(): get additional header keyword "WaveLength". Update 14/08/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): if there is a shared memory header provided and the command line option "dummy" is not given, use the "Dummy" value in the shared memory header to set "Dummy" for the output file (with set_dummy()); read_esrf_file(): add input argument "type" in 5th position; read_esrf_file(): read the values for the structure type "data_head" from the header of the file and, if successful, transfer the structure to the corresponding image type header structure in the correction routines (except for SPDTYP); get_buffer(): change the call to read_esrf_file() to include the new "type" argument. Update 13/08/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add command line argument "clear" and the corresponding code to reset all option values to their default values; analyse_args(): add the second argument to the set_headval() call to put the online header into the SRCTYP header; Update 10/08/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): rename variable "filename" to "distfile", declare it static and initialize it to "spatial.dat"; analyse_args(): declare as static the variables simul_flag, do_spd, do_flat, do_later, verbose, norm_int, overf, bkgconst, dummy and arad and give them the required initialization values; scanhead() and save_esrf_file(): change format for reading of header from "%s" to "%[^\n]" as the string can contain blanks; analyse_args(): correct the code to get the "simul_flag" option (it got "corid" instead) and move the code for the grid simulation directly behind the loop over the option arguments; analyse_args(): transfer the parameters to the correction routines only after the end of the loop over the option arguments. Update 09/08/2001 R. Wilcke (wilcke@esrf.fr) increase dimensions of current_shm[], old_where[], old_file[], last_mtime[] and last_utime[] from 5 to 6 and add initialization elements; analyse_args(): change code for the background corrections: now the background constant can be specified in addition to any of the two other background options. Update 08/08/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): in the "error_ret", free the buffer if it has been allocated; analyse_args(): rename "input_file" to "srcfile"; analyse_args(): remove declaration of shm_src, shm_cor, shm_flo and shm_bkg; analyse_args(): test if the get_buffer() calls have been successful, and return with an error if not; analyse_args(): test for "srcid != -1" instead of "src_im" for the shared memory case; analyse_args(): move the get_buffer() call for the source image into the code for the shared memory case - the file case has already its own get_buffer(); analyse_args(): give the get_buffer() call for the source image a "srcid" = -1 for the file case and a "srcfile" = NULL for the shared memory case; main(): print an error message if analyse_args() return != 0. Update 07/08/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): add code to get a buffer for the scattering background image and hand it over to the correction routines; get_buffer(): add code for obtaining a buffer for the scattering background image; clean_buffer(): do not free an empty buffer pointer; analyse_args(): clean the source image buffer at the end of the routine (did not happen before if there was no valid buffer for the corrected image); rename global variable COR_FILE to "corfile" and make it a local variable in analyse_args(). Update 06/08/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): initialize "dummy" to 0., and add code to select the correct value of "dummy" - this parameter might be given on the command line and in the user-header. Update 03/08/2001 R. Wilcke (wilcke@esrf.fr) add routine scanhead() to get the header keywords and values from the header shared memory segment and put them in the header structure; analyse_args(): read header from shared memory segment directly after the source image has been read, get the values using scanhead() and hand them to the correction routines with set_headval(). Update 02/08/2001 R. Wilcke (wilcke@esrf.fr) move declaration of structure current_shm to the beginning of the code; analyse_args(): add command line argument "norm_int" and the code to read it in and pass it to the correction routines; get_buffer(): change order of arguments in the set_xysize(); get_buffer(): declare return type of function as "int". Update 01/08/2001 R. Wilcke (wilcke@esrf.fr) move the get_buffer() and clean_buffer() calls for the header shared memory segment (HEADER_ID) from put_buffer() to analyse_args(); rename global variable HEADER_ID to "headid" and make it local to routine analyse_args(); rename local variable header_buf to HEADER_BUF and make it global; Update 26/07/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): correct the values given to HEADER_NO and HEADER_LEN; save_esrf_file(): change the format in the sscanf() call of the header buffer to remove leading blanks in the values; save_esrf_file(): update comments about the header keywords that are automatically written (EDF_DataFormatVersion and EDF_DataBlocks keywords removed); save_esrf_file(): change reading of the header buffer so that it can work with two different formats of the header buffer. Update 28/06/2001 R. Wilcke (wilcke@esrf.fr) use routines set_bkgim() and set_floim() to hand pointers to the background image and the flood field image to the image correction routines; change call to correct_image() by eliminating the background image and the flood field image from the input arguments. Update 26/06/2001 R. Wilcke (wilcke@esrf.fr) correct the comments explaining "xfile" and "yfile"; analyse_args(): add command line arguments "xoutfile" and "youtfile" and the code to read them in and pass them to the correction routines; Update 25/06/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): add missing string argument in prmsg() call in test for correct image size; remove declaration of variables X_COR, Y_COR, DO_XYFILE and SPLINE_INVALID; remove declaration of variables XOFFSET and YOFFSET and all code that uses them (they do not seem to serve any purpose in the image correction); remove declaration of variable COR_FORMAT and all related code, the output format is now always EDF; remove declaration of the parameters for the geometrical method (CURV_RADIUS, XCENTER and YCENTER) and all related code. This method is no longer used; remove function save_mar_file(), it is no longer needed; analyse_args(): change type of "bkgconst" from "int" to "float" and change format argument in scan_argument() accordingly; remove declaration of variable LUT_INVALID (this is now an internal variable of the functions in "correct.c"); use new function calls to set the values of former global variables: - set_verbose() for "verbose"; - set_overflow() for IMAGE_OVER and IMAGE_OVER_SET; - set_dummy() for Dummy; - set_actrad() for ACTIVE_R; - set_splinfil() for FILENAME; - set_xycorin() for XFILE and YFILE; - set_xysize() for XSIZE and YSIZE; - set_bkgconst() for BKG_CONST; use new function calls to obtain the values of former global variables: - get_xsize() for XSIZE; - get_ysize() for YSIZE; Update 19/06/2001 R. Wilcke (wilcke@esrf.fr) initialize global variable COR_FILE to NULL. Update 18/06/2001 R. Wilcke (wilcke@esrf.fr) read_esrf_file(): remove reading of BYTEORDER header keyword and the code to do forced byteswapping; analyse_args(): remove code for setting the global variable SRC_SWAP for forced byteswapping; remove global variable SRC_SWAP. Update 12/06/2001 R. Wilcke (wilcke@esrf.fr) change variable name "DUMMY" to "Dummy" to avoid name conflict with macro DUMMY(). Update 14/05/2001 R. Wilcke (wilcke@esrf.fr) save_esrf_file(): completely rewritten to use the "ESRF Data Format" access routines of P. Boesecke; put_buffer(): replace SHM_FLOAT by MFloat in the call to save_esrf_file(); remove struct "esrf_id" (no longer needed). Update 11/05/2001 R. Wilcke (wilcke@esrf.fr) remove gethead() routine - no longer needed. Update 10/05/2001 R. Wilcke (wilcke@esrf.fr) read_esrf_file(): completely rewritten to use the "ESRF Data Format" access routines of P. Boesecke; get_buffer(): replace SHM_FLOAT by MFloat in the call to read_esrf_file(); get_buffer(): do no longer allocate a buffer for the image (this is done in read_esrf_file()); get_buffer(): test if the shared memory segment has changed, and allocate a new data buffer only if it has. Update 25/04/2001 R. Wilcke (wilcke@esrf.fr) analyse_args(): correct comments for "flat_distortion" parameter; Update 19/04/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): allow shared memory segments of type "unsigned short" for input image and background, copy them to an allocated data buffer of type "float"; clean_buffer(): when detaching from a shared memory segment, free the corresponding allocated buffer if it exists. Update 14/03/2001 R. Wilcke (wilcke@esrf.fr) get value for Dummy from data header, if possible. Update 13/02/2001 R. Wilcke (wilcke@esrf.fr) clean up global variables: remove C_XSIZE, C_YSIZE; added global variable Dummy. Update 02/02/2001 R. Wilcke (wilcke@esrf.fr) get_buffer(): change code to return a buffer of type "float" except for a "header" buffer; put_buffer(): change type of output buffer to "SHM_FLOAT". */ #include "spd.h" #include static int raw_cmpr = UnCompressed; int azim_pass = 1,headpass = 0; int verbose = 1, inptbusy = 0; /* * All elements of current_shm and current_shm_data * are initialized to NULL (C language default). */ static SHM_HEADER* current_shm[MAXTYP]; static void* current_shm_data[MAXTYP]; void help_arg(void); int scanhead(int,struct data_head *); int get_filnam(char **,char *,char *,int); int fprint_first_el(FILE *,const char *,int *,int *); int fprint_first_el(FILE *out,const char *header_key,int *pErrorValue, int *pstatus) { const char *key,*value; edf_first_header_element(header_key,&key,&value,pErrorValue,pstatus); if(*pstatus || key == NULL) { printf(" \'%s\' : no elements\n",header_key); return(-1); } else printf(" \'%s\' : \'%s\' = \'%s\'\n",header_key,key,value); return(0); } /*============================================================================== * This routine handles the printing of user-defined messages. * * It works by being called from the macros "prmsg" or "__prmsg" (see * corresponding description). These macros call this routine twice: * - first with four arguments, of which the first is == NULL. The remaining * three contain the message type, the line number and the file name; * - then with a variable number of arguments. The first (which must not be * NULL) contains the format string, the remaining ones the parameters to * print. * * Messages have one of the types DMSG, MSG, WARNING, ERROR or FATAL. * * For each of the types, the additional flag PRERR can be set. If it is, then * the output stream for the message is "stderr", else "stdout". * * Depending on the message type and the value of the user-defined "verbose" * global variable, the user message may or may not be printed: * - if verbose == -1, return without any action; * - if verbose == 0, print only the message with types MSG, ERROR or FATAL; * - if verbose == 1, print all messages except those of type DMSG; * - if verbose == 2, print all messages. * * If the message type is ERROR or FATAL, also print the current line number and * file name (as defined by the C preprocessor macros __LINE__ and __FILE__). If * the system error variable "errno" is set, print the corresponding system * error message as well. * * If the message type is FATAL, the program will then be terminated by exit(1). * Note that this will not happen if verbose == -1! * * This routine uses a variable length argument list. This is handled * differently by old C compilers than by ANSI standard C compilers (STDC). * For details, see the "varargs" and "stdargs" manual pages. * * Input : va_alist: variable argument list * Output: none * Return: none */ #if defined(__STDC__) void _prmsg(char *format,...) { #else void _prmsg(va_alist) va_dcl { char *format; #endif /* __STDC__ */ char *errmsg = NULL; va_list args; static int type; static int line; static char file[256]; static char *typmsg[] = {"\0","WARNING: ","\nERROR: ","\nFATAL: ","\0"}; FILE *outstr; /* * Get the format argument. For "stdarg" argument handling, this is * explicitly handed over in the argument list. For "varargs" argument * handling, it is the first argument of the variable length argument list. */ #if defined(__STDC__) va_start(args,format); #else va_start(args); format = va_arg(args,char*); #endif /* __STDC__ */ /* * If the format argument is == NULL, only get the message type, the current * file name and the current line number (as defined by the C preprocessor * macros __LINE__ and __FILE__). * * If it is not NULL, it contains the format string for the printing. */ if(format == NULL) { type = va_arg(args,int); strcpy(file,va_arg(args,char*)); line = va_arg(args,int); va_end(args); return; } /* * Leave this routine without printing in the following cases: * - verbose == -1 * - verbose == 0 and type is neither MSG nor FATAL nor ERROR * - verbose == 1 and type is DMSG */ if((verbose == -1) || (verbose != 1 && verbose != 2 && type == WARNING) || (verbose != 2 && type == DMSG)) { va_end(args); return; } /* * Determine the output stream for the printing of the message. * * If the flag PRERR is set in "type", print to "stderr", else to "stdout". */ if(type & PRERR) { outstr = stderr; type &= ~PRERR; } else outstr = stdout; /* * Print the message to the requested output. * * The format string obtained earlier and the rest of the variable argument * list is given to a vfprintf() call for printing. * * For message type WARNING, ERROR and FATAL, print the type of the message * before the message text. * * If the message type is ERROR or FATAL, also print after the message text * the current line number and file name (as defined by the C preprocessor * macros __LINE__ and * __FILE__). If the system error variable "errno" is * set, print the corresponding system error message as well. * * If the message type is FATAL, terminate the program with exit(1). */ fprintf(outstr,"%s",*(typmsg + type)); vfprintf(outstr,format,args); if(type == ERROR || type == FATAL) { if(errno != 0) errmsg = strerror(errno); fprintf(outstr,"%s (in file %s line %d)\n",errmsg ? errmsg : " ",file,line); } va_end(args); if(type == FATAL) { fprintf(outstr,"Program terminated\n"); exit(1); } } const char * shm_data_type_string ( int shm_type ) { const char * data_type_string=""; switch ( shm_type ) { case SHM_DOUBLE: data_type_string="double"; break; case SHM_FLOAT: data_type_string="float"; break; case SHM_LONG: data_type_string="long"; break; case SHM_ULONG: data_type_string="unsigned long"; break; case SHM_SHORT: data_type_string="short"; break; case SHM_USHORT: data_type_string="unsigned short"; break; case SHM_CHAR: data_type_string="char"; break; case SHM_UCHAR: data_type_string="unsigned char"; break; case SHM_STRING: data_type_string="string"; break; default: data_type_string="unknown"; break; } return( data_type_string ); } #ifndef NO_SHARED_MEMORY /*============================================================================== * Gets the header from the shared memory segment identified by the input * parameter "id". * * If the input flag "delete" is set, the shared memory segment is removed * afterwards. * * Note that this shared memory header is "spec" specific. It is not part of * the standard shared memory operations. * * Input : id: shared memory identifier * delete: if true, remove the shared memory segment * Output: none * Return: pointer to the "spec" shared memory header */ SHM_HEADER *getShmPtr(int id, int delete) { SHM_HEADER *shm; struct shmid_ds info; /* * shmat() attaches the shared memory segment associated with the identifier * "id" to the data segment of the calling process. * * Last parameter of shmat must be SHM_RDONLY if read only access is desired, * otherwise it is read / write (with 0 it is read / write). */ /* shmat is casted to a void as it is a char * on some machines. Casting it to shm_header would not feel quite right as it only starts with a shm_header */ if((shm = (void *)shmat(id,(char *)0,0)) == (void *) -1) { prmsg(ERROR,("Could not attach shared mem (id %d)\n",id)); return((SHM_HEADER *)NULL); } if(shm->head.head.magic != SHM_MAGIC) { prmsg(ERROR,("Shared mem (id %d) is not a spec shared mem\n",id)); shmdt((void *)shm); return((SHM_HEADER *)NULL); } if(!delete) return(shm); /* * Calling shmctl() with the command IPC_STAT places the current value of * each member of the data structure associated with "id" into the structure * pointed to by "info". * * The element "info.shm_nattch" contains the number of current attaches to * the shared memory segment. */ shmctl(id,IPC_STAT,&info); if(info.shm_nattch == 1) { /* * shmdt() detaches the shared memory segment located at the address * specified by "shm" from the calling process' data segment. */ shmdt((void *)shm); /* * Calling shmctl() with the command IPC_STAT removes the memory identifier * specified by "id" from the system and destroys the shared memory and data * structure associated with it. */ if(!shmctl(id,IPC_RMID,&info)) { prmsg(DMSG,("Shared mem (id %d) deleted - nobody attached \n",id)); } return((SHM_HEADER *)NULL); } return(shm); } /* getShmPtr */ /*============================================================================== * This routine returns the pointer to the data of the shared memory * starting at shm_header depending on the shared memory version. * * If shm_version is larger than 3 the new header structure * shm_header is used, otherwise the old structure shm_oheader * Only if shm_version is 0 the actual version is read from the header, * otherwise no memory access is done. * * data pointer corresponding to version is returned. * Depending on shm_version the pointer to the start of the shared memory * data section is * returned: * version 0 read version from header * version <=3 shm_oheader * version >3 shm_header * * Data is defined as void * data in spec_shm.h. Apparently 'void * data' * is the start of the data section and not a pointer to the data. A better * specification would be 'void data'. But C does not allow it. * * Attention: For shm_header!=NULL and shm_version==0 the shared memory * must be attached! */ void *getShmDataPtr( SHM_HEADER* shm, int shm_version ) { void * shm_data_ptr = NULL; int shm_type = -1; // undefined if (shm) { if (shm_version==0) { shm_version = shm->head.head.version; shm_type = shm->head.head.type; } if (shm_version>3) { shm_data_ptr = (void *) &(((struct shm_header*) shm)->data); } else { shm_data_ptr = (void *) &(((struct shm_oheader*) shm)->data); } prmsg(DMSG,("Version of shared %s memory at %p is %d - data starts at %p\n", shm_data_type_string(shm_type), (void *)shm, shm_version, shm_data_ptr)); } return( shm_data_ptr ); } // getShmDataPtr u32_t getShmUTime( SHM_HEADER* shm ) { return( shm->head.head.utime ); } /* getShmUTime */ u32_t incShmUTime( SHM_HEADER* shm ) { return( shm->head.head.utime++ ); } /* incShmUTime */ u32_t getShmRows( SHM_HEADER* shm ) { return( shm->head.head.rows ); } /* getShmRows */ u32_t getShmCols( SHM_HEADER* shm ) { return( shm->head.head.cols ); } /* getShmCols */ u32_t getShmType( SHM_HEADER* shm ) { return( shm->head.head.type ); } /* getShmType */ #else /* ifndef NO_SHARED_MEMORY */ SHM_HEADER *getShmPtr(int id, int delete) { return ( (SHM_HEADER *) NULL ); } /* getShmPtr */ void *getShmDataPtr( SHM_HEADER* shm, int shm_version ) { return ( NULL ); } /* getShmDataPtr */ u32_t getShmUTime( SHM_HEADER* shm ) { return ( (u32_t) 0 ); } /* getShmUTime */ u32_t incShmUTime( SHM_HEADER* shm ) { return( (u32_t) 1 ); } /* incShmUTime */ u32_t getShmRows( SHM_HEADER* shm ) { return ( (u32_t) 0 ); } /* getShmRows */ u32_t getShmCols( SHM_HEADER* shm ) { return ( (u32_t) 0 ); } /* getShmCols */ u32_t getShmType( SHM_HEADER* shm ) { return ( (u32_t) -1 ); } /* getShmType */ int shmdt(const void *shmaddr) { return(-1); } /* shmdt */ #endif /* ifndef NO_SHARED_MEMORY */ /*============================================================================== * If SPEC_PIPE is defined, then this package can be called from a different * program using the call user_code(). * * If SPEC_PIPE is not defined, then this package will be a stand-alone program * with its own main(). */ #if SPEC_PIPE int __main() { /* This is a trick to get cc working if data_pipe has been compiled with gcc. __main seems to be called before main . */ return(0); } int user_code(int argc,char *argv[]) { unsigned long status; errno = 0; status = (unsigned long)analyse_args(argc,argv,"corimg_corr"); prmsg(DMSG,("Image processing returned status %#x\n",status)); set_return_value((float)status); return(status); } #else /*============================================================================== * Function "main" for the SPD offline version. * * The routine hands the command line arguments (without the program name) to * the routine analyse_args() and returns an exit code of success or failure to * the user depending on the return value of analyse_args(). * * Input : argc: number of the command line arguments (including program name) * argv: string array with the program name and the command line * arguments * exit code: EXIT_SUCCESS (== 0) if analyse_args() returns no error * EXIT_FAILURE (!= 0) else */ #if MAKE_FUNCTION # define MAIN main_spd #else # define MAIN main #endif /*============================================================================== * get the time to do some simple benchmarking * ============================================================================= */ double get_time() { struct timeval tv; gettimeofday(&tv,(void *)0); return (double) tv.tv_sec+tv.tv_usec*1e-6; } int MAIN(int argc,char *argv[]) { if(argc >=2 ){ if(!strcasecmp( argv[1],"--server")){ int my_argc=0; // something that looks like argc char *my_argv[256]; // something that looks like argv char *svprt; // pointer char *s; // pointer char buf[2048]; // buffer for input command int x=0; // index unsigned long status; // return status of SPD double start; // start & stop time static const char delim [] =" \t\n"; // delimiters of strings my_argv[0]=" "; // when we are in server mode, use unbuffered output stdout & stderr setvbuf(stdout, NULL, _IONBF, 0); setvbuf(stderr, NULL, _IONBF, 0); prmsg(MSG,("Server Mode\n")); while(strcasecmp(my_argv[0],"--exit")!=0) { fgets(buf,2048, stdin); //prmsg(MSG,"I got: %s\n",buf); s = strlib_tok_r(buf,delim,&svprt); my_argc = 0; while(s!=0) { my_argv[my_argc++] = s; s = strlib_tok_r(NULL,delim,&svprt); } my_argv[my_argc] = 0; for(x=0;x<=my_argc;++x) { if(my_argv[x] != 0) printf("argv[%d] = %s\n",x,my_argv[x]); //else // printf ("argv[%d] = NULL\n",x); } start = get_time(); status = (unsigned long)analyse_args(my_argc,my_argv,"SPD Server Mode"); prmsg(MSG,("Image processing took %.3f s returned status %#x\n", (get_time()-start),status)); } exit(EXIT_SUCCESS); } } if(analyse_args(argc - 1,argv + 1,argv[0]) < 0) exit(EXIT_FAILURE); exit(EXIT_SUCCESS); } #endif /* SPEC_PIPE */ /*============================================================================== * Returns the value of the "input busy flag": * 1 if input data are just being read by the program * 0 if not * * Input : none * Output: none * Return: value of the "input busy flag" */ int getstate(void) { return(inptbusy); } /*============================================================================== * Update the values of user_head with command header values * * Input : struct data_head *user_head header to be updated * Return: 0 no errors */ int upd_headvalcmd( struct data_head *user_head ) { struct data_head cmd_head; get_headval(&cmd_head,CMDTYP); /* * Set the header values defined on the command line in user_head */ if(cmd_head.init != 0) { if(cmd_head.init & FL_OFFS1) { user_head->Offset_1 = cmd_head.Offset_1; user_head->init |= FL_OFFS1; } if(cmd_head.init & FL_OFFS2) { user_head->Offset_2 = cmd_head.Offset_2; user_head->init |= FL_OFFS2; } if(cmd_head.init & FL_BSIZ1) { user_head->BSize_1 = cmd_head.BSize_1; user_head->init |= FL_BSIZ1; } if(cmd_head.init & FL_BSIZ2) { user_head->BSize_2 = cmd_head.BSize_2; user_head->init |= FL_BSIZ2; } if(cmd_head.init & FL_CENT1) { user_head->Center_1 = cmd_head.Center_1; user_head->init |= FL_CENT1; } if(cmd_head.init & FL_CENT2) { user_head->Center_2 = cmd_head.Center_2; user_head->init |= FL_CENT2; } if(cmd_head.init & FL_INTE0) { strcpy(user_head->Intens_0,cmd_head.Intens_0); user_head->init |= FL_INTE0; } if(cmd_head.init & FL_INTE1) { strcpy(user_head->Intens_1,cmd_head.Intens_1); user_head->init |= FL_INTE1; } if(cmd_head.init & FL_PSIZ1) { user_head->PSize_1 = cmd_head.PSize_1; user_head->init |= FL_PSIZ1; } if(cmd_head.init & FL_PSIZ2) { user_head->PSize_2 = cmd_head.PSize_2; user_head->init |= FL_PSIZ2; } if(cmd_head.init & FL_SAMDS) { user_head->SamplDis = cmd_head.SamplDis; user_head->init |= FL_SAMDS; } if(cmd_head.init & FL_ORIEN) { user_head->Orientat = cmd_head.Orientat; user_head->init |= FL_ORIEN; } if(cmd_head.init & FL_TITLE) { strcpy(user_head->Title,cmd_head.Title); user_head->init |= FL_TITLE; } if(cmd_head.init & FL_WAVLN) { user_head->WaveLeng = cmd_head.WaveLeng; user_head->init |= FL_WAVLN; } if(cmd_head.init & FL_PRO) { strcpy(user_head->ProjTyp,cmd_head.ProjTyp); user_head->init |= FL_PRO; } if(cmd_head.init & FL_ROT1) { user_head->DetRot_1 = cmd_head.DetRot_1; user_head->init |= FL_ROT1; } if(cmd_head.init & FL_ROT2) { user_head->DetRot_2 = cmd_head.DetRot_2; user_head->init |= FL_ROT2; } if(cmd_head.init & FL_ROT3) { user_head->DetRot_3 = cmd_head.DetRot_3; user_head->init |= FL_ROT3; } /* * Set pre-rotation parameters */ if(cmd_head.init & FL_PRECEN1) { user_head->PreCenter_1 = cmd_head.PreCenter_1; user_head->init |= FL_PRECEN1; } if(cmd_head.init & FL_PRECEN2) { user_head->PreCenter_2 = cmd_head.PreCenter_2; user_head->init |= FL_PRECEN2; } if(cmd_head.init & FL_PREDIS) { user_head->PreSamplDis = cmd_head.PreSamplDis; user_head->init |= FL_PREDIS; } if(cmd_head.init & FL_PREROT1) { user_head->PreDetRot_1 = cmd_head.PreDetRot_1; user_head->init |= FL_PREROT1; } if(cmd_head.init & FL_PREROT2) { user_head->PreDetRot_2 = cmd_head.PreDetRot_2; user_head->init |= FL_PREROT2; } if(cmd_head.init & FL_PREROT3) { user_head->PreDetRot_3 = cmd_head.PreDetRot_3; user_head->init |= FL_PREROT3; } } return(0); } /*============================================================================== * Obtains the header keyword values from the EDF header (input file or * temporary online header). * * Initialize a select set of the header value if they are not set by the input * data. * * For "x-distortion" and "y-distortion" data, get the "displaced" header values * (if any). * * The prerotation parameters are only read for source and dark files. * In all headers the default prerotations are 0. * * On return, the "init" member of the structure contains the "OR"ed flags of * all the keywords found (or initialized). * * Input : type: type of data buffer for which the header is to be obtained (see * routine get_buffer() for more information) * Output: user_head: structure with the values of the header keywords * Return: -1 if error * 0 else */ int scanhead(int type,struct data_head *user_head) { static char dspkey[100] = "Displaced"; const char *val; int i,ish,status,err; struct data_head cmd_head; int retval=0; user_head->init = 0; user_head->Dspinit = 0; unsigned long paramsneeded, paramsgiven; /* * Search the header for values corresponding to the following keywords: * - RasterOrientation * - Dummy * - DDummy * - Offset_1 * - Offset_2 * - PSize_1 * - PSize_2 * - Intensity0 * - Intensity1 * - Center_1 * - Center_2 * - SampleDistance * - WaveLength * - Title * - Time * - ExposureTime * - BSize_1 * - BSize_2 * - Dim_1 * - Dim_2 * - ProjectionType * - DetectorRotation_1 * - DetectorRotation_2 * - DetectorRotation_3 * * The prerotation parameters are only updated in the source image header * and the spec header * * - PreDetectorRotation_1 * - PreDetectorRotation_2 * - PreDetectorRotation_3 * - PreCenter_1 * - PreCenter_2 * - PreSampleDistance * * If the keywords are found and the values are valid, then they set the * corresponding values in the global variables. If not, then the previous * values of the global variables are kept. This is not an error condition. */ for(i = 0, ish = 1; i < maxhdkey; i++, ish = 1 << i) { if(edf_search_header_element(*(typestr + type),*(headkey + i),&val,&err, &status) && status == status_success) { switch(ish) { case FL_ORIEN: user_head->Orientat = num_str2long(val,NULL,&err); user_head->init |= ish; break; case FL_DUMMY: user_head->Dummy = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_DDUMM: user_head->DDummy = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_OFFS1: user_head->Offset_1 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_OFFS2: user_head->Offset_2 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_PSIZ1: user_head->PSize_1 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_PSIZ2: user_head->PSize_2 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_INTE0: strcpy(user_head->Intens_0,val); user_head->init |= ish; break; case FL_INTE1: strcpy(user_head->Intens_1,val); user_head->init |= ish; break; case FL_CENT1: user_head->Center_1 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_CENT2: user_head->Center_2 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_SAMDS: user_head->SamplDis = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_WAVLN: user_head->WaveLeng = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_TITLE: strcpy(user_head->Title,val); user_head->init |= ish; break; case FL_TIME: strcpy(user_head->Time,val); user_head->init |= ish; break; case FL_EXTIM: strcpy(user_head->ExpTime,val); user_head->init |= ish; break; case FL_BSIZ1: user_head->BSize_1 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_BSIZ2: user_head->BSize_2 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_DIM1: user_head->Dim_1 = num_str2long(val,NULL,&err); user_head->init |= ish; break; case FL_DIM2: user_head->Dim_2 = num_str2long(val,NULL,&err); user_head->init |= ish; break; case FL_PRO: strcpy(user_head->ProjTyp,val); user_head->init |= ish; break; case FL_ROT1: user_head->DetRot_1 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_ROT2: user_head->DetRot_2 = num_str2double(val,NULL,&err); user_head->init |= ish; break; case FL_ROT3: user_head->DetRot_3 = num_str2double(val,NULL,&err); user_head->init |= ish; /* * Load prerotation parameters only for SCRTYP */ case FL_PRECEN1: if ( (type == SRCTYP) || (type == HD_TYP) ) { user_head->PreCenter_1 = num_str2double(val,NULL,&err); user_head->init |= ish; } break; case FL_PRECEN2: if ( (type == SRCTYP) || (type == HD_TYP) ) { user_head->PreCenter_2 = num_str2double(val,NULL,&err); user_head->init |= ish; } break; case FL_PREDIS: if ( (type == SRCTYP) || (type == HD_TYP) ) { user_head->PreSamplDis = num_str2double(val,NULL,&err); user_head->init |= ish; } break; case FL_PREROT1: if ( (type == SRCTYP) || (type == HD_TYP) ) { user_head->PreDetRot_1 = num_str2double(val,NULL,&err); user_head->init |= ish; } break; case FL_PREROT2: if ( (type == SRCTYP) || (type == HD_TYP) ) { user_head->PreDetRot_2 = num_str2double(val,NULL,&err); user_head->init |= ish; } break; case FL_PREROT3: if ( (type == SRCTYP) || (type == HD_TYP) ) { user_head->PreDetRot_3 = num_str2double(val,NULL,&err); user_head->init |= ish; } break; } } } prmsg(DMSG,("Header flags set in %s data: 0x%x\n",*(typestr + type), user_head->init)); /* * Set the header values defined on the command line for the source or dark * image, if any. */ if(type == SRCTYP || type == DRKTYP) upd_headvalcmd( user_head ); /* * For the following header elements, set default values if they are not set * by the input data or command line arguments: * - RasterOrientation = 1 * - Dummy = 0. * - DDummy = DDSET(Dummy) * - Offset_1 = 0. * - Offset_2 = 0. * - Intensity1 = Intensity0 (only if Intensity0 is defined) * - Title = "\0" (i.e. an empty string) * - BSize_1 = 1. * - BSize_2 = 1. * - ProjectionType = "Saxs" * - DetectorRotation_1 = 0. * - DetectorRotation_2 = 0. * - DetectorRotation_3 = 0. */ if(!(user_head->init & FL_DUMMY)) { user_head->init |= FL_DUMMY; user_head->Dummy = 0.; } if(!(user_head->init & FL_DDUMM)) { user_head->init |= FL_DDUMM; user_head->DDummy = DDSET(user_head->Dummy); } if(!(user_head->init & FL_OFFS1)) { user_head->init |= FL_OFFS1; user_head->Offset_1 = 0.; } if(!(user_head->init & FL_OFFS2)) { user_head->init |= FL_OFFS2; user_head->Offset_2 = 0.; } if(!(user_head->init & FL_ORIEN)) { user_head->init |= FL_ORIEN; user_head->Orientat = 1; } if(!(user_head->init & FL_INTE1) && user_head->init & FL_INTE0) { user_head->init |= FL_INTE1; strcpy(user_head->Intens_1,user_head->Intens_0); } if(!(user_head->init & FL_TITLE)) *(user_head->Title) = '\0'; if(!(user_head->init & FL_BSIZ1)) { user_head->init |= FL_BSIZ1; user_head->BSize_1 = 1.; } if(!(user_head->init & FL_BSIZ2)) { user_head->init |= FL_BSIZ2; user_head->BSize_2 = 1.; } if(!(user_head->init & FL_PRO)) { user_head->init |= FL_PRO; strcpy(user_head->ProjTyp,"Saxs"); } if(!(user_head->init & FL_ROT1)) { user_head->init |= FL_ROT1; user_head->DetRot_1 = 0.; } if(!(user_head->init & FL_ROT2)) { user_head->init |= FL_ROT2; user_head->DetRot_2 = 0.; } if(!(user_head->init & FL_ROT3)) { user_head->init |= FL_ROT3; user_head->DetRot_3 = 0.; } /* * For all header types the default value for prerotations is zero. * - PreDetectorRotation_1 = 0. // FL_PREROT1 * - PreDetectorRotation_2 = 0. // FL_PREROT2 * - PreDetectorRotation_3 = 0. // FL_PREROT3 * * If PreCenter and PreSampleDistance are not set by the input * data or command line arguments default values are calculated: * - PreCenter_1 // FL_PRECEN1 * - PreCenter_2 and // FL_PRECEN2 * - PreSampleDistance // FL_PREDIS * * are calculated so that they agree with Center_1, Center_2 * and SampleDistance after prerotation */ if(!(user_head->init & FL_PREROT1)) { user_head->init |= FL_PREROT1; user_head->PreDetRot_1 = 0.; } if(!(user_head->init & FL_PREROT2)) { user_head->init |= FL_PREROT2; user_head->PreDetRot_2 = 0.; } if(!(user_head->init & FL_PREROT3)) { user_head->init |= FL_PREROT3; user_head->PreDetRot_3 = 0.; } if(type == SDXTYP || type == SDYTYP) { /* * For "x-distortion" and "y-distortion" data, get the "displaced" header * values (if any). */ for(i = 0; i < maxhdkey; i++) { strncpy(dspkey + 9,*(headkey + i),90); if(edf_search_header_element(*(typestr + type),dspkey,&val,&err, &status) && status == status_success) { user_head->Dspinit |= 1 << i; switch(i) { case 0: // FL_ORIEN user_head->DspOrientat = num_str2long(val,NULL,&err); break; case 1: // FL_DUMMY user_head->DspDummy = num_str2double(val,NULL,&err); break; case 2: // FL_DDUMM user_head->DspDDummy = num_str2double(val,NULL,&err); break; case 3: // FL_OFFS1 user_head->DspOffset_1 = num_str2double(val,NULL,&err); break; case 4: // FL_OFFS2 user_head->DspOffset_2 = num_str2double(val,NULL,&err); break; case 5: // FL_PSIZ1 user_head->DspPSize_1 = num_str2double(val,NULL,&err); break; case 6: // FL_PSIZ2 user_head->DspPSize_2 = num_str2double(val,NULL,&err); break; case 7: // FL_INTE0 strcpy(user_head->DspIntens_0,val); break; case 8: // FL_INTE1 strcpy(user_head->DspIntens_1,val); break; case 9: // FL_CENT1 user_head->DspCenter_1 = num_str2double(val,NULL,&err); break; case 10: // FL_CENT2 user_head->DspCenter_2 = num_str2double(val,NULL,&err); break; case 11: // FL_SAMDS user_head->DspSamplDis = num_str2double(val,NULL,&err); break; case 12: // FL_WAVLN user_head->DspWaveLeng = num_str2double(val,NULL,&err); break; case 13: // FL_TITLE strcpy(user_head->DspTitle,val); break; case 14: // FL_TIME strcpy(user_head->DspTime,val); break; case 15: // FL_EXTIM strcpy(user_head->DspExpTime,val); break; case 16: // FL_BSIZ1 user_head->DspBSize_1 = num_str2double(val,NULL,&err); break; case 17: // FL_BSIZ2 user_head->DspBSize_2 = num_str2double(val,NULL,&err); break; case 18: // FL_DIM1 user_head->DspDim_1 = num_str2long(val,NULL,&err); break; case 19: // FL_DIM2 user_head->DspDim_2 = num_str2long(val,NULL,&err); break; case 20: // FL_PRO strcpy(user_head->DspProjTyp,val); break; case 21: // FL_ROT1 user_head->DspDetRot_1 = num_str2double(val,NULL,&err); break; case 22: // FL_ROT2 user_head->DspDetRot_2 = num_str2double(val,NULL,&err); break; case 23: // FL_ROT3 user_head->DspDetRot_3 = num_str2double(val,NULL,&err); break; case 24: // FL_PRECEN1 user_head->DspPreCenter_1 = num_str2double(val,NULL,&err); break; case 25: // FL_PRECEN2 user_head->DspPreCenter_2 = num_str2double(val,NULL,&err); break; case 26: // FL_PREDIS user_head->DspPreSamplDis = num_str2double(val,NULL,&err); break; case 27: // FL_PREROT1 user_head->DspPreDetRot_1 = num_str2double(val,NULL,&err); break; case 28: // FL_PREROT2 user_head->DspPreDetRot_2 = num_str2double(val,NULL,&err); break; case 29: // FL_PREROT3 user_head->DspPreDetRot_3 = num_str2double(val,NULL,&err); break; } } } } /*if(type == SDXTYP || type == SDYTYP)*/ return(retval); } /* scanhead */ /*============================================================================== * Read a filename from a keyword in the source header. * * If the name of a file in the input arguments of "spd" has been specified in * the form * * filename=prefix[char_string]postfix * * (a character string value with a leading and trailing square bracket, * optionally preceded and/or followed by other character strings, e.g. * dark_file=[DarkFileName] * or dark_file=../datadark/[DarkFileName] * or dark_file=[DarkFileName]_len32 * or dark_file=../mydat/[DarkFileName].ext * ) * * then the "char_string" part of this filename is to be read from the header of * the source image in the keyword "char_string". * * Test if that is the case. If so get the keyvalue and assemble the file name * from the "prefix" string, followed by the keyvalue and then the "postfix" * string. * * Example: * with dark_file=../mydat/[DarkFileName].ext * and the definition in the input file header DarkFileName=gd10dark * the resulting filename is ../mydat/gd10dark.ext * * Return with error if the file name contains the "[char_string]" construct but * the corresponding keyword cannot be found in the source header. * * If the file name does not contain the "[char_string]" construct (including * the cases of only a opening '[", only a closing "]" or "]" preceding '["), * or if the input is from shared memory (file is a NULL pointer), then the * routine returns without action. This is not an error condition. * * Input : file : pointer to input file name string (NULL for shared memory) * inbuf : character string given as file name argument to spd * outbuf: buffer (possibly empty) for the new file name * Note: this buffer must be allocated by the calling program * type : type of file to be read (source, flood field, ...) * Output: file : pointer to filename constructed from keyword, or unchanged * if no keyword in input file name string * outbuf: character string with the file name from the input data file * Return: -1 if error * 0 else */ int get_filnam(char **file,char *inbuf,char *outbuf,int type) { const char *keyval; char *lpos,*rpos; char key[EdfMaxKeyLen + 1] = {'\0'};; int status,err; int iret = 0; lpos = strchr((const char *)inbuf,(int)'['); rpos = strrchr((const char *)inbuf,(int)']'); if(*file != NULL && lpos != NULL && rpos != NULL && lpos < rpos) { /* * Remove prefix, postfix and square brackets, use only "char_string" for * the keyword search. * If successful, concatenate the prefix, the obtained key value and the * postfix into the output buffer, this will be used as the new file name * buffer. Note that the original buffer with the value of the file name * input argument is not changed. */ strncat(key,lpos + 1,rpos - lpos - 1); if(edf_search_header_element(*(typestr + SRCTYP),key,&keyval,&err,&status) && status == status_success) { *outbuf = '\0'; strncat(outbuf,(const char *)inbuf,lpos - inbuf); strcat(outbuf,keyval); strcat(outbuf,(const char *)(rpos + 1)); *file = outbuf; } else { prmsg(ERROR,("%s file keyword \"%s\" not found in source header\n", *(typestr + type),key)); iret = -1; } } return(iret); } /* get_filnam */ /*============================================================================== * Returns only 0 if key is one of the following prerotation parameters: * - PreDetectorRotation_1 * - PreDetectorRotation_2 * - PreDetectorRotation_3 * - PreCenter_1 * - PreCenter_2 * - PreSampleDistance */ int is_not_prerotpar ( const char * key ) { static const char *prerotpar[] = {"PreDetectorRotation_1", "PreDetectorRotation_2", "PreDetectorRotation_3", "PreCenter_1", "PreCenter_2", "PreSampleDistance", (const char *) NULL }; int notfound=1; const char **ppar=prerotpar; for ( ppar = prerotpar; *ppar; ppar++ ) { if (!( notfound = strcmp( *ppar, key ) )) break; } return( notfound ); } /* is_not_prerotpar */ /*============================================================================== * Get a buffer for the type of data requested and, where applicable, fill it * with the appropriate data values. * * The following data types are possible: * - SRCTYP: source data (input image) * - CORTYP: corrected data (output image) * - DRKTYP: dark image data (the image for the dark image subtraction) * - FLOTYP: flood field data (the image for the flood field correction) * - HD_TYP: header data set from SPEC * - SBKTYP: scattering background data (the image for the scattering background * correction) * - SDXTYP: x-direction displacement values for spatial distortion correction * - SDYTYP: y-direction displacement values for spatial distortion correction * - SDMTYP: multiplication factors for spatial distortion correction * - AZITYP: azimuthal regrouped data (output image) * - AVETYP: azimuthal averaged data (output image) * - MSKTYP: mask image with pixels to ignore for azimuthal regrouping (input) * - CMDTYP: header structure with values filled by command line arguments * * The storage associated with the data in the buffer can be a file or a shared * memory segment. Identifiers for both are input to this routine. * * Not all combination of data type and data storage are possible, however. * * The data type CMDTYP is only filled from the command line and thus cannot be * used in a get_buffer() call. * * A shared memory segment can be a storage for all data types except SDXTYP, * SDYTYP and MSKTYP (i.e., spatial distortion displacement or azimuthal mask * data). The routine then normally returns a pointer to the location of the * shared memory as buffer pointer. If the data type is CORTYP, then this * shared memory serves as the place to put the corrected image data into. * * If the data type is one of the input types SRCTYP, DRKTYP, SBKTYP or FLOTYP, * the shared memory is always copied to a newly allocated internal buffer. This * makes the shared memory quickly available for refilling with new data by a * data acquisition process. The routine returns a pointer to this new buffer. * * Note that the correction routines need all input data to be of type "float". * If the shared memory contains its data in a different form, this routine can * convert the data under certain circumstances. * * For details, see below in the section "Input from shared memory segment". * * A file can only be a storage for the data types SRCTYP, DRKTYP, FLOTYP, * SBKTYP, SDXTYP, SDYTYP, SDMTYP and MSKTYP (i.e., source, dark image, * flood field, scattering background, spatial distortion or azimuthal mask * data). If this is the case, then a buffer will be allocated, and the data * values will be read from the file and stored in the buffer. * * If neither the "shared memory segment identifier" nor the "file name" are * defined in the input arguments, then a NULL buffer pointer will be returned, * as no data can be obtained. Exceptions to this are the output data types * CORTYP, AZITYP, AVETYP, SDXTYP, SDYTYP and SDMTYP, as for these no input * data are required. A buffer will be allocated and its pointer returned * in these cases. The buffer values must be initialized separately. * * The input arguments "shared memory segment identifier" and "file name" * should not both be defined in a call to this routine. If they are, then the * shared memory segment identifier will be ignored, and processing will be as * if the file name only was defined. * * Note that if "type" is CORTYP, AZITYP, AVETYP or HD_TYP (corrected output * data, azimuthally regrouped output data, regrouped output data or online * header), "file" must be a NULL pointer, i.e. there cannot be a file * associated with these data types. If a file name is given, the routine * returns an error. * * For output data types, the dimensions of the buffer must be given as input * arguments "rows" and "cols". For input data types, "rows" and "cols" are * determined from the dimensions of the input image. * * For the azimuthally averaged data type, the "rows" argument given in the * input argument is checked against the corresponding dimension of the shared * memory buffer. If there are less than 4 rows in the buffer, the routine * returns an error. If 8 rows are requested and there is not enough room for 8 * but enough for 4 (one averaged angle range only), the routine returns the * value 4 for "rows". * * The routine returns an error under any of the following conditions: * - the data type requested is not one of the possible ones; * - there is a file name specified for an output or a header buffer; * - memory allocation for the data buffer is required but fails; * - data needs to be read from a file, but there is an error in doing so; * - a shared memory segment is requested but cannot be attached or has the * wrong data type in it; * - the "cols" dimension of the azimuthal averaging buffer is not compatible * with the one given as input argument. * * It is not an error if neither the shared memory segment identifier nor the * file name are defined. * * Input : shm_id: shared memory segment identifier, or -1 if none defined * file: name of data file, or NULL if none defined * buffer_ptr: data buffer, or NULL if none available * rows: number of elements in the second dimension of the image * (this is the "slow-moving" index, i.e. the first index * in a two-dimensional C data buffer) * cols: number of elements in the first dimension of the image * (this is the "fast-moving" index, i.e. the second index * in a two-dimensional C data buffer) * type: type of data buffer to be obtained * Output: buffer_ptr: data buffer (may have been changed, allocated or freed) * rows: second dimension of the image (may have been changed) * cols: first dimension of the image (may have been changed) * Return: 1 if successful and the data buffer was updated (this includes * the case where the data buffer was set to NULL) * 0 if successful and the old data buffer is still valid * -1 else (error) */ int get_buffer(int shm_id,char *file,void **buffer_ptr,int *rows,int *cols, int type) { #define QUOTE(a) #a #define FMT1(a) "%" QUOTE(a) "[^\n]" #define FMT2(a) "%[^= ]%*[ =]%[" QUOTE(a) "^\n]" static char id[EdfMaxKeyLen + 1],val[EdfMaxValLen + 1]; /* * By C language default, all elements of the following arrays are initialized * to: * - NULL for old_file * - 0 for old_where, last_mtime, last_utime * * old_where tells the type of the previous data storage: * no_stor (= 0) == none, * fil_stor (= 1) == file, * shm_stor (= 2) == shared memory. */ static char *old_file[MAXTYP]; static int old_where[MAXTYP]; static int last_mtime[MAXTYP]; static long last_utime[MAXTYP]; enum {no_stor,fil_stor,shm_stor}; void *pnewbuf; char *hdptr,*hdend; unsigned char *uch_buf; unsigned short *ush_buf; unsigned int *uin_buf; int *int_buf; int err,status,imgsiz,headrows,headcols; int file_changed = 0,shm_changed = 0; long hdtype; float *float_ptr,*flt_buf; double bu1,bu2,bs1,bs2; struct data_head src_head,user_head; SHM_HEADER *shm_ptr; struct stat stat_buf; /* * Check whether the type of data requested is a valid one. */ if(type <= 0 || type >= MAXTYP || type == CMDTYP || type == TMPTYP) { errno = 0; prmsg(FATAL,("invalid data type %d for get_buffer().\n",type)); } /* * Output or header data must not have a file associated with them. */ if(file && (type == CORTYP || type == AZITYP || type == AVETYP || type == HD_TYP)) { errno = 0; prmsg(ERROR,("no file permitted in get_buffer() for data type %s.\n", *(typestr + type))); return(-1); } /* * If the data image to be obtained is already in buffer but has a different * binning, dimension or offset than the source image, a possible cause is * that these parameters have changed in the source image. The data image then * needs to be re-processed accordingly. * * To enable this, force a re-acquisition of the data image. * * For the source image, a re-acquisition is always forced. */ if(type != HD_TYP) { get_headval(&src_head,SRCTYP); if(type != SRCTYP) { unsigned short tstDim_1,tstDim_2; float tstOffset_1,tstOffset_2; if(type == SDXTYP || type == SDYTYP) { tstDim_1 = src_head.Dim_1 + 1; tstDim_2 = src_head.Dim_2 + 1; tstOffset_1 = src_head.Offset_1 - 0.5; tstOffset_2 = src_head.Offset_2 - 0.5; } else { tstDim_1 = src_head.Dim_1; tstDim_2 = src_head.Dim_2; tstOffset_1 = src_head.Offset_1; tstOffset_2 = src_head.Offset_2; } get_headval(&user_head,type); if(user_head.init != 0 && (user_head.BSize_1 != src_head.BSize_1 || user_head.BSize_2 != src_head.BSize_2 || user_head.Dim_1 != tstDim_1 || user_head.Dim_2 != tstDim_2 || user_head.Offset_1 != tstOffset_1 || user_head.Offset_2 != tstOffset_2)) old_where[type] = no_stor; } else old_where[SRCTYP] = no_stor; if(old_where[type] == no_stor && current_shm[type] != NULL) { shmdt((void *)current_shm[type]); } } /* * If there is a file name in the input "file" argument, find out if the file * has changed since the last access. * * It is defined as having changed if any of the following is true: * - the previous data storage was not a file; * - the current file name is different from the previous one; * - the current file name is identical to the previous one, but the * modification time has changed. * * If the current file cannot be accessed, return with error. * * If there is no file name in the input "file" argument (i.e. NULL pointer), * the file is defined as not having changed. */ if(file) { if(stat(file,&stat_buf) != 0) goto get_buffer_error; if(old_where[type] != fil_stor || strcmp(file,old_file[type]) != 0 || (int)stat_buf.st_mtime != last_mtime[type]) { file_changed = 1; last_mtime[type] = (int)stat_buf.st_mtime; } } /* * Free the old buffers if the file has changed (then new buffers need to be * allocated) or if there was a file before but there is none now (then the * buffers are no longer needed). */ if(file_changed || (file == NULL && old_where[type] == fil_stor)) { clean_buffer(buffer_ptr,type,1); if(old_file[type] != NULL) { pfree(old_file[type]); old_file[type] = NULL; } } /* * For input data types, remove the data buffer if there is neither a file nor * a shared memory segment where the data can be obtained from. The data * buffer is then obviously not needed. * * For output data types, it is normal not to have input data. The buffer that * is obtained here is needed to store the output data. Therefore, if there is * no shared memory segment for them, a buffer of the appropriate size must be * allocated if it does not yet exist. * * Output data types are "corrected", "azimuth" and "averaged". The types * "x-distortion" and "y-distortion" can either be input or output data. * * In all cases, create or reset the internal header and history buffers and * return without error afterwards. This is considered a state where the input * buffer has changed (return code 1). * * Note that in order for this code to work properly, it is assumed that the * data types "corrected", "azimuth" and "averaged" will always have a NULL * file pointer associated with them. */ if(file == NULL && shm_id == -1) { edf_new_header(*(typestr + type)); edf_history_new(*(typestr + type)); /* * Output data types. */ if(type == CORTYP || type == AZITYP || type == AVETYP || type == SDXTYP || type == SDYTYP || type == SDMTYP) { /* * Better defaults could be calculated (these are sometimes useful values) * It would be more adequate to use the parameters of CORTYP. */ if (type == AZITYP) { if (*cols <=0 ) *cols = (int) sqrt(src_head.Dim_1*src_head.Dim_1+src_head.Dim_2*src_head.Dim_2); if (*rows <=0 ) *rows = 360; } if (type == SDXTYP || type == SDYTYP) { /* * If available, get default values from SRCTYP */ if (*cols <=0 ) *cols = src_head.Dim_1+1; if (*rows <=0 ) *rows = src_head.Dim_2+1; if (src_head.init & FL_OFFS1) { user_head.Offset_1 = src_head.Offset_1-0.5; user_head.init |= FL_OFFS1; } if (src_head.init & FL_OFFS2) { user_head.Offset_2 = src_head.Offset_2-0.5; user_head.init |= FL_OFFS2; } if (src_head.init & FL_BSIZ1) { user_head.BSize_1 = src_head.BSize_1; user_head.init |= FL_BSIZ1; } if (src_head.init & FL_BSIZ2) { user_head.BSize_2 = src_head.BSize_2; user_head.init |= FL_BSIZ2; } if (src_head.init & FL_PSIZ1) { user_head.PSize_1 = src_head.PSize_1; user_head.init |= FL_PSIZ1; } if (src_head.init & FL_PSIZ2) { user_head.PSize_2 = src_head.PSize_2; user_head.init |= FL_PSIZ2; } } if (type == SDMTYP) { /* * If available, get default values from SRCTYP */ if (*cols <=0 ) *cols = src_head.Dim_1; if (*rows <=0 ) *rows = src_head.Dim_2; if (src_head.init & FL_OFFS1) { user_head.Offset_1 = src_head.Offset_1; user_head.init |= FL_OFFS1; } if (src_head.init & FL_OFFS2) { user_head.Offset_2 = src_head.Offset_2; user_head.init |= FL_OFFS2; } if (src_head.init & FL_BSIZ1) { user_head.BSize_1 = src_head.BSize_1; user_head.init |= FL_BSIZ1; } if (src_head.init & FL_BSIZ2) { user_head.BSize_2 = src_head.BSize_2; user_head.init |= FL_BSIZ2; } } if(*cols <= 0 || *rows <= 0) { errno = 0; prmsg(ERROR,("illegal dimensions [%d,%d] for %s buffer\n",*cols,*rows, *(typestr + type))); goto get_buffer_error; } if(*buffer_ptr != NULL) pfree(*buffer_ptr); if((*buffer_ptr = (void *)pmalloc(*cols * *rows * sizeof(float))) == NULL) goto get_buffer_error; user_head.Dim_1 = *cols; user_head.Dim_2 = *rows; user_head.init |= FL_DIM1 | FL_DIM2; set_headval(user_head,type); /* * Input data types. */ } else if(*buffer_ptr != NULL) clean_buffer(buffer_ptr,type,1); old_where[type] = no_stor; return(1); } /* * Input from file: * * If the file has changed or if there is a file but the buffer pointer is * NULL, create or reset the internal header and history buffers, read the * data into a buffer, fill in the old file name and set the access type to * "fil_stor" for "file access". The allocation of the data buffer is done in * read_esrf_file(). */ if(file_changed || file != NULL && *buffer_ptr == NULL) { edf_new_header(*(typestr + type)); edf_history_new(*(typestr + type)); prmsg(DMSG,("Reading %s file %s\n",*(typestr + type),file)); if(read_esrf_file(file,buffer_ptr,rows,cols,type,MFloat,&err)) { errno = 0; prmsg(ERROR,("error reading %s file %s\n",*(typestr + type),file)); goto get_buffer_error; } old_file[type] = pmalloc(strlen(file) + 1); strcpy(old_file[type],file); old_where[type] = fil_stor; } /* * Input from shared memory segment: * * If the data storage is not a file but a shared memory segment, attach the * shared memory segment to the process' data segment. Its data buffer can * then be accessed through the address stored in "buffer_ptr". * * If the shared memory segment cannot be attached, return with error. * * If the shared memory segment can be attached, test whether it has changed * since the last access. * * It is defined to have changed if any of the following is true: * - the previous data storage was not a shared memory segment; * - the current shared memory address is different from the previous one; * - the current shared memory address is identical to the previous one, but * the modification counter has changed. * * If the shared memory segment has not changed, then the old buffer still * contains valid data and need not be changed. * * If the shared memory segment has changed, a new data buffer needs to be * assigned. Test the data type of the shared memory segment: * - it must be "string" (SHM_STRING) for header data (type == HD_TYP); * - it must be "float" (SHM_FLOAT) for corrected (type == CORTYP), flood * field (FLOTYP), azimuthal (AZITYP) and averaged (AVETYP) data; * - for all other cases, it must be "unsigned character" (SHM_UCHAR), * "unsigned short" (SHM_USHORT), "unsigned / signed long" (SHM_ULONG / * SHM_LONG), or "float" (SHM_FLOAT). * * Note that in the above definitions, for SPEC "LONG" means 32 bit. * * If the shared memory segment contains an illegal data type, return with * error. * * Otherwise, update the shared memory address and modification counter and * reset the internal header and history buffers. */ if(file == NULL && shm_id != -1) { if((shm_ptr = (void *)getShmPtr(shm_id,0)) == NULL) { prmsg(ERROR,("%s shared memory id %d not found\n",*(typestr + type), shm_id)); goto get_buffer_error; } if(old_where[type] != shm_stor || current_shm[type] != shm_ptr || getShmUTime( shm_ptr) != last_utime[type]) { hdtype = getShmType(shm_ptr); if(((type == SRCTYP || type == DRKTYP || type == SBKTYP) && hdtype != SHM_UCHAR && hdtype != SHM_USHORT && hdtype != SHM_ULONG && hdtype != SHM_LONG && hdtype != SHM_FLOAT) || ((type == CORTYP || type == FLOTYP || type == AZITYP || type == AVETYP) && hdtype != SHM_FLOAT) || (type == HD_TYP && hdtype != SHM_STRING)) { errno = 0; prmsg(ERROR,("only %s supported for %s\n", (type == CORTYP || type == FLOTYP || type == AZITYP || type == AVETYP) ? "float" : ((type == HD_TYP) ? "string" : "unsigned char, unsigned short, unsigned/signed long, or float"), *(typestr + type))); last_utime[type] = 0; goto get_buffer_error; } shm_changed = 1; /* * Free the buffer pointer if it is not NULL and if it is not pointing * to the previous shared memory buffer. */ if(*buffer_ptr && current_shm[type] && current_shm_data[type]!=*buffer_ptr) { pfree(*buffer_ptr); *buffer_ptr = NULL; } current_shm[type] = shm_ptr; current_shm_data[type] = getShmDataPtr(shm_ptr,0); last_utime[type] = getShmUTime(shm_ptr); old_where[type] = shm_stor; edf_new_header(*(typestr + type)); edf_history_new(*(typestr + type)); /* * Use the "rows" and "cols" information that was provided in the shared * memory header * - for the azimuthal averaging (AVETYP) buffer: to check if the "rows" * of the buffer are at least what was requested by the input arguments * and if not, if at least 4 rows (one averaging angle) can be used; * - for the other data buffers: to set the "rows" and "cols" arguments; * - for header buffers: to set the number of header items and the length * of each item. */ if(type != HD_TYP) { if(type == AVETYP) { *cols = getShmCols(shm_ptr); if(*rows > getShmRows(shm_ptr)) { if(*rows == 8 && getShmRows(shm_ptr) >= 4) *rows = 4; else { errno = 0; prmsg(ERROR, ("wrong shared memory dimensions found for %s buffer\n", *(typestr + type))); goto get_buffer_error; } } } else { *rows = getShmRows(shm_ptr); *cols = getShmCols(shm_ptr); //++++++++ previous position of imgsiz = *cols * *rows; } imgsiz = *cols * *rows; /* * Put a default header in the header structure. It contains those * elements of the online header designated by the macro FL_IMAGE. * However, the header structure of the corrected image always contains * the same elements as the source image. * * For the source image, get the header structure here and make sure * that header elements Dim_1 and Dim_2 are defined. */ if(type != SRCTYP) { if(type == CORTYP) //original user_head = src_head; else { get_headval(&user_head,HD_TYP); user_head.init &= FL_IMAGE; } set_headval(user_head,type); } else { get_headval(&src_head,SRCTYP); src_head.Dim_1 = *cols; src_head.Dim_2 = *rows; src_head.init |= FL_DIM1 | FL_DIM2; set_headval(src_head,SRCTYP); } } else { headrows = getShmRows(shm_ptr); headcols = getShmCols(shm_ptr); /* * Write the header information from the online header buffer into an * internal EDF buffer. The online header buffer can have two different * formats: * * 1) each keyword / value pair is contained on a single line, separated * by the separator symbol "=" and possibly some blanks on either or * both sides of the separator; * * 2) each keyword / value pair is contained on two consecutive lines, * the first line containing the keyword and the second one the * value. In this case there is no separator. * * In both cases, there can be empty lines before or after the ones * containing the keyword / value information. */ /* shm_ptr is attached, getShmDataPtr can be used without problems */ hdptr = (char *) getShmDataPtr(shm_ptr,0); hdend = hdptr + headrows * headcols; for(; hdptr < hdend; hdptr += headcols) { if(*hdptr == '\0') continue; /* * If the first non-empty header line does not contain an "=" (equal * sign), then the header contains keywords and values on consecutive * lines, without any separating "=". */ if(strchr(hdptr,'=') == NULL) { if(sscanf(hdptr,"%[^\n]",id) != 1) continue; hdptr += headcols; /* * This is to have for the "sscanf()" format string a maximum field * width specified by the "EdfMaxValLen" macro. The line expands to * * if(sscanf(hdptr,"%EdfMaxValLen[^\n]",val) != 1) * * but with "EdfMaxValLen" replaced by the macro's value. */ if(sscanf(hdptr,FMT1(EdfMaxValLen),val) != 1) continue; /* * If the first non-empty header line does contain an "=" (equal * sign), then the header contains in each line the sequence * "keyword = value". * * Note that this way the possibility that the value itself might * contain an "=" is also covered, as the keyword does never contain * an "=" and the test for the non-existence of an "=" in the first * line (i.e., the keyword line) is therefore conclusive. */ } else { /* * This line expands to * * if(sscanf(hdptr,"%[^= ]%*[ =]%EdfMaxValLen[^\n]",id,val) != 2) * * similar to the FMT1() macro call above. */ if(sscanf(hdptr,FMT2(EdfMaxValLen),id,val) != 2) continue; } /* prmsg(DMSG,("Read header keyword %s, value = %s\n",id,val)); */ edf_add_header_element(*(typestr + type),id,val,&err,&status); if(status != status_success) { prmsg(ERROR,("error writing internal header buffer: %s\n", edf_report_data_error(err))); return(-1); } } } /* * If the image is an input (source), dark, scattering background or flood * field image, then allocate a new buffer to store the data in. The main * purpose of this is to have the shared memory segment available as soon * as possible to be filled with new data from a data acquisition process. * * Otherwise, the shared memory segment itself is used as the buffer. */ /* shm_ptr is attached, getShmDataPtr can be used without problems */ *buffer_ptr = getShmDataPtr(shm_ptr,0); if(type == SRCTYP || type == DRKTYP || type == SBKTYP || type == FLOTYP) { float_ptr = (float *)pmalloc(imgsiz * sizeof(float)); flt_buf = float_ptr + imgsiz - 1; switch(hdtype) { case SHM_UCHAR: uch_buf = (unsigned char *)*buffer_ptr + imgsiz - 1; for(; flt_buf >= float_ptr;) *flt_buf-- = *uch_buf--; break; case SHM_USHORT: ush_buf = (unsigned short *)*buffer_ptr + imgsiz - 1; for(; flt_buf >= float_ptr;) *flt_buf-- = *ush_buf--; break; case SHM_ULONG: uin_buf = (unsigned int *)*buffer_ptr + imgsiz - 1; for(; flt_buf >= float_ptr;) *flt_buf-- = *uin_buf--; break; case SHM_LONG: int_buf = (int *)*buffer_ptr + imgsiz - 1; for(; flt_buf >= float_ptr;) *flt_buf-- = *int_buf--; break; case SHM_FLOAT: memcpy(float_ptr,*buffer_ptr,imgsiz * sizeof(float)); } *buffer_ptr = float_ptr; } } } /* * Test if the image buffer needs to be mapped, i.e. if its geometry has * changed. Note: this test is not relevant for the online header buffer. * * For all image types except the source image, there must no longer be * undefined dimensions. If there are, return with error. * * For the source image, undefined dimensions mean that the image has already * been acquired before and therefore its dimensions have not been set anew * by the code above. Get the actual values from the corresponding header, * if they are defined. If not, return with error. */ if(type != HD_TYP && (*cols <= 0 || *rows <= 0)) { if(type == SRCTYP && src_head.init & FL_DIM1 && src_head.init & FL_DIM2) { *cols = src_head.Dim_1; *rows = src_head.Dim_2; } else { errno = 0; prmsg(ERROR,("no dimensions found for %s buffer\n",*(typestr + type))); goto get_buffer_error; } } /* * For input image types, test if they need to be mapped. */ if(type == DRKTYP || type == FLOTYP || type == SBKTYP || type == MSKTYP || (type == SDXTYP || type == SDYTYP) && file != NULL) { get_headval(&user_head,type); bu1 = user_head.BSize_1; bu2 = user_head.BSize_2; bs1 = src_head.BSize_1; bs2 = src_head.BSize_2; /* * If the binning, the dimensions and the offsets are the same as for the * source image, the image does not need to be mapped. * * Displacement files (type SDXTYP and SDYTYP) always need to be mapped as * they may contain "displaced" image parameters that need to be processed. * * Dark image files also need to be mapped when they have changed as the * linearity correction may have to be applied. * */ if(type == SDXTYP || type == SDYTYP || type == SDMTYP || bu1 != bs1 || bu2 != bs2 || type == DRKTYP && file_changed | shm_changed || user_head.Dim_1 != src_head.Dim_1 || user_head.Dim_2 != src_head.Dim_2 || user_head.Offset_1 != src_head.Offset_1 || user_head.Offset_2 != src_head.Offset_2) { /* * If source image is not fully contained in this image, return with * error. */ if(region_compare(type, user_head.Offset_1,user_head.BSize_1,(float)user_head.Dim_1, user_head.Offset_2,user_head.BSize_2,(float)user_head.Dim_2, src_head.Offset_1,src_head.BSize_1,(float)src_head.Dim_1, src_head.Offset_2,src_head.BSize_2,(float)src_head.Dim_2) == -1) { prmsg(MSG, ("%s does not cover full source region, correction not possible\n", *(typestr + type))); goto get_buffer_error; } if(map_imag(*buffer_ptr,&pnewbuf,bs1 / bu1,bs2 / bu2,type) < 0) goto get_buffer_error; else if(*buffer_ptr != pnewbuf) { if(type == DRKTYP) pfree(*buffer_ptr); else clean_buffer(buffer_ptr,type,1); *buffer_ptr = pnewbuf; get_headval(&user_head,type); *cols = user_head.Dim_1; *rows = user_head.Dim_2; } } } prmsg(DMSG,("get_buffer(shm,file,buff,rows,cols,type): %d, %s, %p, %d, %d, %s\n", shm_id, file ? file : "",*buffer_ptr,*rows,*cols,*(typestr + type))); return(file_changed | shm_changed); get_buffer_error: prmsg(ERROR,("error get_buffer(shm,file,buff,rows,cols,type): %d, %s, %p, %d, %d, %s\n", shm_id,file ? file : "",*buffer_ptr,*rows,*cols,*(typestr + type))); clean_buffer(buffer_ptr,type,1); old_where[type] = no_stor; edf_new_header(*(typestr + type)); edf_history_new(*(typestr + type)); return(-1); } /* get_buffer */ /*============================================================================== * Save the data buffer to a file or to the shared memory segment. * * If there is an output data file defined, write the contents of the data * buffer to the output file. Additionally the header information will be * written. It consists of the following parts: * - the standard header as provided by the EDF output routines. It contains at * least: EDF_DataBlockID, EDF_BinarySize, HeaderID, ByteOrder, DataType, * Dim_1, Dim_2; * - the content of the header structure. This is filled by the input header * data in the distortion file, the EDF data file or the online header shared * memory segment; * - the content of the program-internal history structure, describing the * actions that the program has performed on the data. * * If there is a shared memory segment defined for the type of data to be * written (given in "type"), then its modification counter will be increased. * * Both, only one or none of output data file and shared memory segment for data * might be defined. * * Input : file: file name of the output data file, or NULL if not defined * buffer_ptr: data buffer * rows: number of elements in the second dimension of the image * (this is the "slow-moving" index, i.e. the first index * in a two-dimensional C data buffer) * cols: number of elements in the first dimension of the image * (this is the "fast-moving" index, i.e. the second index * in a two-dimensional C data buffer) * type: type of data buffer to be written (see in get_buffer()) * Output: none * Return: -1 if errors * 0 else */ int put_buffer(char *file,void **buffer_ptr,int rows,int cols,int type) { static char id[EdfMaxKeyLen + 1],val[EdfMaxValLen + 1]; void *outptr; char *pkey,*pval; int i,err,status,mtype = MFloat; int valset; SHM_HEADER *shm_ptr = current_shm[type]; struct data_head user_head; /* * Check whether the type of data requested is a valid one. */ if(!(type == SRCTYP || type == CORTYP || type == DRKTYP || type == SDXTYP || type == SDYTYP || type == SDMTYP || type == AZITYP || type == AVETYP || type == HD_TYP)) { errno = 0; prmsg(FATAL,("invalid data type %d for put_buffer().\n",type)); } /* * If the input source image is a shared memory that is saved to a file, then * the complete online header is always written to the file as well; but the * header information from the input source file is only passed on to * * - the corrected output file if requested with "headpass"; * - the azimuthally regrouped output file if requested with "azim_pass". */ if(type == SRCTYP || headpass && type == CORTYP || azim_pass && type == AZITYP) { int prerotpass = ((type == SRCTYP) || (headpass && (!get_doprerot())))?1:0; edf_first_header_element(*(typestr + HD_TYP),(const char **)&pkey, (const char **)&pval,&err,&status); while(pkey != NULL) { /* * Do not pass any PREROT parameters to corrected images when do_prerot * is set, otherwise it would mean that the corrected data need still to * be prerotated. */ if ( (prerotpass) || (is_not_prerotpar( pkey )) ) { edf_add_header_element(*(typestr + type),pkey,pval,&err,&status); if(status != status_success) { prmsg(ERROR,("error copying %s header value: %s\n",pkey, edf_report_data_error(err))); return(-1); } } edf_next_header_element(*(typestr + HD_TYP),(const char **)&pkey, (const char **)&pval,&err,&status); } } /* * Update the header information with the values from the header structure * (not necessary for the input source image). */ if(type != SRCTYP) { get_headval(&user_head,type); for(i = 0; i < maxhdkey; i++) { valset=1; if(user_head.init & 1 << i) { strcpy(id,*(headkey + i)); switch(i) { case 0: sprintf(val,"%ld",user_head.Orientat); break; case 1: sprintf(val,"%g",user_head.Dummy); break; case 2: sprintf(val,"%g",user_head.DDummy); break; case 3: sprintf(val,"%g pixel",user_head.Offset_1); break; case 4: sprintf(val,"%g pixel",user_head.Offset_2); break; case 5: sprintf(val,"%g m",user_head.PSize_1); break; case 6: if(type != AZITYP) sprintf(val,"%g m",user_head.PSize_2); else sprintf(val,"%g rad",user_head.PSize_2); break; case 7: strcpy(val,user_head.Intens_0); break; case 8: strcpy(val,user_head.Intens_1); break; case 9: sprintf(val,"%g pixel",user_head.Center_1); break; case 10: sprintf(val,"%g pixel",user_head.Center_2); break; case 11: sprintf(val,"%g m",user_head.SamplDis); break; case 12: sprintf(val,"%g m",user_head.WaveLeng); break; case 13: if(type == DRKTYP) strcpy(val,"Dark Image"); else strcpy(val,user_head.Title); break; case 14: strcpy(val,user_head.Time); break; case 15: strcpy(val,user_head.ExpTime); break; case 16: sprintf(val,"%g",user_head.BSize_1); break; case 17: sprintf(val,"%g",user_head.BSize_2); break; case 18: sprintf(val,"%d",user_head.Dim_1); break; case 19: sprintf(val,"%d",user_head.Dim_2); break; case 20: strcpy(val,user_head.ProjTyp); break; case 21: sprintf(val,"%g_deg",RAD2DEG(user_head.DetRot_1)); break; case 22: sprintf(val,"%g_deg",RAD2DEG(user_head.DetRot_2)); break; case 23: sprintf(val,"%g_deg",RAD2DEG(user_head.DetRot_3)); break; default: valset=0; } if (valset) { edf_add_header_element(*(typestr + type),id,val,&err,&status); if(status != status_success) { prmsg(ERROR,("error updating %s header value %s: %s\n",id,val, edf_report_data_error(err))); return(-1); } } } } } /* * Copy the history from the internal history structure to the header * structure. Note that for the corrected image, this also means that the * history will be written back to the online header, if there is one. */ edf_history_write_header(*(typestr + type),*(typestr + type),&err,&status); /* * For corrected, azimuthal, averaged and spatial distortion displacement data * the buffer to be written has been created by the program. * * If only header data are to be saved to a special output file, no data * buffer is required. * * For the other types (source and dark image), there must be an input shared * memory to be written to file. If not, return with error. */ if(type == CORTYP || type == AZITYP || type == AVETYP || type == SDXTYP || type == SDYTYP || type == SDMTYP) { outptr = *buffer_ptr; /* * If a shared memory segment is defined for these data types, increase its * modification counter. If there was also an online header for the source * data, write the header values of the corrected image back to the online * header and increase its modification counter as well. */ if(shm_ptr) { incShmUTime(shm_ptr); if(type == CORTYP && (shm_ptr = current_shm[HD_TYP]) != NULL) { char *hdptr,*hdend; int headrows,headcols; headrows = getShmRows(shm_ptr); headcols = getShmCols(shm_ptr); /* shm_ptr is attached, getShmDataPtr can be used without problems */ hdptr = (char *) getShmDataPtr(shm_ptr,0); hdend = hdptr + headrows * headcols; /* * Reset the online header to empty lines. */ for(; hdptr < hdend; hdptr += headcols) *hdptr = '\0'; /* * Write the keywords and values of CORTYP header to the online header. */ /* shm_ptr is attached, getShmDataPtr can be used without problems */ hdptr = (char *) getShmDataPtr(shm_ptr,0); edf_first_header_element(*(typestr + CORTYP),(const char **)&pkey, (const char **)&pval,&err,&status); while(pkey != NULL) { strcpy(hdptr,pkey); hdptr += headcols; strncpy(hdptr,pval,headcols - 1); *(hdptr + headcols - 1) = '\0'; hdptr += headcols; edf_next_header_element(*(typestr + CORTYP),(const char **)&pkey, (const char **)&pval,&err,&status); } incShmUTime(shm_ptr); } } } else if(type == HD_TYP) { outptr = NULL; } else { if(shm_ptr) { rows = getShmRows(shm_ptr); cols = getShmCols(shm_ptr); switch(getShmType(shm_ptr)) { case SHM_UCHAR: mtype = edf_datatype2machinetype(Unsigned8); break; case SHM_USHORT: mtype = edf_datatype2machinetype(Unsigned16); break; case SHM_ULONG: mtype = edf_datatype2machinetype(Unsigned32); break; case SHM_LONG: mtype = edf_datatype2machinetype(Signed32); break; } /* shm_ptr is attached, getShmDataPtr can be used without problems */ outptr = getShmDataPtr(shm_ptr,0); } else { prmsg(ERROR,("no shared memory segment to save for %s image.\n", *(typestr + type))); return(-1); } } /* * If an output file is defined, write to it the data and possibly additional * header information from shared memory segment. */ if(file) { prmsg(MSG,("Saving %s image to file %s\n",*(typestr + type),file)); return(save_esrf_file(file,outptr,rows,cols,type,mtype)); } return(0); } /* put_buffer */ /*============================================================================== * Detaches from shared memory and optionally deletes the data buffer. * * If there is a shared memory segment associated with the data, detach from it. * * If there was a buffer allocated for the data storage, delete it if the * "free_flag" is set. * * Note that if the data came from a file, there is always a data buffer * allocated for it, but no shared memory segment is associated with it. If * the data came from a shared memory segment, this memory segment might be * used as the data buffer (in which case there is no buffer allocated), or * a new buffer might be allocated to hold a copy of the data in the memory * segment (in which case there will be both a memory segment and an allocated * buffer for the data). For details, see routine get_buffer(). * * Input : buffer_ptr: data buffer, or NULL if none available * type: type of data buffer to be obtained (see in get_buffer()) * free_flag: flag to determine if an allocated data buffer will be * deleted: delete buffer if set, otherwise keep it * Output: buffer_ptr: data buffer (may have been set to NULL) * Return: 0 */ int clean_buffer(void **buffer_ptr,int type,int free_flag) { SHM_HEADER *shm_ptr = current_shm[type]; void *shm_data_ptr = current_shm_data[type]; if(shm_ptr != NULL) { shmdt((void *)shm_ptr); } /* * If there is a shared memory segment and an allocated buffer for this data, * then the pointer handed over as input argument points to the allocated * buffer and will be different from the pointer to the memory segment in the * array "current_shm". The allocated buffer is then freed. If the two * pointers are identical, the input pointer points to the memory segment and * must not be freed! */ if(free_flag && *buffer_ptr) { if(shm_ptr == NULL || shm_data_ptr != *buffer_ptr) { pfree(*buffer_ptr); } *buffer_ptr = NULL; current_shm[type] = NULL; current_shm_data[type] = NULL; } return(0); } /*============================================================================== * Sets globally the data type of all output edf files. * * If out_type is NULL or an empty string the output data type is reset to * default. * * Input : new value for output type * Output: none * Return: none */ void set_type(char *out_type) { int datatype_out; /* * Test if output type is NULL or empty. */ if(!out_type) out_type=""; if(strlen(out_type)) { /* * If not, convert string to data type and set output data type of all * output files, including xy-shift files. */ datatype_out = edf_string2datatype(out_type); if(datatype_out!=InValidDType) edf_set_datatype(datatype_out); /* * If NULL or empty, set data type to default (no conversion). */ } else edf_set_datatype(InValidDType); } /*============================================================================== * Sets globally the data value offset for all output edf files. * * Input : new value for dvo * Output: none * Return: none */ void set_dvo(long dvo) { /* * Set data value offset of all (!) output files (also xy-shift files!) */ edf_set_datavalueoffset(dvo); } /*============================================================================== * Analyze the input arguments, set the parameters of the correction routines * accordingly, get all required image data (input image, dark image image, * etc.) and call the correction routines. * * The input arguments consist of options and file names in the form * * opt1=val1 opt2=val2 opt3=val3 filename1 [filename2 ...] * * Options have the form "name=value" and are distinguished from the file name * arguments by the presence of the equal sign "=". * * No option needs to be given, and no filename needs to be given either. * However, at least an input image must be specified, either with the "src_id" * option or by giving at least one filename. * * The routine processes first the options, until it encounters the first input * argument that is not an option (i.e. that does not contain a "=") or when * all input arguments have been processed. Any input arguments that might be * left in the input line are considered to be file names for the input image * file. * * Note that it is therefore required that all options precede the input file * names, as any option following the first file name will also be considered * to be a file name. * * The order of the options is normally not relevant, e.g. the dark image * options can be specified before or after the flood field options. However, * some options are mutually exclusive (e.g., there are three options to * specify the dark image source, but they cannot all be specified at the same * time). In these cases, the order is important, and the last option given * is the one that is retained. * * The option "clear" is a special case: it will reset all previously set * option values to their default values. It therefore makes only sense if * given at the beginning of a series of options for a particular input image, * to reset options that might have been set for previous images. If given in * the middle of a series of options for one image, all options just set before * "clear" for this image will be reset, which is probably not what was * intended. * * If there is more than one file name specified, the routine will process them * all, in the order given by the input arguments. * * The routine returns an error if at least one of the input files was not * processed successfully. However, subsequent files in the input string are * still processed and may be corrected successfully. * * The possible options are described below in alphabetical order. * * active_radius defines a circular "active area" in the image. No spatial * distortion corrections are done for pixels outside this area * (default: 0., i.e. no "active area" used) * * ave_ext filename extension for the azimuthal averaged output image * file (default: empty string, i.e. no output file written). * The base of the filename is in "base_name" * ave_id shared memory segment identifier for the azimuthal averaged * output image (default: -1, i.e. no identifier specified) * * The two options ave_ext and ave_id specify the output for * the azimuthal averaged image. This can be: * - ave_ext: a output image file; * - ave_id: a shared memory segment. * * The default values are that no output for the azimuthal * averaged image will be produced (no shared memory segment * and no filename extension specified). * * ave_scf scale factor for "s" values of the averaged image * (default: 1.) * * azim_a0 start angle for 1st azimuthal regrouping (default: 0.0) * azim_a1 start angle for 2nd azimuthal regrouping (default: not used) * azim_a_num angular dimension of output buffer for azimuthal regrouping * (default: 0) * azim_da angle interval for azimuthal regrouping (default: 1.0) * azim_ext filename extension for the azimuthal regrouped output image * file (default: empty string, i.e. no output file written). * The base of the filename is in "base_name" * azim_id shared memory segment identifier for the azimuthal regrouped * output image (default: -1, i.e. no identifier specified) * * The two options azim_ext and azim_id specify the output for * the azimuthal regrouped image. This can be: * - azim_ext: a output image file; * - azim_id: a shared memory segment. * * The default values are that no output for the azimuthal * regrouped image will be produced (no shared memory segment * and no filename extension specified). * * azim_int if set, regroupe the image along the azimuth angle * (default: 0, i.e. no regrouping) * azim_pass if set, all header values of the corrected image are passed * to the azimuthal regrouped image (default: 1, i.e. set) * * azim_pro choose "Saxs" or "Waxs" projection for azimuthal image. * in case of "Waxs" a "Saxs" input image is projected to the * Ewald sphere taking into account the detector rotations. * (default: not used). * * azim_r0 minimum radius for azimuthal regrouping (default: 0.0) * azim_r_num radial dimension of output buffer for azimuthal regrouping * (default: 0) * * base_name contains the "file name base" from which all other file names * are derived (default: "image") * * bckg_const constant to be added to the value of all scattering * background image pixels (default: 0.) * bckg_fact multiplication factor for the value of all scattering * background image pixels (default: 1.) * * bckg_const and bckg_fact are applied to the scattering * background image as given in the following formula: * scattering * bckg_fact + bckg_const * * bckg_file name of the file with the scattering background image * (default: no file, i.e. NULL pointer) * bckg_id shared memory segment identifier for the scattering * background image (default: -1, i.e. no identifier specified) * * The two options bckg_id and bckg_file specify the input * source for the scattering background image. This can be: * - bckg_id: a shared memory segment; * - bckg_file: a scattering background image file. * * Default is no scattering background correction (no shared * memory segment nor scattering background file defined). * * Note that only one scattering background image input source * can be specified; if more than one is specified in the input * arguments, then only the last one will be taken into account. * * bin_1 number of pixels to bin together in x-direction (default: 1, * i.e. no binning to be performed) * bin_2 number of pixels to bin together in y-direction (default: 1, * i.e. no binning to be performed) * * bis_1 if set, defines value for "BSize_1" header keyword. * bis_2 if set, defines value for "BSize_2" header keyword. * * bkg_const old name of "dark_const" parameter (do not use) * bkg_file old name of "dark_file" parameter (do not use) * bkg_id old name of "dark_id" parameter (do not use) * * cen_1 if set, defines value for "Center_1" header keyword. * cen_2 if set, defines value for "Center_2" header keyword. * * clear reset all previously given options to their default values * (default: 0, i.e. the previously given options are not reset) * * cor_ext filename extension for corrected output image file (default: * ".cor"). The base of the filename is in "base_name". * Note: if "cor_ext" is set to an empty string, no output file * is written. * cor_file name of the output file for the corrected image (default: no * file, i.e. NULL pointer). This option is obsolete and should * be replaced by "cor_ext" with "base_name". * cor_id shared memory segment identifier for the corrected output * image (default: -1, i.e. no identifier specified) * * The two options cor_id and cor_file specify the output for * the corrected image. This can be: * - cor_id: a shared memory segment; * - cor_file: a output image file. * * Default is no output location (no shared memory segment nor * output file defined). * * dark_const constant for overall dark image subtraction (default: 0.) * For more details, see "dark_id" below. * * dark_ext filename extension for the file with the dark (background) * image. This is mainly used to save an online dark image to a * file. (default: empty string, i.e. no output file written). * The base of the filename is in "base_name" * * dark_file name of the file with the dark image (default: no file, * i.e. NULL pointer) * If dark_file is a string containing an opening and a closing * square bracket, then the name of the dark image file is to * be formed by removing the brackets and replacing the part * between the brackets by the value of the the keyword * "char_string" in the header of the source image file. * Example: * with dark_file=../data/[char_string].ext * and the keyword char_string=gd10dark * the resulting filename is ../data/gd10dark.ext * * dark_id shared memory segment identifier for the dark image * (default: -1, i.e. no identifier specified) * * The three options dark_const, dark_id and dark_file specify * the input source for the dark image correction. This can be: * - dark_id: a shared memory segment; * - dark_file: a dark image file; * - dark_const: an overall constant to be applied to all pixels * of the image data. * * Default is no shared memory segment nor dark image file * defined and the overall dark image constant 0. That also * implies that by default there is no dark image correction * performed. * * If a source for the dark image correction is specified, then * normally the dark image correction is performed. However, * this can be prevented by setting "do_dark=0" (see below). * * Note that in principle only either a shared memory segment or * an image file can be specified; if both are specified in the * input arguments, then the one specified last will be used. * * The overall constant can be specified in addition to either * of the two other options. * * distortion_file name of the file with the distortion correction parameters * (default: empty string, i.e. no file). Note: if "xfile" and * "yfile" are specified, "distortion_file" is ignored. * If distortion_file is a string containing an opening and a * closing square bracket, then the name of the distortion file * is to be formed by removing the brackets and replacing the * part between the brackets by the value of the the keyword * "char_string" in the header of the source image file. * Example: * with distortion_file=../data/[char_string].ext * and the keyword char_string=gd10dist * the resulting filename is ../data/gd10dist.ext * * dis if set, defines value for "SampleDistance" header keyword. * * do_dark if set to 0, no dark image correction is performed, even if * there is a source for it (dark image buffer, file or constant * - see "dark_id", "dark_file" and "dark_const" above). The * purpose of this is to allow a saving of the online dark image * buffer for a later processing. * * If set to 1, then the dark image correction is performed if * there is a source for it. Since 2011-10-23 the default value * is 0 and set to 1 by either dark_id, dark_file or dark_const, * if not set explicitely to a different value. * * do_distortion controls the distortion correction/prerotation correction: * 0: no distortion/prerotation correction is performed * >0: distortion/prerotation correction is performed as follows: * 1: after the dark image subtraction (default) * 2: after the floodfield division * 3: after the normalization * 4: after background subtraction. * * Note: regardless of the value of "do_distortion", no * distortion correction is performed if neither * "distortion_file" nor "xfile" and "yfile" are specified. * * do_prerotation controls the prerotation correction: * 0: no prerotation correction is performed (default) * 1: prerotation correction after distortion correction * 2: prerotation correction without distortion correction. * * norm_prerotation if set, renormalize the prerotated image according to the * change in spherical angle covered by each pixel. The * output intensities correspond to a perpendicular detector * that is exactly perpendicular to the primary beam. * (default: 1, renormalization) * * dummy value that is used to ignore a pixel. If dummy is different * from 0 all pixels with a value in the range * [dummy-ddummy,dummy+ddummy] are not processed in the analysis * (default: 0., i.e. not set). * * dvo value that defines globally the data value offset of all * written edf files (default 0). The data value offset is * converted to a long integer value and must be added to all * data values stored in the edf file: * = + * The conversion is done in the module "edfio" when a file is * written. * * flat_after flag indicating whether the flood field correction is to be * done before or after the distortion correction. If the flag * is set, then flood field will be done after distortion * (default: 1, i.e. set). This is obsolete, use "do_distortion" * instead. * flat_distortion if set, the target image is normalized to a flat image * (default: 1, i.e. set) * flood_file name of the file with the flood field image (default: no * file, i.e. NULL pointer) * If flood_file is a string containing an opening and a closing * square bracket, then the name of the flood file image file is * to be formed by removing the brackets and replacing the part * between the brackets by the value of the the keyword * "char_string" in the header of the source image file. * Example: * with flood_file=../data/[char_string].ext * and the keyword char_string=gd10flood * the resulting filename is ../data/gd10flood.ext * flood_id shared memory segment identifier for the flood field image * (default: -1, i.e. no identifier specified) * * The two options flood_id and flood_file specify the input * source for the floodfile image. This can be: * - flood_id: a shared memory segment; * - flood_file: a floodfile image file. * * Default is no flood field correction (no shared memory * segment nor flood field file defined). * * Note that only one flood field image input source can * be specified; if more than one is specified in the input * arguments, then only the last one will be taken into account. * * from_ext filename extension for the input image file. * This is obsolete, use "src_ext" instead. * * header_ext filename extension for the file with the header of the input * source image. This is mainly used to save the online header * to a file when the input source image itself is not saved. * (default: empty string, i.e. no header file written). The * base of the filename is in "base_name" * header_id shared memory segment identifier where additional header * information for the output image is available (default: -1, * i.e. no identifier specified) * header_min set minimum header length for output files (default: 0, i.e. * take default value from EDF routines) * * i0 if set, defines value for "Intensity0" header keyword. * i1 if set, defines value for "Intensity1" header keyword. * inp_const constant to be added to the value of all source image pixels * (default: 0.) * inp_exp exponent applied to the value of all source and dark image * pixels (default: 1.) * inp_factor multiplication factor for the value of all source image * pixels (default: 1.) * * inp_const, inp_exp and inp_factor are applied to the source * and dark image as given in the following formula: * corrected = (source ^ inp_exp - dark ^ inp_exp) * * inp_factor + inp_const * * inp_max maximum allowed value for a pixel. Pixels with bigger values * are not processed in the analysis (default: 0., i.e. not set) * inp_min minimum allowed value for a pixel. Pixels with smaller values * are not processed in the analysis (default: 0., i.e. not set) * mask_file name of the file with a mask image of pixels to ignore for * azimuthal regrouping (default: no file, i.e. NULL pointer) * * norm_factor multiplication factor for the value of all scattering * intensity normalized image pixels (default: 1.). Used only * if "norm_int" is set * norm_int if set, normalize image to absolute scattering intensities * 0: no normalization (default) * 1: full normalization to DOmega and Intensity1 * 2: normalization to Intensity1 * 3: normalization to DOmega * * overflow pixel value used to mark an overflow (default: 0 == not set) * * off_1 if set, defines value for "Offset_1" header keyword. * off_2 if set, defines value for "Offset_2" header keyword. * ori if set, defines value for "RasterOrientation" header keyword. * outdir directory path for the output files (default: directory path * of "base_name" option). * * If "outdir" contains a string (i.e. not empty), this string * will be prefixed to the names of the output files unless * these contain already a directory path. * * The output files concerned are: * - simulated grid image; * - file for saving online dark image buffer; * - file for saving online source image buffer; * - file for saving online header buffer; * - files for the x and y distortion correction displacements; * - corrected output image; * - file for azimuthal regrouping and averaging. * * pass if set, all header values of the input source file are read * and written to the corrected output file (default: 0 not set) * * pix_1 if set, defines value for "PSize_1" header keyword. * pix_2 if set, defines value for "PSize_2" header keyword. * * pro string defining projection type to calculate the scattering * vectors for the azimuthal regrouping (default: "Saxs"): * "Saxs" normal SAXS images * "Waxs" images that have been projected to the Ewald sphere * * psize_distort if set, certain image parameters for the corrected image are * taken from the distortion files (default: 0, i.e. not set). * * If psize_distort = 1, only the pixel size for the corrected * image is taken from the distortion files. * * If psize_distort = 2, the pixel size, center, offset, sample * distance, binning size, projection and rotation for the * corrected image are taken from the distortion file. * * If psize_distort is set and any of the input arguments * pix_1, pix_2, cen_1, cen_2, off_1, off_2, bis_1, bis_2, dis, * pro, rot_1, rot_2 or rot_3 are set as well, then the value * given in the input arguments has precedence over the value in * the distortion files. * * rot_1 angle (in radian) for the detector rotation in plane 1 * rot_2 angle (in radian) for the detector rotation in plane 2 * rot_3 angle (in radian) for the detector rotation in plane 3 * (default: 0. for all 3 angles) * * save_dark if set, the SPEC shared memory segment for the dark current * (= background) image is saved to a file with extension * ".dark". * Possible values: 0 = not set, * 1 = save always, * 2 = save if new image (default). * Saving will only happen if the input source image is also * saved (i.e. "src_ext" is not empty) * scat_const old name of "bckg_const" parameter (do not use) * scat_fact old name of "bckg_fact" parameter (do not use) * scat_file old name of "bckg_file" parameter (do not use) * scat_id old name of "bckg_id" parameter (do not use) * simul_id if set, the routine only produces a simulated grid with * Gaussian peaks and puts it to the output destination; no * image processing is done (default: 0, i.e. not set) * * src_ext filename extension for the file with the input source image * (default: ".edf"). This is mainly used to save online input * data to a file. The base of the filename is in "base_name". * Note: if "src_ext" is set to an empty string, no output file * is written. * src_id shared memory segment identifier for the input image data * (default: -1, i.e. no identifier specified) * * Note that if there is both a shared memory segment and * filename(s) specified for the input image data, only the * filename(s) will be used. * * tit if set, defines string value for "Title" header keyword. * to_ext filename extension for the corrected image file. * This is obsolete, use "cor_ext" instead. * * type defines globally the data type of all written edf files. * Possible values are defined in the document "SaxsKeywords", * e.g. "FloatIEEE32" (default), "Unsigned16". * The values are converted to the closest possible output * value. * The conversion is done in the module "edfio" when an EDF file * is written. * * verbose controls the level of message printing from the program: * -1: nothing is printed; * 0: print only the message with types ERROR or FATAL; * 1: (default) print all messages except those of type DMSG * (debug); * 2: print all messages including debugging messages. * version print version string of the program if != 0. * * wvl if set, defines value for "WaveLength" header keyword. * * xfile name of the input file with the values of the distortion * corrections for the x coordinate (default: empty string, i.e. * no file). Needs to be specified simultaneously with "yfile". * See also remark at "distortion_file" above. * xoutfile name of the output file for the values of the distortion * corrections for the x coordinate (default: no file, i.e. NULL * pointer) * yfile name of the input file with the values of the distortion * corrections for the y coordinate (default: empty string, i.e. * no file). Needs to be specified simultaneously with "xfile". * See also remark at "distortion_file" above. * youtfile name of the output file for the values of the distortion * corrections for the y coordinate (default: no file, i.e. NULL * pointer) * * Input : argc: number of input arguments * argv: array of strings with the input arguments * progname: string with the name of the executing program * Output: none * Return: >= 0 if successful * < 0 otherwise */ int analyse_args(int argc,char *argv[],char *progname) { #define MaxKeyLen1 EdfMaxKeyLen + 1 static int floid = -1,darkid = -1,bckgid = -1,corid = -1,headid = -1; static int azim_id = -1,ave_id = -1; int srcid = -1; static void *flo_im = NULL,*dark_im = NULL,*bckg_im = NULL,*cor_im = NULL; static void *src_im = NULL,*azim_im = NULL,*ave_im = NULL,*mask_im = NULL; static void *head_buf,*pnewbuf; static char src_ext[256] = {".edf"},cor_ext[256] = {".cor.edf"}; static char dark_ext[256] = {'\0'},head_ext[256] = {'\0'}; static char azim_ext[256] = {".azim.edf"},ave_ext[256] = {'\0'}; static char flobuf[1024],flotmp[1024],darkbuf[1024],darktmp[1024]; static char bckgbuf[1024],corbuf[1024],maskbuf[1024]; static char *flofile = NULL,*darkfile = NULL,*bckgfile = NULL,*corfile = NULL; static char *maskfile = NULL; char *srcfile = NULL,*tmpnam1 = NULL,*tmpnam2 = NULL; char tmpbuf1[1024],tmpbuf2[1024]; static char out_type[256] = {'\0'},outdir[1024] = {'\0'}; static char basnam[1024] = {"image"}; static char xfbuf[1024] = {'\0'},yfbuf[1024] = {'\0'},distbuf[1024] = {'\0'}; static char xoutbuf[1024] = {'\0'},youtbuf[1024] = {'\0'},moutbuf[1024] = {'\0'}; static char *distfile = NULL; char srcbuf[1024]; char *outfile,*pos; static unsigned long overf = 0; static int norm_int = 0,do_dist = 1,flat_dist = 1,flat_aft = 1,do_dark = 0; static int do_dark_cmd = 0; // is set to 1 by the option do_dark static int do_prerot = 0; static int norm_prerot = 1; static int azimint = 0,azim_rnum = 0,azim_anum = 0,azim_a1fl = 0; static int azim_pro = IO_NoPro; char azim_pro_buf[1024]; static int cols = 0,rows = 0,bin_1 = 1,bin_2 = 1; static int save_dark = 2,psize_distort = 0; static int simul_flag = 0,dummy_set = 0,iverpr = 1,ihistnew = 1; int argn,clear,lcont,dstrt_tmp,rowtmp,err,status; int gbufstat = 0,iret = 0; static float darkconst = 0.,dummy = 0.,arad = 0.,inp_min = 0.,inp_max = 0.; static float inpconst = 0.,bckgconst = 0.; static float inpfact = 1.,inpexp = 1.,bckgfact = 1.,normfact = 1.; static float azim_r0 = 0.,azim_a0 = 0.,azim_da = 1.,ave_scf = 1.; float tmpconst; static unsigned long head_min = 0; static long out_dvo = 0; static float i0,i1; static float azim_a1; static char histargs[] = "InputArg"; static struct data_head cmd_head; struct data_head user_head; if(iverpr == 1) { prntvers(progname); iverpr = 0; } /* * If there are no input arguments, print out a help text and return. */ if(argc == 0) { prmsg(MSG,("Usage: %s parameter=option [filenames]\n",progname)); help_arg(); goto analyse_args_return; } /* * All the input arguments are written into the history header of the output * data to describe the processing done with the input image. * * Technically, this is done by first writing them in an intermediate * "histargs" buffer for all information up to but excluding the source image * file names. Then the intermediate history buffer is copied to the output * history buffer and the source image file name added to it. * * The reason for this is that all information up to the source image file * name remains identical if several input files are processed. This part of * the history can thus be reused. * * The intermediate buffer is created at the start of the processing for an * input image or (offline only) for the sequence of input images specified * on the command line. The input arguments are written into it by the routine * scan_argument(). When analyse_arguments() returns after processing one * image or a series of images, "ihistnew" is reset to 1, and the next call * creates then a new history buffer. */ if(ihistnew == 1) { edf_history_new(histargs); edf_history_argv(histargs,progname); ihistnew = 0; } /* * Loop over the input arguments, extract the values for the options specified * and set the program parameters accordingly. * * Options have the form "name=value" and are distinguished from other input * arguments by the presence of the equal sign "=". * * This loop ends with the first input argument that is not an option or when * all input arguments have been processed. Any input arguments that might be * left in the input line are considered to be file names for the input image * files. * * Note that it is therefore required that all options precede the input file * names, as any option following the first file name will also be considered * to be a file name. * * The order of the options is normally not relevant, e.g. the dark image * options can be specified before or after the flood field options. However, * some options are mutually exclusive (e.g., there are three options to * specify the dark image source, but they cannot all be specified at the same * time). In these cases, the order is important, and the last option given * is the one that is retained. */ for(argn = 0; argn < argc; argn++) { /* * End loop with the first input argument that is not an option. */ if(strchr(argv[argn],'=') == NULL) break; prmsg(DMSG,("command line %d. parameter = %s\n",argn,argv[argn])); /* * This section is for the setting of internal parameters. */ if(scan_argument(argv[argn],"clear","%d",&clear)) { /* * The option "clear" resets all parameters to the startup values. */ if(clear != 0) { floid = darkid = bckgid = corid = headid = azim_id = ave_id = -1; flofile = darkfile = bckgfile = corfile = maskfile = distfile = NULL; *out_type = *outdir = '\0'; *distbuf = *xfbuf = *yfbuf = *xoutbuf = *youtbuf = *moutbuf = '\0'; *dark_ext = *head_ext = *ave_ext = '\0'; strcpy(azim_ext,".azim.edf"); strcpy(basnam,"image"); strcpy(src_ext,".edf"); strcpy(cor_ext,".cor.edf"); do_prerot = 0; norm_prerot = 1; raw_cmpr = UnCompressed; overf = 0; do_dist = flat_aft = flat_dist = verbose = azim_pass = 1; do_dark = do_dark_cmd = 0; // do_dark_cmd is set to 1 by the option do_dark headpass = norm_int = azimint = simul_flag = 0; azim_pro = IO_NoPro; save_dark = 2; psize_distort = 0; cmd_head.init = 0; head_min = out_dvo = 0; darkconst = bckgconst = inpconst = arad = inp_min = inp_max = 0.; dummy = 0.; inpfact = inpexp = bckgfact = normfact = 1.; bin_1 = bin_2 = 1; azim_r0 = azim_a0 = 0.; azim_da = ave_scf = 1.; azim_rnum = azim_anum = azim_a1fl = 0; dummy_set = 0; edf_free_data_file(); } } else if(scan_argument(argv[argn],"version","%d",&iverpr)) { /* * Print the version number of the program if option "version" != 0. */ if(iverpr != 0) { prntvers(progname); iverpr = 0; } } else if(scan_argument(argv[argn],"verbose","%d",&verbose)) { /* nothing */ } else if(scan_argument(argv[argn],"base_name","%s",basnam)) { /* nothing */ } else if(scan_argument(argv[argn],"outdir","%s",outdir)) { /* nothing */ } else if(scan_argument(argv[argn],"overflow","%lu",&overf)) { /* nothing */ } else if(scan_argument(argv[argn],"dummy","%f",&dummy)) { dummy_set = 1; } else if(scan_argument(argv[argn],"inp_min","%g",&inp_min)) { /* nothing */ } else if(scan_argument(argv[argn],"inp_max","%g",&inp_max)) { /* nothing */ } else if(scan_argument(argv[argn],"raw_cmpr","%s", tmpbuf1)) { raw_cmpr = edf_string2compression ( tmpbuf1 ); if ( (raw_cmpr=EndDCompression) ) raw_cmpr=UnCompressed; } else if(scan_argument(argv[argn],"do_prerotation","%d",&do_prerot)) { /* nothing */ } else if(scan_argument(argv[argn],"norm_prerotation","%d",&norm_prerot)) { /* nothing */ } else if(scan_argument(argv[argn],"do_distortion","%d",&do_dist)) { /* nothing */ } else if(scan_argument(argv[argn],"flat_distortion","%d",&flat_dist)) { /* nothing */ } else if(scan_argument(argv[argn],"flat_after","%d",&flat_aft)) { /* nothing */ /* * Following section sets the data format of the output files */ } else if(scan_argument(argv[argn],"type","%s",&out_type)) { /* nothing */ } else if(scan_argument(argv[argn],"dvo","%ld",&out_dvo)) { /* nothing */ /* * Following section sets the binning factor if the images are to be binned. */ } else if(scan_argument(argv[argn],"bin_1","%d",&bin_1)) { /* nothing */ } else if(scan_argument(argv[argn],"bin_2","%d",&bin_2)) { /* nothing */ /* * Following section is for parameters for the scattering intensity * normalization. */ } else if(scan_argument(argv[argn],"norm_int","%d",&norm_int)) { /* nothing */ } else if(scan_argument(argv[argn],"norm_factor","%g",&normfact)) { /* nothing */ /* * Following section is for parameters for the azimuthal regrouping. */ } else if(scan_argument(argv[argn],"azim_int","%d",&azimint)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_pro","%s",&azim_pro_buf)) { if(strlib_ncasecmp("Saxs",azim_pro_buf,4) == 0) azim_pro=IO_ProSaxs; else if(strlib_ncasecmp("Waxs",azim_pro_buf,4) == 0) azim_pro=IO_ProWaxs; } else if(scan_argument(argv[argn],"azim_pass","%d",&azim_pass)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_id","%d",&azim_id)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_ext","%s",azim_ext)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_r0","%f",&azim_r0)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_r_num","%d",&azim_rnum)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_a0","%f",&azim_a0)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_a1","%f",&azim_a1)) { azim_a1fl = 1; } else if(scan_argument(argv[argn],"azim_da","%f",&azim_da)) { /* nothing */ } else if(scan_argument(argv[argn],"azim_a_num","%d",&azim_anum)) { /* nothing */ } else if(scan_argument(argv[argn],"ave_id","%d",&ave_id)) { /* nothing */ } else if(scan_argument(argv[argn],"ave_ext","%s",ave_ext)) { /* nothing */ } else if(scan_argument(argv[argn],"ave_scf","%f",&ave_scf)) { /* nothing */ } else if(scan_argument(argv[argn],"mask_file","%s",maskbuf)) { maskfile = maskbuf; /* * Following section is for parameters for Andy Hammersley's correction. */ /* * Calculate the distortion correction values for x and y from spline * function coefficients. The coefficients are read from the "distortion * file". * * Note that reading the distortion correction values directly from files * (parameters "xfile" and "yfile", see below) takes precedence over * calculating them from the spline function coefficients. Thus, if * "distortion_file" is specified at the same time as "xfile" and "yfile", * then "distortion_file" is ignored. */ } else if(scan_argument(argv[argn],"distortion_file","%s",distbuf)) { distfile = distbuf; /* * Get the distortion correction values for x and y directly instead of * calculating them from the spline function coefficients. * * The two files defined here contain for each pixel the correction in * the x direction ("xfile") and y direction ("yfile") as floating point * numbers. The files are in EDF format and have each the same number of * data values as there are pixels in the image. * * It obviously does not make much sense to specify only one of them, as * the corrections in both directions are needed. If only one is given, the * program acts as if none had been specified. * * See the remark above for "distortion_file" concerning the precedence * of the options "xfile", "yfile" and "distortion_file". */ } else if(scan_argument(argv[argn],"xfile","%s",xfbuf)) { /* nothing */ } else if(scan_argument(argv[argn],"yfile","%s",yfbuf)) { /* nothing */ /* * Save the distortion correction values for x and y when they have been * calculated from the spline function coefficients. * * The two files contained here will receive the corrections in the x * direction ("xoutfile") and y direction ("youtfile"). For more details, * see the description of "xfile" and "yfile" above. */ } else if(scan_argument(argv[argn],"xoutfile","%s",xoutbuf)) { /* nothing */ } else if(scan_argument(argv[argn],"youtfile","%s",youtbuf)) { /* nothing */ } else if(scan_argument(argv[argn],"moutfile","%s",moutbuf)) { /* nothing */ /* * Defines a circular "active area" in the image. */ } else if(scan_argument(argv[argn],"active_radius","%f",&arad)) { /* nothing */ /* * This parameter causes certain parameters for the corrected image to be * taken from the distortion correction files. * * If it is 1, the pixel size is taken. * * If it is 2, the pixel size, center coordinates, sample distance, * projection and rotation for the corrected image are taken from the * distortion correction files. */ } else if(scan_argument(argv[argn],"psize_distort","%d",&psize_distort)) { /* nothing */ /* * These parameters, if set, define the following keywords in the data * header: * - cen_1 defines Center_1 * - cen_2 defines Center_2 * - i0 defines Intensity0 * - i1 defines Intensity1 * - off_1 defines Offset_1 * - off_2 defines Offset_2 * - pix_1 defines PSize_1 * - pix_2 defines PSize_2 * - bis_1 defines BSize_1 * - bis_2 defines BSize_2 * - ori defines RasterOrientation * - dis defines SampleDistance * - tit defines Title * - wvl defines WaveLength * - pro defines ProjectionType * - rot_1 defines DetectorRotation_1 * - rot_2 defines DetectorRotation_2 * - rot_3 defines DetectorRotation_3 */ } else if(scan_argument(argv[argn],"cen_1","%f",&cmd_head.Center_1)) { cmd_head.init |= FL_CENT1; } else if(scan_argument(argv[argn],"cen_2","%f",&cmd_head.Center_2)) { cmd_head.init |= FL_CENT2; } else if(scan_argument(argv[argn],"i0","%f",&i0)) { sprintf(cmd_head.Intens_0,"%g",i0); cmd_head.init |= FL_INTE0; } else if(scan_argument(argv[argn],"i1","%f",&i1)) { sprintf(cmd_head.Intens_1,"%g",i1); cmd_head.init |= FL_INTE1; } else if(scan_argument(argv[argn],"off_1","%f",&cmd_head.Offset_1)) { cmd_head.init |= FL_OFFS1; } else if(scan_argument(argv[argn],"off_2","%f",&cmd_head.Offset_2)) { cmd_head.init |= FL_OFFS2; } else if(scan_argument(argv[argn],"pix_1","%f",&cmd_head.PSize_1)) { cmd_head.init |= FL_PSIZ1; } else if(scan_argument(argv[argn],"pix_2","%f",&cmd_head.PSize_2)) { cmd_head.init |= FL_PSIZ2; } else if(scan_argument(argv[argn],"bis_1","%f",&cmd_head.BSize_1)) { cmd_head.init |= FL_BSIZ1; } else if(scan_argument(argv[argn],"bis_2","%f",&cmd_head.BSize_2)) { cmd_head.init |= FL_BSIZ2; } else if(scan_argument(argv[argn],"dis","%f",&cmd_head.SamplDis)) { cmd_head.init |= FL_SAMDS; } else if(scan_argument(argv[argn],"ori","%d",&cmd_head.Orientat)) { cmd_head.init |= FL_ORIEN; } else if(scan_argument(argv[argn],"tit","%s",&cmd_head.Title)) { cmd_head.init |= FL_TITLE; } else if(scan_argument(argv[argn],"wvl","%f",&cmd_head.WaveLeng)) { cmd_head.init |= FL_WAVLN; } else if(scan_argument(argv[argn],"pro","%s",&cmd_head.ProjTyp)) { cmd_head.init |= FL_PRO; } else if(scan_argument(argv[argn],"rot_1","%f",&cmd_head.DetRot_1)) { cmd_head.init |= FL_ROT1; } else if(scan_argument(argv[argn],"rot_2","%f",&cmd_head.DetRot_2)) { cmd_head.init |= FL_ROT2; } else if(scan_argument(argv[argn],"rot_3","%f",&cmd_head.DetRot_3)) { cmd_head.init |= FL_ROT3; /* * If do_prerotation is set, the following parameters are used to include * a rotation correction after the distortion correction. The prerotations * align the detector perpendicular to the incident beam where all * detector rotations are 0, i.e. for rot_1=rot_2=rot_3=0. * - precen_1 defines pre-rotation Center_1 (default calculated from cen_1) * - precen_2 defines pre-rotation Center_2 (default calculated from cen_2) * - predis defines pre-rotation SampleDistance (default calculated from dis) * - prerot_1 defines pre-rotation DetectorRotation_1 (default 0) * - prerot_2 defines pre-rotation DetectorRotation_2 (default 0) * - prerot_3 defines pre-rotation DetectorRotation_3 (default 0) * This is also known as fit2d tilt-correction. Use sxparams to translate * between prerotation and tilts. */ } else if(scan_argument(argv[argn],"precen_1","%f",&cmd_head.PreCenter_1)) { cmd_head.init |= FL_PRECEN1; } else if(scan_argument(argv[argn],"precen_2","%f",&cmd_head.PreCenter_2)) { cmd_head.init |= FL_PRECEN2; } else if(scan_argument(argv[argn],"predis","%f",&cmd_head.PreSamplDis)) { cmd_head.init |= FL_PREDIS; } else if(scan_argument(argv[argn],"prerot_1","%f",&cmd_head.PreDetRot_1)) { cmd_head.init |= FL_PREROT1; } else if(scan_argument(argv[argn],"prerot_2","%f",&cmd_head.PreDetRot_2)) { cmd_head.init |= FL_PREROT2; } else if(scan_argument(argv[argn],"prerot_3","%f",&cmd_head.PreDetRot_3)) { cmd_head.init |= FL_PREROT3; /* * This parameter causes a simulated grid to be produced and saved to the * corrected output file. No image correction processing will happen. */ } else if(scan_argument(argv[argn],"simul_id","%d",&simul_flag)) { /* nothing */ /* * The different dark image input options - end up with a buffer pointer. * * The dark image input can be: * - a shared memory segment; * - a dark image file; * - an overall constant to be applied to all pixels of the image data. * * Default is no shared memory segment nor dark image file defined and the * overall dark image constant 0. This implies that by default no dark image * correction is performed. * * However, even if a source for the dark image correction is specified, the * correction can still be suppressed with the option "do_dark=0". This * allows the specification and saving of a dark image buffer for later * processing. By default, "do_dark" is 1. * * Note that in principle only either a shared memory segment or an image * file can be specified; if both are specified in the input arguments, then * the one specified last will be used. * * The overall constant can be specified in addition to either of the two * other options. * * The (possibly dark image-corrected) values of the input image can then * be further adjusted with a multiplicative and an additive constant. */ } else if(scan_argument(argv[argn],"dark_id","%d",&darkid) || scan_argument(argv[argn],"bkg_id","%d",&darkid)) { darkfile = NULL; if ((darkid!=-1)&&(!do_dark_cmd)) do_dark=1; } else if(scan_argument(argv[argn],"dark_file","%s",darkbuf) || scan_argument(argv[argn],"bkg_file","%s",darkbuf)) { darkid = -1; darkfile = darkbuf; if (!do_dark_cmd) do_dark=1; } else if(scan_argument(argv[argn],"dark_const","%g",&darkconst) || scan_argument(argv[argn],"bkg_const","%f",&darkconst)) { if (!do_dark_cmd) do_dark=1; /* nothing */ } else if(scan_argument(argv[argn],"do_dark","%d",&do_dark)) { do_dark_cmd = 1; /* nothing */ } else if(scan_argument(argv[argn],"save_dark","%d",&save_dark)) { /* nothing */ } else if(scan_argument(argv[argn],"dark_ext","%s",dark_ext)) { /* nothing */ } else if(scan_argument(argv[argn],"inp_const","%g",&inpconst)) { /* nothing */ } else if(scan_argument(argv[argn],"inp_exp","%g",&inpexp)) { /* nothing */ } else if(scan_argument(argv[argn],"inp_factor","%g",&inpfact)) { /* nothing */ /* * The different flood field input options - end up with a buffer pointer. * * The flood field input can be: * - a shared memory segment; * - a flood field image file. * * Default is no flood field correction, i.e. no shared memory segment nor * flood field file defined. * * Note that in principle only one flood field input source can be * specified; if more than one is specified in the input arguments, then * only the last one will be taken into account. */ } else if(scan_argument(argv[argn],"flood_id","%d",&floid)) { flofile = NULL; } else if(scan_argument(argv[argn],"flood_file","%s",flobuf)) { floid = -1; flofile = flobuf; /* * The different scattering background input options - end up with a buffer * pointer. * * The scattering background input can be: * - a shared memory segment; * - a scattering background image file. * * Default is no scattering background correction, i.e. no shared memory * segment nor scattering background file defined. * * Note that in principle only one scattering background input source can be * specified; if more than one is specified in the input arguments, then * only the last one will be taken into account. * * The scattering background image, if it exists, can have a multiplicative * and an additive constant applied to the value of each pixel before it is * subtracted from the image to be corrected. These constants are obtained * here. */ } else if(scan_argument(argv[argn],"bckg_id","%d",&bckgid) || scan_argument(argv[argn],"scat_id","%d",&bckgid)) { bckgfile = NULL; } else if(scan_argument(argv[argn],"bckg_file","%s",bckgbuf) || scan_argument(argv[argn],"scat_file","%s",bckgbuf)) { bckgid = -1; bckgfile = bckgbuf; } else if(scan_argument(argv[argn],"bckg_const","%f",&bckgconst) || scan_argument(argv[argn],"scat_const","%g",&bckgconst)) { /* nothing */ } else if(scan_argument(argv[argn],"bckg_factor","%g",&bckgfact) || scan_argument(argv[argn],"scat_factor","%g",&bckgfact)) { /* nothing */ /* * The shared memory where user-defined header values are obtained from. */ } else if(scan_argument(argv[argn],"header_id","%d",&headid)) { /* nothing */ /* * Determine if the entire input source file header is passed to the output. */ } else if(scan_argument(argv[argn],"pass","%d",&headpass)) { /* nothing */ /* * Set the minimum header length for output files (if not set, take default * from EDF I/O routines). */ } else if(scan_argument(argv[argn],"header_min","%lu",&head_min)) { if(head_min > 0) edf_set_minimumheadersize(head_min); /* * The filename extension of the output file where header of the input * source image is saved to (saving is done if this extension is not empty). */ } else if(scan_argument(argv[argn],"header_ext","%s",head_ext)) { /* nothing */ /* * The different options where to put the results. * * The options "cor_file" and "to_ext" are obsolete. They should be replaced * by "base_name" and "cor_ext". * * Note that a value of "-" (minus) for the "cor_file" parameter causes any * previously given output file name to be erased (the pointer to the file * name is set to NULL). */ } else if(scan_argument(argv[argn],"cor_id","%d",&corid)) { /* nothing */ } else if(scan_argument(argv[argn],"cor_ext","%s",cor_ext)) { /* nothing */ } else if(scan_argument(argv[argn],"to_ext","%s",cor_ext)) { /* nothing */ } else if(scan_argument(argv[argn],"cor_file","%s",corbuf)) { corfile = NULL; if(strcmp(corbuf,"-") && *corbuf != '\0') { corfile = corbuf; } /* * The input image specification - end up with a buffer pointer. * * The source for the input image can be: * * - a shared memory segment; * - one (or several) files with input image data. * * The shared memory segment is used if an identifier for it is set with * the option "src_id". * * Data files with input image data have to be given on the input argument * line after all option arguments (see below). * * It is not possible to have a shared memory segment and files with input * image data at the same time. If both are specified, the shared memory * segment will be ignored. However, it is possible to specify several input * data files. They will all be processed, in the sequence given by the * input arguments. * * The option "from_ext" is obsolete. It should be replaced by "src_ext". */ } else if(scan_argument(argv[argn],"src_id","%d",&srcid)) { srcfile = NULL; } else if(scan_argument(argv[argn],"src_ext","%s",src_ext)) { /* nothing */ } else if(scan_argument(argv[argn],"from_ext","%s",src_ext)) { /* nothing */ } else { errno = 0; prmsg(ERROR,("Unknown option: %s\n",argv[argn])); } } /* * End of the loop over the option arguments. */ /* * Default value for "outdir": if not set, set it to the directory path of * "basnam" (if there is one). */ if(*outdir == '\0' && (pos = strrchr((const char *)basnam,(int)'/')) != NULL) strncat(outdir,basnam,pos - basnam + 1); /* * If the simulation flag is set, do the grid simulation, write it to the * output file and return without any further processing. */ if(simul_flag) { if(corid == -1) { cols = get_xsize(); rows = get_ysize(); } else { cols = 0; rows = 0; } if(get_buffer(corid,NULL,&cor_im,&rows,&cols,CORTYP) != -1) { prmsg(MSG,("Starting to simulate grid image [%d,%d]\n",cols,rows)); make_grid(cor_im,1000.0,5.0,0); if(*cor_ext != '\0') outfile = outname(basnam,outdir,src_ext,cor_ext); else outfile = corfile; put_buffer(outfile,&cor_im,rows,cols,CORTYP); } clean_buffer(&cor_im,CORTYP,1); ihistnew = 1; goto analyse_args_return; } /* * Test if there are any more input arguments. If so, take the first and * interpret it as a file name for an input image data file. */ if(argn < argc) { if(fnampat(srcbuf,sizeof(srcbuf),argc - argn,argv + argn) < 0) goto analyse_args_cleanup; srcfile = srcbuf; srcid = -1; } /* * If there is no input source specified, return without further action. * * This serves as a protection against incorrect use of the program: it * does not make sense to correct a non-existent input image. * * However, this is also used as a feature by the online-version of the * program. In this case, the command line parameters for the correction of * one image may be handed over in several subsequent calls to analyse_args(). * Each call sets some parameters, and only the last one contains the input * source image and therefore starts the correction. */ if(srcfile == NULL && srcid == -1) goto analyse_args_return; /* * Set the "input data busy" flag indicating that the program is getting the * input data now. This flag can be tested with the "getstate()" routine. */ inptbusy = 1; /* * Default value for "dark_file": if not set, set it to "[DarkFileName]" if: * - a dark image correction is requested; * - there is a source image file (otherwise there can be no substitution). */ if(darkfile == NULL && do_dark == 1 && srcfile != NULL) darkfile = strcpy(darkbuf,"[DarkFileName]"); /* * Set globally the output data type and data value offset. */ set_type(out_type); set_dvo(out_dvo); /* * Hand the parameters to the correction routines. */ set_headval(cmd_head,CMDTYP); set_overflow(overf); set_inpmin(inp_min * bin_1 * bin_2); set_inpmax(inp_max * bin_1 * bin_2); set_dummy(dummy); set_dodark(do_dark); set_doflat(flat_dist); set_normint(norm_int,normfact); set_actrad(arad); dstrt_tmp = 0; if(psize_distort == 1) dstrt_tmp = FL_PSIZ1 + FL_PSIZ2; else if(psize_distort == 2) dstrt_tmp = FL_OFFS1 + FL_OFFS2 + FL_PSIZ1 + FL_PSIZ2 + FL_CENT1 + FL_CENT2 + FL_SAMDS + FL_BSIZ1 + FL_BSIZ2 + FL_PRO + FL_ROT1 + FL_ROT2 + FL_ROT3; set_dstrtval(dstrt_tmp); /* * Apply linearity correction for dark constant, if necessary. * * Note that for the dark constant, the additional factor resulting from the * binning of the image must be the one of the source image, not of the dark * image (which might not even exist). */ if(inpexp != 1. && bin_1 * bin_2 != 1) tmpconst = pow((double)darkconst / (double)(bin_1 * bin_2),(double)inpexp) * bin_1 * bin_2; else tmpconst = darkconst; set_drkconst(tmpconst); set_inpconst(inpconst); set_inpexp(inpexp); set_inpfact(inpfact); set_bckgconst(bckgconst); set_bckgfact(bckgfact); /* * If the image comes from shared memory, clear the flags of the SRCTYP header * structure (and therefore also the flags of the CORTYP header structure). * This is useful if there is an input image but no header for it - in this * case the previous header structure would be kept, which might not be what * was desired. * * If the image comes from a file, this situation cannot happen, as a file * always provides a header. */ if(srcid != -1) user_head.init = 0; /* * Get a buffer for the user-defined online header. * * If the source image comes from shared memory, then the online header * contains the corresponding header values. * Read them from the online header, update them with the command header, * and write them to the correction routines. * * Otherwise, the online header is intended as output for the header values * of the corrected image. Ignore its values at this point. */ if(headid != -1) { cols = rows = 0; if((gbufstat = get_buffer(headid,NULL,&head_buf,&rows,&cols,HD_TYP)) == -1) goto analyse_args_cleanup; if(srcid != -1) { scanhead(HD_TYP,&user_head); set_headval(user_head,HD_TYP); /* * upd_headvalcmd updates the online header with the command header */ upd_headvalcmd( &user_head ); set_headval(user_head,SRCTYP); if(user_head.init & FL_DUMMY) set_dummy(user_head.Dummy); } /* * If there is no online header for this image, free its buffers. */ } else clean_buffer(&head_buf,HD_TYP,1); /* * Get a buffer for the input source image. This image must be acquired as the * first one, as the dimensions of all other images are checked against the * size of this image. */ cols = rows = 0; if((gbufstat = get_buffer(srcid,srcfile,&src_im,&rows,&cols,SRCTYP)) == -1) goto analyse_args_cleanup; /* * Bin and linearity-correct the input image if requested. Afterwards, free * the old source buffer if it has changed and if it is not a shared memory. */ if(gbufstat > 0) if(map_imag(src_im,&pnewbuf,(double)bin_1,(double)bin_2,SRCTYP) < 0) goto analyse_args_cleanup; if(src_im != pnewbuf) { if(srcid == -1 || current_shm_data[SRCTYP] != src_im) pfree(src_im); src_im = pnewbuf; get_headval(&user_head,SRCTYP); user_head.Dim_1 = cols /= bin_1; user_head.Dim_2 = rows /= bin_2; set_headval(user_head,SRCTYP); } set_xysize(cols,rows); /* * Get the filename for the dark image, and then get the dark image buffer. * Return an error if this fails. * * Also return an error if the dark file name is specified as keyword of the * source header but there is no source image file, as for the dark image the * keyword construct must not be used with source input from shared memory. */ if(get_filnam(&darkfile,darkbuf,darktmp,DRKTYP) < 0) { iret |= SPD_ERRFLG; goto analyse_args_cleanup; } if(darkfile != NULL && strchr(darkbuf,'[') != NULL && srcfile == NULL) { prmsg(ERROR,("no dark_file keyword search allowed for shared memory\n")); iret |= SPD_ERRFLG; goto analyse_args_cleanup; } /* * If the dark file name does not contain a directory path, use the one from * the source image file name. */ if(darkfile != NULL && srcfile != NULL && strchr(darkfile,'/') == NULL) { if((tmpnam1 = strrchr(srcfile,'/')) != NULL) { *tmpbuf1 = '\0'; strncat(tmpbuf1,srcfile,tmpnam1 - srcfile + 1); strcat(tmpbuf1,darkfile); strcpy(darkfile,tmpbuf1); } } /* * Get the buffer for the dark image, and hand it to the correction routines. * The buffer is only acquired if it is also needed afterwards (for correction * or dark bffer saving). */ if(do_dark != 0 || save_dark != 0) { if((gbufstat = get_buffer(darkid,darkfile,&dark_im,&rows,&cols,DRKTYP)) < 0) goto analyse_args_cleanup; /* * The dark image will only be saved if all of the following conditions are * fulfilled: * - the image comes from an online buffer; * - there is a file extension defined for it; * - the raw image is also to be saved; * - the "save_dark" command line argument is either 1 (save always) or it * is 2 (save if new) and the dark image is new. */ if(darkid != -1) { if(*dark_ext != '\0' && *src_ext != '\0' && (save_dark == 1 || save_dark == 2 && gbufstat == 1)) { if((outfile = outname(basnam,outdir,NULL,dark_ext)) == NULL) goto analyse_args_cleanup; if(put_buffer(outfile,NULL,rows,cols,DRKTYP) == 0) iret |= SPD_DRKFIL | SPD_BASUSE; else iret |= SPD_ERRFLG; strcpy(darkbuf,basename(outfile)); } /* * Add the filename of the saved dark image buffer to the online header. * If this dark image buffer is not to be saved, the filename is the name * of the last saved dark image buffer. */ edf_add_header_element(*(typestr + HD_TYP),"DarkFileName",darkbuf,&err, &status); } if(gbufstat == 1) set_imgbuf(dark_im,DRKTYP); } /* * If the command line option "src_ext" is set, save the input source image to * a file if it comes from a shared memory (if it comes from a file, there is * obviously no need to save it to a file again). * * Alternatively, if the command line option "head_ext" is set, save the * online header (only the header!) to a file. Again, this is not necessary if * the source image comes from a file, as a file always has its own header. */ if(srcid != -1) { if(*src_ext != '\0') { if((outfile = outname(basnam,outdir,NULL,src_ext)) == NULL) goto analyse_args_cleanup; if(put_buffer(outfile,NULL,rows,cols,SRCTYP) == 0) iret |= SPD_SRCFIL | SPD_BASUSE; else iret |= SPD_ERRFLG; } else if(*head_ext != '\0') { if((outfile = outname(basnam,outdir,NULL,head_ext)) == NULL) goto analyse_args_cleanup; if(put_buffer(outfile,NULL,rows,cols,HD_TYP) != 0) iret |= SPD_ERRFLG; } } /* * Get the file name(s) for the distortion correction and hand them to the * correction routines. Return an error if this fails. * If successful, set the value of the distortion correction parameter. */ if(do_dist) { if(*xfbuf != '\0' && *yfbuf != '\0') set_xycorin(xfbuf,yfbuf); else if(distfile != NULL && *distfile != '\0') { /* * Get the filename for the spline distortion coefficients. */ if(get_filnam(&distfile,distbuf,tmpbuf1,DISTYP) < 0) { iret |= SPD_ERRFLG; goto analyse_args_cleanup; } set_splinfil(distfile); } else { if (!do_prerot) do_dist = 0; } if(*xoutbuf != '\0' && *youtbuf != '\0') { /* * Get the output filenames for the x and y spatial distortion * displacement values. */ tmpnam1 = strcpy(tmpbuf1,outname(xoutbuf,outdir,NULL,NULL)); tmpnam2 = strcpy(tmpbuf2,outname(youtbuf,outdir,NULL,NULL)); set_xycorout(tmpnam1,tmpnam2); } if(*moutbuf != '\0') { /* * Get the output filenames for the x and y spatial distortion * displacement values. */ tmpnam1 = strcpy(tmpbuf1,outname(moutbuf,outdir,NULL,NULL)); set_moutfile(tmpnam1); } } if(do_dist == 1 && flat_aft == 0) do_dist = 2; set_dospd(do_dist); /* * Set the value of the prerotation parameter. */ set_doprerot(do_prerot); /* * Set the value of the prerotation normalization parameter. */ set_normprerot(norm_prerot); /* * Get the file names for the flood field and the scattering background image, * and then get the buffers and hand them to the correction routines. * Return an error if this fails. */ if(get_filnam(&flofile,flobuf,flotmp,FLOTYP) < 0) { iret |= SPD_ERRFLG; goto analyse_args_cleanup; } if((gbufstat = get_buffer(floid,flofile,&flo_im,&rows,&cols,FLOTYP)) == -1) goto analyse_args_cleanup; if(gbufstat == 1) set_imgbuf(flo_im,FLOTYP); if((gbufstat = get_buffer(bckgid,bckgfile,&bckg_im,&rows,&cols,SBKTYP)) == -1) goto analyse_args_cleanup; if(gbufstat == 1) set_imgbuf(bckg_im,SBKTYP); /* * All input data have been acquired now. Reset the "input data busy" flag. * This flag can be tested with the "getstate()" routine. */ inptbusy = 0; /* * Get a buffer for the corrected output image. */ if((gbufstat = get_buffer(corid,NULL,&cor_im,&rows,&cols,CORTYP)) == -1) goto analyse_args_cleanup; /* * Get the buffers for the azimuthal regrouping and averaging: * * - one buffer for the azimuthal regrouped output image; * - one buffer for the azimuthal averaged output image; * - one buffer for the mask defining the pixels to ignore for the azimuthal * calculations. * * The averaged output needs 4 rows in the buffer to provide the space for the * four azimuthal averaged values per radial value: * * - the "s" value; * - the average over all angular values; * - 2 values for the errors. * * If there are two start angles defined for the azimuthal averaging, then the * buffer needs 8 rows, 4 for each of the two angles. If, however, the shared * memory only provides space for 4 rows, the averaging is automatically set * to be performed only for one start angle. */ if(azimint == 1) { if((gbufstat = get_buffer(azim_id,NULL,&azim_im,&azim_anum,&azim_rnum, AZITYP)) == -1) goto analyse_args_cleanup; if(azim_a1fl == 0) rowtmp = 4; else rowtmp = 8; if((gbufstat = get_buffer(ave_id,NULL,&ave_im,&rowtmp,&azim_rnum,AVETYP)) == -1) goto analyse_args_cleanup; if(rowtmp == 4) azim_a1fl = 0; if(maskfile != NULL) if((gbufstat = get_buffer(-1,maskfile,&mask_im,&rows,&cols,MSKTYP)) == -1) goto analyse_args_cleanup; } /* * Get the buffer for the input image. Two cases are possible: * - input from file(s). There may be more than one input file specified; * - input from shared memory. * * Then do the corrections and (if requested) the azimuthal regrouping. */ do { /* * Set the "Dummy" value. * * "Dummy" is the value used to mark invalid pixels in the output * image. It is defined by (in increasing order of precedence) * - the "Dummy" value in either: * -- the input source image (for input from files) * -- the online header (for input from shared memory); * - the value of the "dummy" parameter on the command line. * * If none of these is set, the default value is Dummy = 0. * * Note: * - for files, the input source image is read in read_esrf_file(). * This also gets and sets the header values and "Dummy"; * - for shared memory, the "Dummy" value is obtained and set when the * online header is read. * * Thus only the "dummy" from the command line needs to be dealt with * here. */ if(dummy_set != 0) set_dummy(dummy); /* * If any of the command line options pix_1, pix_2, cen_1, cen_2, off_1, * off_2, bis_1, bis_2, dis, pro, rot_1, rot_2 or rot_3 were given, these * values take precedence over the values set in the distortion file, even * if psize_distort is set. Modify the value set for the correction * routine accordingly with the set_dstrtval() call. */ if(cmd_head.init != 0 && psize_distort) { dstrt_tmp &= ~cmd_head.init; set_dstrtval(dstrt_tmp); } if(srcfile) { /* * Case 1: input from file(s). This is typically the case when the program * is run offline. * * There can be more than one file name specified in the input arguments. * The program loops over all input files, performs the corrections, and * writes the data to the output files. * * There is only one set of correction parameters for all input files, * thus in principle the same corrections are applied to all source files. * However, there are some exceptions to that: * - dark image subtraction; * - distortion correction; * - flood field correction. * * For these, the corresponding input argument can specify that the name * of the file containing the correction is to be obtained from a keyword * in the source image header. Thus these corrections could be different * for each input file. For more details, see description of the input * arguments "dark_file, "distortion_file" and "flood_file". * * The header values for the corrected image are pre-set by the file * header of the input source image. Any online header is ignored. * * The names of the output files are derived from the names of the * corresponding input files by replacing the string contained in * "src_ext" with the string in "cor_ext". These two strings can be * defined by the user. For details about the generation of the name, see * routine outname(). * * The output file name that might have been defined by the user with the * (obsolete) option "cor_file" is not used. * * Note that it is in principle possible to have the program write the * output data also to shared memory. However, if there is more than one * input file to be processed, the second output image will overwrite the * first, etc., as there is only one shared memory segment for output. * * If the correction routines return an error for at least one of the * input files, analyse_args() will return an error. However, processing * of files does not stop when the error is encountered, thus subsequent * input files might be corrected successfully. */ prmsg(DMSG,("command line input file = %s\n",srcfile)); tmpnam1 = strrchr((const char *)srcfile,(int)'/'); if(tmpnam1 == NULL) tmpnam1 = srcfile; else tmpnam1++; /* * Do not try to do corrections if there is no input. */ if(src_im == NULL) continue; /* * Generate output file name, respecting the following conditions: * * - do not store corrected image if "cor_ext" is an empty string; * - signal error if no output file name could be created; * - ignore cases where the input file name would be identical to the * output file name, i.e. where the input file would be overwritten. */ if(*cor_ext == '\0') outfile = NULL; else if((outfile = outname(tmpnam1,outdir,src_ext,cor_ext)) == NULL) iret |= SPD_ERRFLG; else if(strcmp(outfile,tmpnam1) == 0) continue; prmsg(MSG,("Correcting: %s\n --> %s\n",srcfile,outfile)); } else if(srcid != -1) { /* * Case 2: input from shared memory. This is typically the case when the * program is run online. Only one input image is then possible for each * call to "analyse_args()". The output can be to a file, a shared memory, * or both. * The name of the output file is derived from "base_name" with the * extension "cor_ext". Both can be set by the user. * * The name of the output file can also be set with the obsolete option * "cor_file". * * Note that the flags of user_head have been cleared and set earlier. If * there is no online header, the input and output header values will just * have the default values. No "old" header values from previous images * will be kept. */ prmsg(DMSG,("Correcting online image [%d,%d]\n",rows,cols)); outfile = corfile; tmpnam1 = basnam; if(*cor_ext != '\0' && (outfile = outname(tmpnam1,outdir,src_ext,cor_ext)) == NULL) iret |= SPD_ERRFLG; } else /* * Neither input files nor input from shared memory. Ignore, probably * user error. */ break; prmsg(DMSG,("Image buffers: cor = %p, src = %p, drk = %p, flo = %p\n", cor_im,src_im,dark_im,flo_im)); /* * Do the correction. * * If successful: * * - copy the history information assembled in the intermediate "histsave" * buffer to the "corrected" history block; * - if the source image input is from a file, add its filename; * - add the history information from the input image header; * - write the corrected image and all its history information to output. * * If not successful, print an error message and set the return value of * the routine to indicate an error. */ if(correct_image(cor_im,src_im) == 0) { edf_history_copy(*(typestr + CORTYP),histargs); if(srcfile) { strcpy(tmpbuf2,tmpnam1); edf_history_argv(*(typestr + CORTYP),basename(tmpbuf2)); } if(!edf_history_read_header(*(typestr + HD_TYP),*(typestr + CORTYP),&err, &status) || status != status_success) { prmsg(ERROR,("error reading history from header data\n")); iret |= SPD_ERRFLG; } if(put_buffer(outfile,&cor_im,rows,cols,CORTYP) != 0) iret |= SPD_ERRFLG; else if(outfile != NULL) { iret |= SPD_CORFIL; if(srcid != -1) iret |= SPD_BASUSE; } /* * Azimuthal regrouping and averaging. */ if(azimint == 1) { /* * Transfer the dummy values from the mask file to the input file for * the azimuthal calculations. */ if(maskfile != NULL) mark_overflow_nocorr(mask_im,cor_im,NULL,MSKTYP); /* * Do averaging over one or two angle ranges as requested. The second * averaging goes into the same buffer with an offset of 4 rows. */ if((azim_int(cor_im,azim_im,ave_im,azim_r0,azim_rnum, azim_a0*NUM_PI/180.0, azim_da*NUM_PI/180.0, azim_anum,azim_pro,ave_scf,verbose) != 0) || (azim_a1fl == 1 && azim_int(cor_im,azim_im,ave_im + 4 * azim_rnum * sizeof(float), azim_r0,azim_rnum,azim_a1*NUM_PI/180.0,azim_da*NUM_PI/180.0, azim_anum,azim_pro,ave_scf,verbose)!=0)){ /* * Error for azimuthal regrouping and averaging. */ iret |= SPD_ERRFLG; prmsg(ERROR,("regrouping routine failed\n")); } else { edf_history_copy(*(typestr + AZITYP),*(typestr + CORTYP)); edf_add_header_element(*(typestr + AZITYP),"AxisType_2","Angle",&err, &status); outfile = NULL; if(*azim_ext != '\0' && (outfile = outname(tmpnam1,outdir,src_ext, azim_ext)) == NULL) iret |= SPD_ERRFLG; if(put_buffer(outfile,&azim_im,azim_anum,azim_rnum,AZITYP) != 0) iret |= SPD_ERRFLG; else if(outfile != NULL) { iret |= SPD_AZIFIL; if(srcid != -1) iret |= SPD_BASUSE; } outfile = NULL; if(*ave_ext != '\0' && (outfile = outname(tmpnam1,outdir,src_ext, ave_ext)) == NULL) iret |= SPD_ERRFLG; if(put_buffer(outfile,&ave_im,rowtmp,azim_rnum,AVETYP) != 0) iret |= SPD_ERRFLG; else if(outfile != NULL) { iret |= SPD_AVEFIL; if(srcid != -1) iret |= SPD_BASUSE; } } } } else { iret |= SPD_ERRFLG; prmsg(ERROR,("correction routines failed\n")); } /* * End of processing for this input image. * * If there are no more file names on the input line, then the processing * stops here ("lcont" is false). * * If there are still file names on the input line, read the next image. * If this results in an error (get_buffer() < 0), then skip this file and * continue with the remaining ones (while there are any left). * * If a file has been successfully read, then process it. If this is a newly * acquired buffer (get_buffer() > 0), then it may need to be mapped first. * If mapping fails, skip this file and continue with the remaining ones. */ while(lcont = fnampat(srcbuf,sizeof(srcbuf),argc - argn,argv + argn) == 0) { if((gbufstat = get_buffer(-1,srcfile,&src_im,&rows,&cols,SRCTYP)) < 0) continue; if(gbufstat > 0) { if(map_imag(src_im,&pnewbuf,(double)bin_1,(double)bin_2,SRCTYP) < 0) continue; if(src_im != pnewbuf) { clean_buffer(&src_im,SRCTYP,1); src_im = pnewbuf; get_headval(&user_head,SRCTYP); user_head.Dim_1 = cols /= bin_1; user_head.Dim_2 = rows /= bin_2; set_headval(user_head,SRCTYP); } set_xysize(cols,rows); } // if(gbufstat > 0) /* * Get a buffer for the corrected output image. */ if(get_buffer(-1,NULL,&cor_im,&rows,&cols,CORTYP) == -1) goto analyse_args_cleanup; /* * Get the image file name for the dark image or flood file correction * from the keyword in the source file header, if requested. * * Then test if the corresponding buffer needs to be re-allocated. This * could be the case due to a different binning of the source image, even * if the dark or flood file has not changed. * * If any of this fails, continue with the next source image. */ if(get_filnam(&darkfile,darkbuf,darktmp,DRKTYP) < 0) continue; /* * If the dark file name does not contain a directory path, use the one * from the source image file name. */ if(darkfile != NULL && strchr(darkfile,'/') == NULL) { if((tmpnam1 = strrchr(srcfile,'/')) != NULL) { *tmpbuf1 = '\0'; strncat(tmpbuf1,srcfile,tmpnam1 - srcfile + 1); strcat(tmpbuf1,darkfile); strcpy(darkfile,tmpbuf1); } } // if(darkfile ... if((gbufstat = get_buffer(-1,darkfile,&dark_im,&rows,&cols,DRKTYP)) < 0) continue; if(gbufstat == 1) set_imgbuf(dark_im,DRKTYP); if(get_filnam(&flofile,flobuf,flotmp,FLOTYP) < 0) continue; if((gbufstat = get_buffer(-1,flofile,&flo_im,&rows,&cols,FLOTYP)) < 0) continue; if(gbufstat == 1) set_imgbuf(flo_im,FLOTYP); /* * Test if the scattering background image buffer needs to be * re-allocated (same argument as for dark and flood file above). */ if((gbufstat = get_buffer(-1,bckgfile,&bckg_im,&rows,&cols,SBKTYP)) < 0) continue; if(gbufstat == 1) set_imgbuf(bckg_im,SBKTYP); /* * Get (if required) the filename for the spline distortion coefficients * from a keyword in the source file header and hand it to the correction * routines. * * If this fails, continue with the next source image. */ if(do_dist) { if(get_filnam(&distfile,distbuf,tmpbuf1,DISTYP) < 0) continue; set_splinfil(distfile); } // if(do_dist) /* * All requested files obtained for this image, do the correction. */ break; } } while(lcont); analyse_args_cleanup: /* * We detach from shared memory here. * * In addition, the buffers will be freed for all output data types. */ if(gbufstat == -1) iret |= SPD_ERRFLG; clean_buffer(&src_im,SRCTYP,0); clean_buffer(&cor_im,CORTYP,1); clean_buffer(&dark_im,DRKTYP,0); clean_buffer(&flo_im,FLOTYP,0); clean_buffer(&bckg_im,SBKTYP,0); clean_buffer(&head_buf,HD_TYP,0); clean_buffer(&azim_im,AZITYP,1); clean_buffer(&ave_im,AVETYP,1); clean_buffer(&mask_im,MSKTYP,0); print_memsize(); ihistnew = 1; analyse_args_return: if((iret & SPD_ERRFLG) != 0) { errno = 0; prmsg(ERROR,("image processing did not succeed\n")); } prmsg(DMSG,("analyse_args return status is %#x\n",iret)); return(iret); } /* analyse_args */ /*============================================================================== * Print out a help text describing the command line options of the program. * * Input: none * Output: none * Return: none */ void help_arg(void) { #define PRNTHELP(x) prmsg(MSG,(" " x "\n")) #define PRNTHLPN(x) prmsg(MSG,("\n " x "\n")) PRNTHELP("src_id="); PRNTHELP("src_ext= (default none)"); PRNTHLPN("cor_id="); PRNTHELP("cor_ext= (default: \".cor.edf\")"); PRNTHLPN("type= (default \"FloatIEEE32\")"); PRNTHELP("dvo= data value offset (default 0)"); PRNTHLPN("dark_id="); PRNTHELP("dark_file="); PRNTHELP("dark_const= subtract constant dark image value"); PRNTHELP(" (default: no dark image subtraction done)"); PRNTHELP("dark_ext= (default none)"); PRNTHELP("do_dark=0|1 if 0, suppress dark image correction (default 0)"); PRNTHELP("save_dark=0|1|2 save dark image memory to file"); PRNTHELP(" 0: never, 1: always, 2: only if new (default 2)"); PRNTHELP("inp_const= add input image constant (default 0.)"); PRNTHELP("inp_exp= apply exponent to input image (default 1.)"); PRNTHELP("inp_factor= multiply with input image factor (default 1.)"); PRNTHELP("raw_cmpr=\"none\"|\"gzip\"|\"z\" compression of raw & dark images (default none) "); PRNTHLPN("flood_id="); PRNTHELP("flood_file="); PRNTHELP(" (default: no flood field used)"); PRNTHLPN("bckg_id="); PRNTHELP("bckg_file="); PRNTHELP(" (default: no scattering background used)"); PRNTHELP("bckg_const= (default 0.)"); PRNTHELP("bckg_fact= (default 1.)"); PRNTHLPN("header_id= (default: not used)"); PRNTHELP("pass=0|1 pass input file header to output (default 0)"); PRNTHELP("header_min= (default 0)"); PRNTHELP("header_ext= (default none)"); PRNTHLPN("distortion_file= (default \"spatial.dat\")"); PRNTHELP("xfile= (x distortion read from edf file)"); PRNTHELP("yfile= (y distortion read from edf file)"); PRNTHELP("xoutfile= (x distortion saved to edf file)"); PRNTHELP("youtfile= (y distortion saved to edf file)"); PRNTHELP("active_radius= (values outside will not be corrected)"); PRNTHELP("precen_1=xxx for pre-rotation center_1 (default calculated)"); PRNTHELP("precen_2=xxx for pre-rotation center_2 (default calculated)"); PRNTHELP("predis=xxx for pre-rotation distance (default calculated)"); PRNTHELP("prerot_1= (default 0.)"); PRNTHELP("prerot_2= (default 0.)"); PRNTHELP("prerot_3= (default 0.)"); PRNTHLPN("psize_distort=0|1|2 take image params from distortion file"); PRNTHELP(" 0: none, 1: pix, 2: pix, cen, dis, proj, rot (default 0)"); PRNTHELP("cen_1=xxx if set, defines Center_1 header value"); PRNTHELP("cen_2=xxx if set, defines Center_2 header value"); PRNTHELP("i0=xxx if set, defines Intensity0 header value"); PRNTHELP("i1=xxx if set, defines Intensity1 header value"); PRNTHELP("off_1=xxx if set, defines Offset_1 header value"); PRNTHELP("off_2=xxx if set, defines Offset_2 header value"); PRNTHELP("pix_1=xxx if set, defines PSize_1 header value"); PRNTHELP("pix_2=xxx if set, defines PSize_2 header value"); PRNTHELP("bis_1=xxx if set, defines BSize_1 header value"); PRNTHELP("bis_2=xxx if set, defines BSize_2 header value"); PRNTHELP("dis=xxx if set, defines SampleDistance header value"); PRNTHELP("ori=xxx if set, defines RasterOrientation header value"); PRNTHELP("tit=xxx if set, defines Title header value"); PRNTHELP("wvl=xxx if set, defines WaveLength header value"); PRNTHELP("pro=\"Saxs\"|\"Waxs\" projection type of image (default Saxs)"); PRNTHELP("rot_1= (default 0.)"); PRNTHELP("rot_2= (default 0.)"); PRNTHELP("rot_3= (default 0.)"); PRNTHLPN("base_name= (default \"image\")"); PRNTHLPN("outdir= directory for output files (default: base_name)"); PRNTHELP("verbose=-1|0|1|2 message printing level (low -> high, default 1)"); PRNTHELP("version=0|1 print version string of the program if != 0"); PRNTHELP("simul=0|1 (default 0)"); PRNTHELP("do_distortion=0|1|2|3|4 distortion correction (default 1)"); PRNTHELP(" (0: none, 1: after dark, 2: after flat, 3: after norm, 4: after background)"); PRNTHELP("flat_distortion=0|1 normalize to flat image (default 1)"); PRNTHELP("do_prerotation=0|1|2 pre-rotation correction (default 0)"); PRNTHELP(" (0: none, 1: after, 2: without distortion correction)"); PRNTHELP("norm_prerotation=0|1 renormalization to spherical angle (default 1)"); PRNTHELP("norm_int=0|1|2|3 intensity normalization (default 0)"); PRNTHELP(" (0: none, 1: full, 2: to Intensity1, 3: to spherical angle"); PRNTHELP("norm_factor= (default 1.)"); PRNTHLPN("overflow=xxx (default 0 = not set)"); PRNTHELP("dummy= (default 0. = not set)"); PRNTHELP("inp_min= (default 0. = not set)"); PRNTHELP("inp_max= (default 0. = not set)"); PRNTHELP("bin_1= factor for x-binning (default 1 = no binning)"); PRNTHELP("bin_2= factor for y-binning (default 1 = no binning)"); PRNTHLPN("azim_int=0|1 azimuthal regrouping (default 0 = no)"); PRNTHLPN ("azim_pass=0|1 pass full header to azimuthal regrouping (def. 1 = yes)"); PRNTHELP ("azim_pro=\"Saxs\"|\"Waxs\" project. type of azim. regrp. (default Saxs)"); PRNTHELP("azim_id= (default -1)"); PRNTHELP("azim_ext= (default: \".azim.edf\')"); PRNTHELP("azim_r0= minimum regrouping radius (default 0.)"); PRNTHELP("azim_r_num= radial output size (default 0)"); PRNTHELP("azim_a0= 1st regrouping start angle (default 0.)"); PRNTHELP("azim_a1= 2nd regrouping start angle (default: not used)"); PRNTHELP("azim_da= angular regrouping interval (default 1.)"); PRNTHELP("azim_a_num= angular output size (default 0)"); PRNTHELP("ave_id= (default -1)"); PRNTHELP("ave_ext= (default none)"); PRNTHELP("ave_scf= (default 1.)"); PRNTHELP("mask_file="); PRNTHELP(" (default: not used)"); PRNTHLPN("clear=0|1 reset all command options (default 0)"); PRNTHLPN("--server switch to server mode, i.e. wait for"); PRNTHELP(" new command/image to process on stdin"); PRNTHLPN("--exit quit the program when we are on server mode."); } /*============================================================================== * Write header and data to an output data file. * * The data contained in the input argument buffer "data" is written to the * output file with the name "fname". The raw data is preceded by the data file * header. * * The header always contains at least the following keywords: EDF_DataBlockID, * EDF_BinarySize, HeaderID, ByteOrder, DataType, Dim_1, Dim_2. * Additional keywords may be contained in the input string "header", and if * so, will be written to the data file header as well. * * If any of the following operations fails, the routine will return an error: * - the output file cannot be opened; * - there is an error adding the additional keywords from the "header" input * argument to the output data file; * - there is an error during the writing of the data. * * * Input : fname: name of the output data file * data: buffer containing the data to be written to the output file * rows: number of elements in the second dimension of the image (this * is the "slow-moving" index, i.e. the first index in a two- * dimensional C data buffer) * cols: number of elements in the first dimension of the image (this * is the "fast-moving" index, i.e. the second index in a two- * dimensional C data buffer) * type : type of file to be written (source, flood field, ...) * mtype: type of data to be written. For possible values, see the enum * variable "MType" in "edfio.h" * Output: none * Return: -1 if error * 0 else */ int save_esrf_file(char *fname,void *data,int rows,int cols,int type,int mtype) { int err,stream,status; long DataNumber = 1; long dim[3]; /* * Create a new output file or, if it already exists, overwrite it. Then open * the file. * * Return with error if this fails. */ if((stream = edf_open_data_file(fname,"new",&err,&status)) == -1) { prmsg(ERROR,("Error opening file \"%s\".\n",fname)); return(-1); } /* * Write the header and the data to the data file. * * The following keywords are automatically written by edf_write_data(): * * - EDF_DataBlockID (and the old keyword Image, which is equivalent to the * "sequence" part of EDF_DataBlockID) * - EDF_BinarySize (and the old equivalent keyword Size) * - EDF_HeaderSize * - the old keyword HeaderID * - ByteOrder * - DataType * - Dim_1 * - Dim_2 * - Compression * - Image * * Additional keywords may be contained in the internal header buffer. This * is filled from the header shared memory for online source images or from * the file header for input source files. It also contains the history * keywords describing the actions that this correction program has performed * with the data. * * The internal header buffer will be written here. Return with error if this * fails. */ if(!edf_write_header(stream,DataNumber,1,*(typestr + type),&err,&status) && err != CouldNotFindKeyword) { prmsg(ERROR,("Error obtaining %s data header from internal buffer.\n", *(typestr + type))); goto save_esrf_file_error; } /* * Write the data. Return with error if this fails. */ if(data != NULL) { dim[0] = 2; dim[1] = cols; dim[2] = rows; if( ((type == SRCTYP) || (type == DRKTYP)) ) { edf_set_datacompression(raw_cmpr); if (raw_cmpr!=UnCompressed) prmsg(DMSG,("Writing %s to file \"%s\" with compression %s.\n", *(typestr + type),fname,edf_compression2string(raw_cmpr))); } edf_write_data(stream,DataNumber,1,dim,data,mtype,&err,&status); edf_set_datacompression(UnCompressed); if(status) { prmsg(ERROR,("Error writing image data to file: \"%s\".\n",fname)); goto save_esrf_file_error; } } edf_close_data_file(stream,&err,&status); return(0); save_esrf_file_error: prmsg(ERROR,("Error producing output data file: \"%s\".\n",fname)); edf_close_data_file(stream,&err,&status); return(-1); } /* save_esrf_file */ /*============================================================================== * Read header and data of an input data file. * * The data file header is read to obtain the information on the number of * rows and columns of the input image, the total size in bytes and the byte * ordering scheme used when storing the data. * * The dimensions of the buffer ("rows" and "columns") are set from the * dimensions of the input image. * * Then the image data are read from the input file into a data buffer that is * returned to the calling program. If a buffer of suitable size is provided in * the input arguments, it is used, else a buffer will be allocated. * * If any of these operations fails, the routine will return an error * indication and the "err" variable will be set to reflect the error that * occurred. * * Input : fname: name of the input data file * type : type of file to be read (source, flood field, ...) * mtype: requested type of data to be read. For possible values, see * the enum variable "MType" in "edfio.h" * Output: data: new buffer containing the data read from the input data file * rows: number of elements in the second dimension of the image (this * is the "slow-moving" index, i.e. the first index in a two- * dimensional C data buffer) * cols: number of elements in the first dimension of the image (this is * the "fast-moving" index, i.e. the second index in a two- * dimensional C data buffer) * err: error indicator. Only meaningful if there is an error. Values: * - 1 if the data header could not be obtained correctly * - 3 if the data record could not be obtained correctly * Return: -1 if error * 0 else */ int read_esrf_file(char *fname,void **data,int *rows,int *cols,int type, int mtype,int *err) { static char bytebuf[EdfMaxLinLen + 1]; char *ptypestr = *(typestr + type); int stream,status; long *dim = NULL; long MinNum,MaxNum; size_t datasize; struct data_head user_head; /* * Open data file and read the file header. Return with error if this fails. */ if((stream = edf_open_data_file(fname,"read",err,&status)) == -1) { prmsg(ERROR,("Error opening file \"%s\".\n",fname)); return(-1); } edf_search_minmax_number(stream,1,&MinNum,&MaxNum,err,&status); /* * Get the values for a certain number of keywords from the header. * * The values for the following keywords are required: * * - DIM_1 number of elements (of type DATATYPE) in the first dimension * of the input data array (= number of columns) * - DIM_2 number of elements (of type DATATYPE) in the second dimension * of the input data array (= number of rows) * * If the keywords cannot be found or the values not be read, return an error. * */ /* * This call gets the values of DIM_1 and DIM_2 and returns them in the array * elements dim[1] and dim[2], and it gets the total size in byte of the data * to be read. */ edf_read_data_dimension(stream,MinNum,1,&dim,&datasize,err,&status); if(status != status_success) { goto badheader; } if(!edf_read_header_line(stream,MinNum,1,"DATATYPE",bytebuf,err,&status) || status != status_success) goto badheader; datasize = datasize * edf_machine_sizeof(mtype) / edf_data_sizeof(edf_string2datatype(bytebuf)); /* * Clear the internal header and history buffers and then read the entire file * header and history of the input file into them. * * For the source type image, also put the file header and history into the * internal buffers of type HD_TYP. This is to make it analogous to the * processing of the "spec" online header, which is always put in the HD_TYP * buffer. They will then be written to the corrected output image file. */ if(!edf_new_header(ptypestr) || !edf_read_header(stream,MinNum,1,ptypestr,err, &status) || status != status_success || !edf_history_new(ptypestr) || !edf_read_header_history(stream,MinNum,1, ptypestr,err,&status) || status != status_success) goto badheader; if(type == SRCTYP) { if(!edf_new_header(*(typestr + HD_TYP)) || !edf_read_header(stream,MinNum,1, *(typestr + HD_TYP),err,&status) || status != status_success || !edf_history_new(*(typestr + HD_TYP)) || !edf_read_header_history(stream, MinNum,1,*(typestr + HD_TYP),err,&status) || status != status_success) goto badheader; } /* * Search the header for the values to be put in the header structure for the * image "type". */ scanhead(type,&user_head); /* * Transfer header structure to the correction routines. * * If a particular keyword was found and the value is valid, then it sets the * corresponding value in the global variables. If not, then the previous * value of the global variable is kept. This is not an error condition. */ set_headval(user_head,type); /* * Set the "dummy" value for the output image from the input source image, if * "dummy" is defined there. */ if(type == SRCTYP && user_head.init & FL_DUMMY) set_dummy(user_head.Dummy); /* * If the output data buffer is NULL, allocate a data buffer with the required * size as determined in the call to edf_read_data_dimension() above. * * Then read the data. * * Return with error if any of these operations fails. */ if(*data == NULL && (*data = (void *)pmalloc(datasize)) == NULL) { prmsg(ERROR,("Cannot allocate %d bytes\n",datasize)); *err = 3; edf_close_data_file(stream,err,&status); return(-1); } edf_read_data(stream,MinNum,1,&dim,&datasize,data,mtype,err,&status); if(status) { *err = 3; prmsg(ERROR,("Error reading file \"%s\".\n",fname)); edf_close_data_file(stream,err,&status); return(-1); } *cols = dim[1]; *rows = dim[2]; edf_close_data_file(stream,err,&status); return(0); /* * Error return in case of problems with the header. */ badheader: *err = 1; edf_close_data_file(stream,err,&status); return(-1); } spd-1.3.0/src/spd.h0000644000175000017500000010006711655560076010767 00000000000000/* * Project: The SPD Image correction and azimuthal regrouping * http://forge.epn-campus.eu/projects/show/azimuthal * * Copyright (C) 2001-2010 European Synchrotron Radiation Facility * Grenoble, France * * Principal authors: P. Boesecke (boesecke@esrf.fr) * R. Wilcke (wilcke@esrf.fr) * * This program is free software: you can redistribute it and/or modify * it under the terms of the GNU Lesser General Public License as published * by the Free Software Foundation, either version 3 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU Lesser General Public License for more details. * * You should have received a copy of the GNU General Public License * and the GNU Lesser General Public License along with this program. * If not, see . */ /* Update 21/10/2011 P. Boesecke (boesecke@esrf.fr) Flag NO_SHARED_MEMORY added to allow compilation with mingw on Windows (cygwin flag -mno-cygwin). If set, do not use shared memories, strlib included from edfpack. two POSIX functions missing in mingw: strtok, strtok_r. They must be replaced by other functions to use mingw. Update 18/10/2011 P. Boesecke (boesecke@esrf.fr) INVALID_TYP added, TMPTYP added. Update 14/10/2011 P. Boesecke (boesecke@esrf.fr) new data type SDMTYP: this array contains multiplication factors that must be applied after spatial distortion correction to the corrected image. It is created together with SDXTYP and SDYTYP, set_moutfile added, get_doprerot added. Update 23/09/2011 P. Boesecke (boesecke@esrf.fr) subtract_im renamed to subtract_drk new subtract_im function added. Update 12/09/2011 P. Boesecke (boesecke@esrf.fr) set_prerot_headval added Update 31/08/2011 P. Boesecke (boesecke@esrf.fr) add include of cmpr.h Update 19/08/2011 P. Boesecke (boesecke@esrf.fr) Version set to spd-1-5 (prerotation) The prerotation correction needs to be tested, all existing functionality of version spd-1-4 should work as before. Update 27/07/2011 P. Boesecke (boesecke@esrf.fr) add include of sx.h, getShmDataPtr added Update 22/07/2011 P. Boesecke (boesecke@esrf.fr) rearrangement of code and renaming of functions (see correct.c). Version set to spd-1-4 Update 03/06/2010 P. Boesecke (boesecke@esrf.fr) add 2 new input arguments to function declaration azim_int(). Update 16/11/2009 R. Wilcke (wilcke@esrf.fr) move the definitions of the SPD return code here from routine "analyse_args()" in file "inout.c". Update 06/10/2009 P. Boesecke (boesecke@esrf.fr) replaced include SaxsDefinition.h => reference.h added include project.h angle.h (works with saxspack>=V2.440 and edfpack>=E2.169) Update 30/09/2009 R. Wilcke (wilcke@esrf.fr) add input argument to function declaration prntvers(). Update 26/08/2009 R. Wilcke (wilcke@esrf.fr) add function declaration getstate(). Update 25/08/2009 R. Wilcke (wilcke@esrf.fr) add function declaration prntvers(). Update 24/04/2009 R. Wilcke (wilcke@esrf.fr) add new input argument (char *) to the "outname" declaration. Update 16/02/2009 A. Gotz (andy.gotz@esrf.fr) To allow compilation with cpp compiler all C-function included into extern "C" {} __cplusplus added to allow compilation with gcc Update 22/01/2008 R. Wilcke (wilcke@esrf.fr) add function declaration region_compare(). Update 17/12/2007 R. Wilcke (wilcke@esrf.fr) add a fifth argument to scale_im(). Update 06/12/2007 R. Wilcke (wilcke@esrf.fr) add include of "filename.h"; add function declaration fnampat(). Update 28/11/2007 R. Wilcke (wilcke@esrf.fr) add a fourth argument to expon_im(). Update 10/10/2007 R. Wilcke (wilcke@esrf.fr) add new image type DISTYP; rename "flatfield" to "floodfield" in "typestr" array. Update 10/04/2007 R. Wilcke (wilcke@esrf.fr) add function declaration set_dodark(). Update 13/02/2007 R. Wilcke (wilcke@esrf.fr) remove special enumerated data for header value updating; add new image type CMDTYP. Update 26/09/2006 R. Wilcke (wilcke@esrf.fr) modify declaration of mark_overflow_nocorr() for additional argument; add declarations of set_inpexp() and expon_im(). Update 11/08/2006 R. Wilcke (wilcke@esrf.fr) include "ipol.h" for additional SAXS definitions. Update 19/08/2005 R. Wilcke (wilcke@esrf.fr) define macro RELTABSH instead of RELTABSIZE. Update 25/01/2005 R. Wilcke (wilcke@esrf.fr) add a whole new set of "Dis" parameters to the user header data structure for the displaced parameters; add Offset_1, Offset_2, BSize_1 and BSize_2 to the enumeration data for the header value updating. Update 24/01/2005 R. Wilcke (wilcke@esrf.fr) remove definition of TEMP_BUF_SIZE; add definition of RAD2DEG(). Update 13/01/2005 R. Wilcke (wilcke@esrf.fr) change "headkey" words Psize_1 -> PSize_1, Psize_2 -> PSize_2; remove declaration of set_dolater(); add declarations for new header elements "ProjectionType", "DetectorRotation_1", "DetectorRotation_2" and "DetectorRotation_3": flags FL_PRO, FL_ROT1, FL_ROT2 and FL_ROT3, members ProjTyp, DetRot_1, DetRot_2 and DetRot_3 for structure "data_head", "ProjectionType", "DetectorRotation_1", "DetectorRotation_2", "DetectorRotation_3" strings in string array "headkey"; add more values in the enumeration data type for updating of header values from the distortion file or from the command line; remove last input argument from the azim_int() declaration. Update 21/09/2004 R. Wilcke (wilcke@esrf.fr) change name bin_imag() to map_imag(). Update 25/08/2004 R. Wilcke (wilcke@esrf.fr) add parameter to the azim_int() declaration to calculate the scattering vector for images that have been projected to the Ewald sphere; add enumeration data type for updating certain header values from the distortion file or from the command line; change name of routine set_psizdist() to set_dstrtval(). Update 24/08/2004 R. Wilcke (wilcke@esrf.fr) include "numio.h"; add flags FL_TITLE, FL_TIME and FL_EXTIML to macro FL_IMAGE and remove flags FL_ORIEN, FL_DUMMY, FL_DDUMM, FL_PSIZ1 and FL_PSIZ2. Update 29/03/2004 R. Wilcke (wilcke@esrf.fr) add declarations for new header elements "BSize_1" and "BSize_2": flags FL_BSIZ1 and FL_BSIZ2, members BSize_1 and BSize_2 for structure "data_head", "BSize_1" and "BSize_2" strings in string array "headkey"; add declarations for new header elements "Dim_1" and "Dim_2" (as above for "BSize_1" and "BSize_2"); add FL_BSIZ1 and FL_BSIZ2 to FL_IMAGE; make members "init" and "Orientat" in structure "data_head" type "long" instead of "short"; replace function definitions set_bckgim(), set_drkim() and set_floim() by set_imgbuf(); remove definition of LOW_MEM macro (no longer used). Update 19/03/2004 R. Wilcke (wilcke@esrf.fr) add function declaration bin_imag(). Update 29/01/2004 R. Wilcke (wilcke@esrf.fr) removed the conditional code that depended on macro MY_TIMEVAL (definition of structures "timeval" and "timezone"). Update 14/01/2004 R. Wilcke (wilcke@esrf.fr) add handling of variable length argument list with "stdarg" for ANSI C compilers (include "stdarg.h" and different function declaration for _prmsg()). Update 21/07/2003 R. Wilcke (wilcke@esrf.fr) add a second argument to the set_normint() function. Update 26/11/2002 R. Wilcke (wilcke@esrf.fr) change type of set_psizdist() from "void" to "int"; add image type MSKTYP for "mask" data (a mask defining the pixels to ignore in azimuthal integration). Update 26/09/2002 R. Wilcke (wilcke@esrf.fr) remove declaration of routine set_verbose(); define new message type macro PRERR. Update 17/09/2002 R. Wilcke (wilcke@esrf.fr) declare functions unloadspd() and area_only() as "void". Update 05/09/2002 R. Wilcke (wilcke@esrf.fr) add member "ExpTime" to structure "data_head" and define corresponding flag; convert members "Intens_0" and "Intens_1" of structure "data_head" from "float" to "character string". Update 03/09/2002 R. Wilcke (wilcke@esrf.fr) rename enumerated variable BKGTYP to DRKTYP; change function names set_bkgconst() and set_bkgim() to set_drkconst() and set_drkim(); rename enumerated variable SCATYP to SBKTYP; change function names set_scaconst(), set_scafact() and set_scaim() to set_bckgconst(), set_bckgfact and set_bckgim(); Update 13/06/2002 R. Wilcke (wilcke@esrf.fr) include instead of . Update 03/06/2002 R. Wilcke (wilcke@esrf.fr) include header file. Update 12/03/2002 R. Wilcke (wilcke@esrf.fr) move declaration of global variable "typestr" and definition of macro MAXTYP from "inout.c" to this file; replace data type SPDTYP by the two new data types SDXTYP and SDYTYP. Update 05/03/2002 R. Wilcke (wilcke@esrf.fr) remove structure member "lut_d->temp_im" (no longer used); add members "Title" and "Time" to structure "data_head" and define the corresponding flags FL_TITLE and FL_TIME. Update 04/03/2002 R. Wilcke (wilcke@esrf.fr) rename global variable NO_TYP to HD_TYP. Update 20/12/2001 R. Wilcke (wilcke@esrf.fr) remove last argument (title) in save_esrf_file() declaration and add "type" as new 5th argument. Update 19/12/2001 R. Wilcke (wilcke@esrf.fr) remove the last input argument in the declaration of save_esrf_file(); define macro FL_IMAGE as a combination of several header keyword flags. Update 10/12/2001 R. Wilcke (wilcke@esrf.fr) add definition of user header type AVETYP. Update 03/12/2001 R. Wilcke (wilcke@esrf.fr) add the averaging buffer and the scale factor to the input arguments of the azim_int() declaration. Update 29/11/2001 R. Wilcke (wilcke@esrf.fr) add "rows" and "cols" as input arguments to get_buffer(); change some "headkey" key words: PSize_1 -> Psize_1, PSize_2 -> Psize_2, Orientation -> RasterOrientation. Update 26/11/2001 R. Wilcke (wilcke@esrf.fr) azim_int(): change the input arguments; add two new arguments to the declaration of put_buffer(). Update 22/11/2001 R. Wilcke (wilcke@esrf.fr) add definition of user header type AZITYP. Update 19/11/2001 R. Wilcke (wilcke@esrf.fr) add declarations for the new functions set_inpconst(), set_inpfact(), set_scaconst(), set_scafact() and scale_im(). Update 16/11/2001 R. Wilcke (wilcke@esrf.fr) add declaration of the keywords for the user header elements; add declaration for new function set_psizdist(). Update 12/11/2001 R. Wilcke (wilcke@esrf.fr) add 3. input argument "type" to declaration of mark_overflow_nocorr(). Update 08/11/2001 R. Wilcke (wilcke@esrf.fr) add declarations for functions set_inpmin() and set_inpmax(). Update 05/11/2001 R. Wilcke (wilcke@esrf.fr) add 2 more new arguments to the declaration of azim_int(). Update 22/10/2001 R. Wilcke (wilcke@esrf.fr) add 3 new input arguments to azim_int() declaration. Update 18/10/2001 R. Wilcke (wilcke@esrf.fr) add declarations for normint_im() and azim_int(). Update 03/10/2001 R. Wilcke (wilcke@esrf.fr) change last argument in the declaration of save_esrf_file() from "char *" to "int". Update 02/10/2001 R. Wilcke (wilcke@esrf.fr) remove the last two arguments from the declaration of save_esrf_file(). Update 13/09/2001 R. Wilcke (wilcke@esrf.fr) changed type of member "init" in structure "data_head" from "short" to "unsigned short". Update 20/08/2001 R. Wilcke (wilcke@esrf.fr) add declaration for function get_headval(); Update 17/08/2001 R. Wilcke (wilcke@esrf.fr) changed value of SPDTYP from -1 to 6; added declarations of flags for the data_head members; add member "WaveLeng" to structure "data_head" and define corresponding flag. Update 14/08/2001 R. Wilcke (wilcke@esrf.fr) add new image type macro SPDTYP; add new input argument of type "int" in 5th position to read_esrf_file(). Update 13/08/2001 R. Wilcke (wilcke@esrf.fr) change type of set_headval() from "void" to "int" and add a second input argument; add definitions for the macros SRCTYP, CORTYP, BKGTYP, FLOTYP, NO_TYP and SCATYP for the image types. Update 07/08/2001 R. Wilcke (wilcke@esrf.fr) declare new routine set_scaim(); add fourth input argument to subtract_im(). Update 03/08/2001 R. Wilcke (wilcke@esrf.fr) declare new routines set_normint() and set_headval(); include ; added definition of structure data_head. Update 28/06/2001 R. Wilcke (wilcke@esrf.fr) change declaration of routine correct_image() by eliminating the background and floodfield image from the input arguments; declare new routines set_bkgim() and set_floim(). Update 26/06/2001 R. Wilcke (wilcke@esrf.fr) declare new function set_xycorout(). Update 25/06/2001 R. Wilcke (wilcke@esrf.fr) move declaration of "verbose" to "correct.c"; declare new functions set_verbose(), set_overflow(), set_dummy(),set_actrad(),set_splinfil(),set_xycorin(), set_xysize(),get_xsize(),get_ysize(),set_bkgconst(), set_doflat(), set_dolater(), set_dospd(). Update 11/05/2001 R. Wilcke (wilcke@esrf.fr) remove declaration of gethead() routine - no longer used. Update 02/02/2001 R. Wilcke (wilcke@esrf.fr) change all arguments of divide_insito_im() and divide_im() to type "float"; change name of substract_im() to subtract_im() and make all arguments of type "float". change all "unsigned short" arguments of mark_overflow() and mark_overflow_nocorr() to type "float"; change all "unsigned short" arguments of corr_calc() to type "float"; remove declaration of corr_calc_plus(); remove definitions of HALFSCALE and FLO_SHIFT; change all "unsigned short" arguments of correct_image() to type "float"; change member *temp_im of struct lut_descript to type "float"; Update 18/01/2001 R. Wilcke (wilcke@esrf.fr) removed declaration of pxcorr(); changed parameter types of pxcorrgrid() and readarray() from "double" to "float". */ #include #include #include #include #if defined(__STDC__) #include #else #include #endif /* __STDC__ */ #include #include #include #include #include #include #ifndef NO_SHARED_MEMORY #include #include #endif #include "spec_shm.h" #include #include #include #include #include #include #include #include #include #include #include #include extern int errno; #if SOLARIS #define UNDERSCORE 1 #endif #if LINUX #define UPPERCASE 1 #endif #define USE_OFFSET_TAB 0 #define WASTE4_FORSPEED 1 /* This flag needs to be on if you want to read in x and y distortion from a edf file */ #define WASTE2_FORSRCTEMP 1 #define KEEP_COUNTS 1 #define TEMP_LONG 1 #define LUT_BYTE 0 #define MY_MALLOC 1 #define BOUND_CHECK 1 #define BOUND_SUPER 0 #define MAX_PIXELSIZE 6 #define MAX_TRIANGLES 1000 #define MAX_PARTS 200 #define VALUES_PERLINE 5 #define MSG 0 #define WARNING 1 #define ERROR 2 #define FATAL 3 #define DMSG 4 #define PRERR 0x02000000 #define INCTARGET 1 #define ABSSRC 2 #define UNCOMPRESSED 4 #define PROGEND 8 #define MULTIINC 16 #if LUT_BYTE #define LUT_TYPE unsigned char #define FULLSCALE 0x80 #define SHIFT 7 #define MAPSCALE 0x7f #define BITMASK 0x80 #else #define LUT_TYPE unsigned short #define FULLSCALE 0x8000 #define SHIFT 15 #define MAPSCALE 0x7fff #define BITMASK 0x8000 #endif #define MAXHIST (1<<18) #define RELTABSH 5 /* for rel_tab sequence size of 32 (= 1 << 5) */ #define RAD2DEG(x) ((double)(x) * 180. / 3.1415926535897932384626) /* * Define the image types: * SRCTYP source image * CORTYP corrected image * DRKTYP dark (= background) image * FLOTYP floodfield image * HD_TYP header buffer handed over online * SBKTYP scattering background image * SDXTYP x-direction displacement values for spatial distortion correction * SDYTYP y-direction displacement values for spatial distortion correction * SDMTYP multiplication factors applied after spatial distortion correction * AZITYP azimuthal integrated image * AVETYP azimuthal averaged image * MSKTYP mask image with pixels to ignore for azimuthal integration * CMDTYP header structure with values filled by command line arguments * DISTYP file with the spline parameters for the distortion correction * TMPTYP temporary header for calculations */ static char *typestr[] = {"invalid","source","corrected","dark","floodfield", "header","scattering-background","x-distortion","y-distortion","m-distortion", "regrouped","averaged","mask","command-line","spline-distortion", "temporary header"}; #define MAXTYP ( sizeof(typestr) / sizeof(char *) ) enum {INVALID_TYP=0,SRCTYP,CORTYP,DRKTYP,FLOTYP,HD_TYP,SBKTYP,SDXTYP,SDYTYP,SDMTYP, AZITYP,AVETYP,MSKTYP,CMDTYP,DISTYP,TMPTYP}; struct lut_descript { LUT_TYPE *lut; unsigned char *prog; int prog_length; unsigned int starttidx; unsigned int startsidx; int *offset_tab; int *rel_tab; int **relend_tab; unsigned short *abs_src; int maxxpixel; int maxypixel; short *xrel; short *yrel; }; struct triangle { float x[3]; float y[3]; float area; int xpos; int ypos; }; /* * Define flags for the return code of SPD: * * - SPD_ERRFLG: an error occured during the image processing * - SPD_BASUSE: filename of command line option "base_name" was used * - SPD_SRCFIL: a file for the source image was written * - SPD_DRKFIL: a file for the dark image was written * - SPD_CORFIL: a file for the corrected image was written * - SPD_AZIFIL: a file for the azimuthally integrated image was written * - SPD_AVEFIL: a file for the azimuthally averaged image was written * * All applicable flags are "OR"ed together in the return code. */ #define SPD_ERRFLG 0x80000000 #define SPD_BASUSE 0x01000000 #define SPD_SRCFIL 0x00010000 #define SPD_DRKFIL 0x00020000 #define SPD_CORFIL 0x00040000 #define SPD_AZIFIL 0x00080000 #define SPD_AVEFIL 0x00100000 /* * Declarations for the user data header: * - the flags to indicate whether a particular member of the header structure * has been initialized. The flags will be "OR"ed into the "init" member; * - the structure of the user data header; * - the keywords associated with the members of the structure. */ #define FL_ORIEN 0x00000001 #define FL_DUMMY 0x00000002 #define FL_DDUMM 0x00000004 #define FL_OFFS1 0x00000008 #define FL_OFFS2 0x00000010 #define FL_PSIZ1 0x00000020 #define FL_PSIZ2 0x00000040 #define FL_INTE0 0x00000080 #define FL_INTE1 0x00000100 #define FL_CENT1 0x00000200 #define FL_CENT2 0x00000400 #define FL_SAMDS 0x00000800 #define FL_WAVLN 0x00001000 #define FL_TITLE 0x00002000 #define FL_TIME 0x00004000 #define FL_EXTIM 0x00008000 #define FL_BSIZ1 0x00010000 #define FL_BSIZ2 0x00020000 #define FL_DIM1 0x00040000 #define FL_DIM2 0x00080000 #define FL_PRO 0x00100000 #define FL_ROT1 0x00200000 #define FL_ROT2 0x00400000 #define FL_ROT3 0x00800000 #define FL_PRECEN1 0x01000000 #define FL_PRECEN2 0x02000000 #define FL_PREDIS 0x04000000 #define FL_PREROT1 0x08000000 #define FL_PREROT2 0x10000000 #define FL_PREROT3 0x20000000 #define FL_IMAGE (FL_OFFS1 | FL_OFFS2 | FL_BSIZ1 | FL_BSIZ2 | FL_TITLE | \ FL_TIME | FL_EXTIM) struct data_head { unsigned long init; unsigned short Dim_1; // FL_DIM1 unsigned short Dim_2; // FL_DIM2 long Orientat; // FL_ORIEN float Dummy; // FL_DUMMY float DDummy; // FL_DDUMM float Offset_1; // FL_OFFS1 float Offset_2; // FL_OFFS2 float PSize_1; // FL_PSIZ1 float PSize_2; // FL_PSIZ2 float Center_1; // FL_CENT1 float Center_2; // FL_CENT2 float BSize_1; // FL_BSIZ1 float BSize_2; // FL_BSIZ2 float SamplDis; // FL_SAMDS float WaveLeng; // FL_WAVLN float DetRot_1; // FL_ROT1 float DetRot_2; // FL_ROT2 float DetRot_3; // FL_ROT3 float PreCenter_1; // FL_PRECEN1 float PreCenter_2; // FL_PRECEN2 float PreSamplDis; // FL_PREDIS float PreDetRot_1; // FL_PREROT1 float PreDetRot_2; // FL_PREROT2 float PreDetRot_3; // FL_PREROT3 char ProjTyp[5]; // FL_PRO char Intens_0[EdfMaxValLen + 1]; // FL_INTE0 char Intens_1[EdfMaxValLen + 1]; // FL_INTE1 char Title[EdfMaxValLen + 1]; // FL_TITLE char Time[EdfMaxValLen + 1]; // FL_TIME char ExpTime[EdfMaxValLen + 1]; // FL_EXTIM /* * Now the values for the displaced parameters. */ unsigned long Dspinit; unsigned short DspDim_1; // FL_DIM1 unsigned short DspDim_2; // FL_DIM2 long DspOrientat; // FL_ORIEN float DspDummy; // FL_DUMMY float DspDDummy; // FL_DDUMM float DspOffset_1; // FL_OFFS1 float DspOffset_2; // FL_OFFS2 float DspPSize_1; // FL_PSIZ1 float DspPSize_2; // FL_PSIZ2 float DspCenter_1; // FL_CENT1 float DspCenter_2; // FL_CENT2 float DspBSize_1; // FL_BSIZ1 float DspBSize_2; // FL_BSIZ2 float DspSamplDis; // FL_SAMDS float DspWaveLeng; // FL_WAVLN float DspDetRot_1; // FL_ROT1 float DspDetRot_2; // FL_ROT2 float DspDetRot_3; // FL_ROT3 float DspPreCenter_1; // FL_PRECEN1 float DspPreCenter_2; // FL_PRECEN2 float DspPreSamplDis; // FL_PREDIS float DspPreDetRot_1; // FL_PREROT1 float DspPreDetRot_2; // FL_PREROT2 float DspPreDetRot_3; // FL_PREROT3 char DspProjTyp[5]; // FL_PRO char DspIntens_0[EdfMaxValLen + 1]; // FL_INTE0 char DspIntens_1[EdfMaxValLen + 1]; // FL_INTE1 char DspTitle[EdfMaxValLen + 1]; // FL_TITLE char DspTime[EdfMaxValLen + 1]; // FL_TIME char DspExpTime[EdfMaxValLen + 1]; // FL_EXTIM }; static char *headkey[] = {"RasterOrientation","Dummy","DDummy", "Offset_1","Offset_2","PSize_1","PSize_2","Intensity0","Intensity1", "Center_1","Center_2","SampleDistance","WaveLength","Title","Time", "ExposureTime","BSize_1","BSize_2","Dim_1","Dim_2","ProjectionType", "DetectorRotation_1","DetectorRotation_2","DetectorRotation_3", "PreCenter_1","PreCenter_2","PreSampleDistance", "PreDetectorRotation_1","PreDetectorRotation_2","PreDetectorRotation_3"}; static int maxhdkey = sizeof(headkey) / sizeof(char *); /* * The macros "prmsg()" and "__prmsg()" handle the printing of user-defined * messages. The actual file name and line number may be added to the user's * message. * * The macros work by calling the function "_prmsg()". For more details, see * the corresponding description. * * The input parameter that contains the message to print must contain a full * print argument list, i.e. the format statement, the variables to print, and * the surrounding parentheses! Example for a valid prmsg() call: * * prmsg(ERROR,("Cannot read <%s> (open failed)\n",filename)); * * "prmsg" will use the file name and line number corresponding to the location * from where it was called. "__prmsg" allows these to be given as parameters. * This can be useful, e.g. if the macro is used inside a service function, and * the important information is not the location in the service function, but * the location where this service function was called. * * Macro prmsg: * Input : N: message type * M: message to print * Output: none * Return: none * * Macro __prmsg: * Input : N: message type * M: current file name * L: current line number * K: message to print * Output: none * Return: none */ #define prmsg(N,M) do{_prmsg(NULL,N,__FILE__,__LINE__); _prmsg M; } while(0) #define __prmsg(N,M,L,K) do{_prmsg(NULL,N,M,L); _prmsg K; } while(0) #if MY_MALLOC /* * If MY_MALLOC is defined, an alternative set of routines for memory * management is used. The following routines are defined: * * - pmalloc(), prealloc(), pfree() replace the standard routines malloc(), * realloc() and free(); * - print_memsize() prints the total allocated memory size. * * The differences to the standard routines are: * - the alternative set provides error printout indicating the current file * and line number where the error occurred; * - the alternative set operates on a linked list of data structures of type * "pmem". Each structure contains the size of its data segment, a pointer to * the next element in the list, and a pointer to its own data segment. This * allows to keep track of the overall memory usage by the program with the * routine print_memsize(). * * Otherwise, the input parameters and return values of the routines in the * alternative set are the same as the ones in the standard set. * * If MY_MALLOC is not defined, pmalloc(), prealloc() and pfree() are defined * to be the standard set of memory management routines, and print_memsize() * is a dummy. */ struct pmem { void *data; /* data segment */ long int size; /* size of the data segment */ struct pmem *next; /* pointer to next structure in linked list */ void *fill128; /* align the return ptr again on 16 byte boundary*/ }; #define pmalloc(N) _pmalloc(N,__FILE__,__LINE__) #define prealloc(N,M) _prealloc(N,M,__FILE__,__LINE__) #define pfree(N) _pfree(N,__FILE__,__LINE__) #else #define pmalloc malloc #define pfree free #define prealloc realloc #endif /* MY_MALLOC */ /* * Function Prototypes */ #if defined __cplusplus extern "C" { #endif #ifndef NO_SHARED_MEMORY # define SHM_HEADER struct shm_header #else # define SHM_HEADER void #endif SHM_HEADER *getShmPtr(int,int); void *getShmDataPtr(SHM_HEADER*,int); int getstate(void); void prntvers(char *); int get_headval(struct data_head *,int); int pr_headval(FILE *, int); int get_xsize(void); int get_ysize(void); void set_actrad(float); void set_bckgconst(float); void set_bckgfact(float); void set_dodark(int); void set_doflat(int); void set_dospd(int); void set_doprerot(int doprerot); int get_doprerot( void ); void set_normprerot(int normprerot); void set_drkconst(float); void set_dummy(float); int set_headval(struct data_head,int); void set_imgbuf(void *,int); void set_inpconst(float); void set_inpexp(float); void set_inpfact(float); void set_inpmax(float); void set_inpmin(float); void set_normint(int,float); void set_overflow(unsigned long); int set_dstrtval(int); void set_splinfil(char *); void set_xycorin(char *,char *); void set_xycorout(char *,char *); void set_moutfile(char *mfile); void set_xysize(int,int); #if defined(__STDC__) void _prmsg(char *format,...); #else void _prmsg(); #endif /* __STDC__ */ struct lut_descript *lut_calc(void); void *_pmalloc(int,char *,int); void *_prealloc(void *,int,char *,int); int _pfree(void *,char *,int); int print_memsize(void); int print_memlist(void); char *spd_fgets(FILE *); struct spd_spline *spd_loadspline(char *); int spd_findkeyword(FILE *,char *); int spd_readarray(FILE *,int,float *); void spd_unloadspline(struct spd_spline *); int spd_calcspline(struct spd_spline *,int,int,float [],float [],float [],float []); int spd_corr(float **,float **,float **,int,int,int,int); int spd_free_buffers(float *,float *); int spd_func(int,int,float *,float *); int trianglecutv_only(struct triangle *,float,struct triangle [],int *); int trianglecuth_only(struct triangle *,float,struct triangle [],int *); void area_only(float *,float *,float *); int triangle_cutall(struct triangle [],int *,int *,int *,int *,int *); int calcparts(float [],float [],int,float [],int *,int *,int *,int *,float *); int debugout(struct triangle [],int,float,float [],int,int,int,int); int pxtomm(float *,float *,float *,float *); int loadspd(char *,float *,float *,int *,int); int byte_swap2N(); int set_prerot_headval( int ); int correct_image(float *,float *); int expon_im(float *,float *,float,int); int scale_im(float *,float *,float,float,int); int subtract_drk(float *,float *,float *,float); int subtract_im(float *,float *,float *,float,float); int divide_insito_im(float *,float *); int divide_im(float *,float *,float *); int normint_im(float *,float *,int); int make_grid(unsigned short *,float,float,int); int mark_overflow(float *,float *,struct lut_descript *,float); int mark_overflow_nocorr(float *,float *,long *,int); int map_imag(void *,void **,double,double,int); int region_compare(int,float,float,float,float,float,float,float,float,float, float,float,float); int azim_int(float *,float *,float *,float,int,float,float,int,int,float,int); int undistort_im(float *,float *,struct lut_descript *); int minmax4(float,float,float,float,float *,float *); int histcompare_count(const void *,const void *); int histcompare_idx(const void *,const void *); int debug_print(unsigned char *,LUT_TYPE *,unsigned short *,int,int,int,int, int); int user_code(int,char *[]); int scan_argument(char *,char *,char *,void *); int prepare_flood(unsigned short *,float *); int get_buffer(int,char *,void **,int *,int *,int); int put_buffer(char *,void **,int,int,int); int clean_buffer(void **,int,int); char *outname(char *,char *,char *,char *); int fnampat(char *,size_t,int,char *[]); int analyse_args(int,char *[],char *); int save_esrf_file(char *,void *,int,int,int,int); int read_esrf_file(char *,void **,int *,int *,int,int,int *); int bench(char *); int despair(unsigned char *,LUT_TYPE *,int); #if defined __cplusplus } #endif spd-1.3.0/config.h.in0000644000175000017500000001021211650556211011243 00000000000000/* config.h.in. Generated from configure.ac by autoheader. */ /* Define to 1 if you have the header file. */ #undef HAVE_FCNTL_H /* Define to 1 if you have the header file. */ #undef HAVE_FLOAT_H /* Define to 1 if you have the `floor' function. */ #undef HAVE_FLOOR /* Define to 1 if you have the `gettimeofday' function. */ #undef HAVE_GETTIMEOFDAY /* Define to 1 if you have the header file. */ #undef HAVE_INTTYPES_H /* Define to 1 if you have the `c' library (-lc). */ #undef HAVE_LIBC /* Define to 1 if you have the header file. */ #undef HAVE_LIMITS_H /* Define to 1 if your system has a GNU libc compatible `malloc' function, and to 0 otherwise. */ #undef HAVE_MALLOC /* Define to 1 if you have the header file. */ #undef HAVE_MEMORY_H /* Define to 1 if you have the `memset' function. */ #undef HAVE_MEMSET /* Define to 1 if you have the `pow' function. */ #undef HAVE_POW /* Define to 1 if your system has a GNU libc compatible `realloc' function, and to 0 otherwise. */ #undef HAVE_REALLOC /* Define to 1 if you have the `sqrt' function. */ #undef HAVE_SQRT /* Define to 1 if stdbool.h conforms to C99. */ #undef HAVE_STDBOOL_H /* Define to 1 if you have the header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the header file. */ #undef HAVE_STDLIB_H /* Define to 1 if you have the `strcasecmp' function. */ #undef HAVE_STRCASECMP /* Define to 1 if you have the `strchr' function. */ #undef HAVE_STRCHR /* Define to 1 if you have the `strdup' function. */ #undef HAVE_STRDUP /* Define to 1 if you have the `strerror' function. */ #undef HAVE_STRERROR /* Define to 1 if you have the header file. */ #undef HAVE_STRINGS_H /* Define to 1 if you have the header file. */ #undef HAVE_STRING_H /* Define to 1 if you have the `strncasecmp' function. */ #undef HAVE_STRNCASECMP /* Define to 1 if you have the `strrchr' function. */ #undef HAVE_STRRCHR /* Define to 1 if you have the `strspn' function. */ #undef HAVE_STRSPN /* Define to 1 if you have the `strstr' function. */ #undef HAVE_STRSTR /* Define to 1 if you have the `strtol' function. */ #undef HAVE_STRTOL /* Define to 1 if you have the header file. */ #undef HAVE_SYS_PARAM_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_STAT_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TIME_H /* Define to 1 if you have the header file. */ #undef HAVE_SYS_TYPES_H /* Define to 1 if you have the header file. */ #undef HAVE_UNISTD_H /* Define to 1 if the system has the type `_Bool'. */ #undef HAVE__BOOL /* Name of package */ #undef PACKAGE /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ #undef PACKAGE_NAME /* Define to the full name and version of this package. */ #undef PACKAGE_STRING /* Define to the one symbol short name of this package. */ #undef PACKAGE_TARNAME /* Define to the home page for this package. */ #undef PACKAGE_URL /* Define to the version of this package. */ #undef PACKAGE_VERSION /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS /* Version number of package */ #undef VERSION /* Define to rpl_malloc if the replacement function should be used. */ #undef malloc /* Define to rpl_realloc if the replacement function should be used. */ #undef realloc /* Define to the equivalent of the C99 'restrict' keyword, or to nothing if this is not supported. Do not define if restrict is supported directly. */ #undef restrict /* Work around a bug in Sun C++: it does not support _Restrict or __restrict__, even though the corresponding Sun C compiler ends up with "#define restrict _Restrict" or "#define restrict __restrict__" in the previous line. Perhaps some future version of Sun C++ will work with restrict; if so, hopefully it defines __RESTRICT like Sun C does. */ #if defined __SUNPRO_CC && !defined __RESTRICT # define _Restrict # define __restrict__ #endif /* Define to `unsigned int' if does not define. */ #undef size_t spd-1.3.0/README0000644000175000017500000000017311643121541010101 00000000000000SPD is a large piece of C-code dealing with image corrections and azimuthal integration, mainly written by Peter Boesecke.