NLSL: getdat.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

getdat.f90
Go to the documentation of this file.
1 c NLS Version 1.5.1 beta 11/25/95
2 c----------------------------------------------------------------------
3 c =========================
4 c function GETDAT
5 c =========================
6 c
7 c Inputs experimental EPR spectra for nonlinear least squares fitting
8 c programs.
9 c
10 c function getdat( filen,infmt,modebc,nspln,ideriv,norm,lumsg,
11 c # comment,ncmts,spndat,bi,delb,stddev,xraw,yraw,y2)
12 c
13 c Returns 0 for a successful read.
14 c
15 c Subroutine arguments:
16 c
17 c filen Name of data file
18 c infmt Specifies the input format of the datafile
19 c 0: PLOT/GENPLOT ASCII format with one X,Y pair per line
20 c (lines with 'c', 'C', or '!' in first column skipped)
21 c 1: PC-GENPLOT binary format files
22 c modebc Specifies the type of baseline correction to be applied
23 c to the data, as follows:
24 c 0: No baseline correction
25 c n: Fit a least squares line to the first and last <n> points
26 c and subtract it from the spectrum
27 c nspln Number of points desired in the final splined data
28 c (0 if no spline is desired)
29 c ideriv Derivative flag (nonzero for first derivative data)
30 c norm Normalization flag: 0=do not normalize data, otherwise,
31 c adjust so that integral=1 (2nd integral for 1st deriv data)
32 c lumsg Logical unit for output of informational messages.
33 c Set to 0 if no output is desired
34 c xraw Work arrays to contain raw x,y data. Should be dimensioned
35 c yraw to maximum expected number of points
36 c y2 Work array to contain spline data
37 c
38 c Output:
39 c comment File comment
40 c ncmts Number of comment lines in file
41 c spndat Splined data after baseline correction
42 c nspln Number of data points if input {nspln,bi,delb} incomplete
43 c bi Low field of input data
44 c delb Delta-field per point
45 c
46 c Functions coded in this file:
47 c
48 c getasc get ASCII 2-column data
49 c sglint Return single integral of data array
50 c dblint Return double integral of data array
51 c linebc Baseline-correct of data array
52 c ncspln Determine spline coefficients from array
53 c splnay Spline interpolation of array
54 c normlz Normalize array to unit integral
55 c
56 c Calls functions (not coded in this file)
57 c getbin (in genio.c)
58 c
59 c----------------------------------------------------------------------
60 c
61 function getdat( filen,infmt,modebc,nspln,ideriv,norm,lumsg,
62 # comment,ncmts,spndat,bi,delb,stddev,xraw,yraw,
63 # y2)
64 c
65 c --- The following is needed for the definition of "MXCMT" and "MXINP"
66 c
67 use nlsdim
68 c
69 implicit none
70 integer getdat,ideriv,infmt,lumsg,modebc,norm,nspln,ncmts
71 double precision bi,delb,stddev,spndat(nspln),xraw(mxinp),
72 # yraw(mxinp),y2(mxinp)
73 c
74 character*30 filen
75 character*80 comment(mxcmt)
76 c
77 integer i,k,iret,npts,nend
78 double precision anorm,c0,c1,yntgrl,ybase
79 c
80 integer getasc,getbin
81
82 double precision sglint,dblint
83 external getasc,getbin,sglint,dblint
84 c
85 c######################################################################
86 c
87 c----------------------------------------------------------------------
88 c Input datafile according to specified format:
89 c----------------------------------------------------------------------
90 if (lumsg.ne.0) write(lumsg,1005) filen
91 c
92 c.......format #1: PC-GENPLOT binary data (input routine written in C)
93 c
94 if (infmt .eq. 1) then
95 iret=getbin(filen,xraw,yraw,npts,comment,ncmts,mxinp)
96 else
97 c
98 c......format #0 (default): standard ASCII format
99 c
100 iret=getasc(filen,xraw,yraw,npts,comment,ncmts,mxcmt,mxinp)
101 end if
102 c
103 c----------------------------------------------------------------------
104 c Abort processing if there was an input error
105 c----------------------------------------------------------------------
106 if (iret .ne. 0) then
107 getdat=1
108 return
109 else
110 c Too many points
111 if (npts.gt.mxinp) then
112 if (lumsg.ne.0) write (lumsg,1013) mxinp,npts-mxinp
113 npts=mxinp
114 end if
115 c Report # points read
116 if (lumsg.ne.0) then
117 if (infmt.eq.1) then
118 write(lumsg,1006) npts,xraw(1),xraw(npts)
119 else
120 write(lumsg,1007) npts,xraw(1),xraw(npts)
121 end if
122 end if
123 c
124 c Check field range
125 c
126 if ((xraw(1).ge.xraw(npts)) .or. 0.5d0*(xraw(1)+xraw(npts))
127 # .lt. abs(xraw(npts)-xraw(1)) ) then
128 if (lumsg.ne.0) write(lumsg,1012)
129 end if
130 c
131 end if
132 c
133 c----------------------------------------------------------------------
134 c Baseline correction.
135 c
136 c Fit a line to first and last MODEBC points of the curve and
137 c subtract it from the data.
138 c----------------------------------------------------------------------
139 stddev = 0.0d0
140 call linebc( xraw,yraw,npts,modebc,c0,c1,stddev )
141 if (modebc.ne.0) then
142 if (lumsg.ne.0) write (lumsg,1008) modebc,c0,c1,stddev
143 else
144 if (lumsg.ne.0) write (lumsg,1009) stddev
145 endif
146 c
147 c----------------------------------------------------------------------
148 c If specified, perform a natural cubic spline on the data in order
149 c to interpolate the desired number of points to be used for fitting.
150 c----------------------------------------------------------------------
151 if (nspln .gt. 0) then
152 bi=xraw(1)
153 delb=(xraw(npts)-xraw(1))/(nspln-1)
154 call ncspln(xraw,yraw,npts,y2 )
155 call splnay(xraw,yraw,y2,npts,bi,delb,spndat,nspln)
156 if (lumsg.ne.0) write(lumsg,1010) nspln
157 else
158 c
159 c No spline: copy raw data directly
160 c
161 bi=xraw(1)
162 delb=(xraw(npts)-xraw(1))/(npts-1)
163 nspln=npts
164 do i=1,nspln
165 spndat(i)=yraw(i)
166 end do
167 if (lumsg.ne.0) write (lumsg,1011)
168 end if
169 c
170 c----------------------------------------------------------------------
171 c Normalize data to adjust integral (or double integral for
172 c first-derivative data) to unity
173 c----------------------------------------------------------------------
174 if (norm.ne.0) then
175 call normlz( spndat,nspln,delb,ideriv,lumsg,anorm )
176 if (anorm.ne.0.0d0) stddev=stddev/anorm
177 end if
178 c
179 getdat=0
180 return
181 c
182 c### format statements ############################################
183 c
184 1005 format(//'Opening file ',a/)
185 1006 format(i6,' raw data points read in PC-GENPLOT binary format'/
186 # ' Field range:',f10.2,' to ',f10.2)
187 1007 format(i6,' raw data points read in ASCII format'/
188 # ' Field range:',f10.2,' to ',f10.2/)
189 1008 format(' Data baseline-corrected using linear fit to ',i3,
190 #' points at each end'/' Intercept=',g14.7,' Slope=',g14.7,
191 #' Noise: ',g14.7)
192 1009 format(' Spectral noise: ',g14.7)
193 1010 format(' Data splined to ',i4,' points')
194 1011 format(' Input data not splined')
195 1012 format(' *** Questionable field range ***')
196 1013 format(' *** Maximum of ',i5,' input pts reached: remaining',i5,
197 # ' pts ignored ***')
198 end
199
200
201 c-----------------------------------------------------------------------
202 c =========================
203 c function GETASC
204 c =========================
205 c Input (X,Y) data in ASCII format with one (X,Y) pair per line
206 c Each line is read in as a character variable; if the first character
207 c of the line is a 'c' or a '!', it is considered to be a comment and
208 c the line is stored in the comment array. Otherwise, the (X,Y) pair
209 c is input from the line using a FORTRAN internal read.
210 c
211 c Arguments:
212 c filen: Name of file to be read
213 c x: Double precision array to receive x data
214 c y: Double precision array to receive y data
215 c comment: Character array to receive file comments
216 c ncmt: Number of comments read from file
217 c maxcmt: Maximum number of comments that may be returned
218 c maxinp: Maximum number of points that may be returned
219 c-----------------------------------------------------------------------
220 function getasc(filen,x,y,n,comment,ncmt,maxcmt,maxinp)
221 c
222 use stdio
223 c
224 implicit none
225 integer getasc,n,ncmt,maxcmt,maxinp,lth
226 character numstr*30
227 c double precision x(n),y(n),xin,yin // n is "output only"
228 double precision x(*),y(*),xin,yin
229 c
230 character*30 filen
231 character*80 comment(maxcmt),line
232 c
233 logical ftoken
234 external ftoken
235 c
236 c######################################################################
237 c
238 ncmt=0
239 open(ludisk,file=filen,status='old',
240 # access='sequential',form='formatted',err=99 )
241
242 7 read (ludisk,1007,end=10,err=99) line
243 if ( line(1:1) .eq. 'c'
244 # .or. line(1:1) .eq. 'C'
245 # .or. line(1:1) .eq. '!' ) then
246 if (ncmt .lt. maxcmt) then
247 ncmt=ncmt+1
248 comment(ncmt)=line
249 endif
250 c
251 goto 7
252 end if
253 c
254 call gettkn(line,numstr,lth)
255 if (.not.ftoken(numstr,lth,x(1)) ) go to 99
256 call gettkn(line,numstr,lth)
257 if (.not.ftoken(numstr,lth,y(1)) ) go to 99
258 1007 format(a)
259 c
260 c---------------------------------------------
261 c loop to read input lines, skipping comments
262 c---------------------------------------------
263 n=1
264 8 read (ludisk,1007,end=10,err=99) line
265 if ( line(1:1) .eq. 'c'
266 # .or. line(1:1) .eq. 'C'
267 # .or. line(1:1) .eq. '!' ) then
268 if (ncmt .lt. maxcmt) then
269 ncmt=ncmt+1
270 comment(ncmt)=line
271 endif
272 goto 8
273 endif
274 c
275 call gettkn(line,numstr,lth)
276 if (.not.ftoken(numstr,lth,xin) ) go to 99
277 call gettkn(line,numstr,lth)
278 if (.not.ftoken(numstr,lth,yin) ) go to 99
279 n=n+1
280 if (n.le.maxinp) then
281 x(n)=xin
282 y(n)=yin
283 end if
284 goto 8
285 c
286 c----------------------------------------------------------------------
287 c Normal return
288 c----------------------------------------------------------------------
289 10 close( ludisk )
290 if (n.gt.0) getasc=0
291 return
292
293 c----------------------------------------------------------------------
294 c Error opening or reading file
295 c----------------------------------------------------------------------
296 99 close( ludisk )
297 n=0
298 getasc=1
299 return
300 end
301
302
303 c----------------------------------------------------------------------
304 c =========================
305 c function SGLINT
306 c =========================
307 c
308 c Calculate the integral of the function tabulated in ARRY using the
309 c trapezoidal rule. It is assumed that the ordinates are equally spaced.
310 c The return value is normalized to a spacing DX=1.
311 c N is number of points in ARRY.
312 c----------------------------------------------------------------------
313 function sglint( arry, n )
314 implicit none
315 integer i,n
316 double precision arry(n), dx, sglint
317
318 sglint=0.0d0
319 do 10 i=1,n
320 sglint=sglint+arry(i)
321 10 continue
322 sglint=sglint-0.5d0*(arry(1)+arry(n))
323 return
324 end
325
326 c----------------------------------------------------------------------
327 c =========================
328 c function DBLINT
329 c =========================
330 c
331 c Calculate the double integral of the function tabulated in ARRY using
332 c the trapezoidal rule. It is assumed that the ordinates are equally spaced.
333 c The return value is normalized to a spacing DX=1.
334 c N is number of points in ARRY.
335 c----------------------------------------------------------------------
336 function dblint( arry, n )
337 implicit none
338 integer i,n
339 double precision arry(n),dx,sglint,dblint
340
341 sglint=0.0d0
342 dblint=0.0d0
343 do 10 i=1,n
344 sglint=sglint+arry(i)
345 dblint=dblint+sglint
346 10 continue
347 dblint=dblint-0.5*(arry(1)+sglint)
348 return
349 end
350
351
352 c----------------------------------------------------------------------
353 c =======================
354 c subroutine LINEBC
355 c =======================
356 c
357 c Given a set of N points in arrays X and Y, fit a least-squares line to
358 c the first and last NEND points of the spectrum and subtract it from the
359 c Y array. Returns slope and intercept of the baseline and the RMS deviation
360 c of the data from the baseline at the endpoints (a measure of spectral
361 c noise)
362 c
363 c Inputs
364 c x array of x-values
365 c y array of y-values (replaced on output)
366 c n number of points
367 c modebc number of endpoints to use for baseline correction
368 c if modebc.eq.0, baseline is calculated but not
369 c
370 c Outputs
371 c c0 Zeroth order (intercept) coefficient for baseline
372 c c1 First order (slope) coefficient for baseline
373 c stddev Std deviation of data from baseline (spectral RMS noise)
374 c
375 c----------------------------------------------------------------------
376 subroutine linebc(x,y,n,modebc,c0,c1,stddev)
377 implicit none
378 integer n,modebc
379 double precision x(n),y(n),c0,c1,stddev
380 double precision d,sn,sx,sx2,sxy,sy
381 integer i,k,nend
382 c
383 double precision ZERO,TWO
384 parameter(zero=0.0d0,two=2.0d0)
385 c
386 nend=min0(modebc,n/3)
387 if (nend.le.0) nend=max0(10,n/20)
388 c
389 sx =zero
390 sy =zero
391 sx2=zero
392 sxy=zero
393 do i=1,nend
394 k=n-i+1
395 sx =sx + x(i)+x(k)
396 sy =sy + y(i)+y(k)
397 sx2=sx2 + x(i)**2 + x(k)**2
398 sxy=sxy + x(i)*y(i) + x(k)*y(k)
399 end do
400 c
401 c --------------------------------------------------------------
402 c Calculate slope and intercept of baseline and spectral noise
403 c --------------------------------------------------------------
404 c
405 sn=2*nend
406 d =sn*sx2 - sx*sx
407 c0=(sx2*sy - sx*sxy) / d
408 c1=(sn*sxy-sx*sy) / d
409 c
410 c --------------------------------
411 c Calculate variance of linear fit
412 c --------------------------------
413 c
414 stddev=zero
415 do i=1,nend
416 k=n-i+1
417 stddev=stddev+((y(i)+y(k))-two*c0-c1*(x(i)+x(k)))**2
418 end do
419 stddev=dsqrt(stddev/dfloat(2*nend-1))
420 c
421 c ------------------------------
422 c Subtract baseline from data
423 c ------------------------------
424 c
425 if (modebc.gt.0) then
426 do i=1,n
427 y(i)=y(i)-(c0+c1*x(i))
428 end do
429 end if
430 return
431 end
432
433 c----------------------------------------------------------------------
434 c =======================
435 c subroutine NCSPLN
436 c =======================
437 c Perform a natural cubic spline fit. This is a modification of
438 c subroutine SPLINE from Numerical Recipes. Given the tabulated function
439 c of N points in arrays X and Y, return an array Y2 of length N which
440 c contains the second derivative of the interpolating function at the
441 c corresponding X values. The major difference from the original SPLINE
442 c routine is that the second derivatives at the both boundaries of
443 c the function are assumed to be zero (hence "natural cubic spline").
444 c----------------------------------------------------------------------
445 subroutine ncspln(x,y,n,y2)
446 implicit none
447 integer NMAX
448 parameter(nmax=4096)
449 double precision ZERO,ONE,TWO,SIX
450 parameter(zero=0.0d0,one=1.0d0,two=2.0d0,six=6.0d0)
451 c
452 integer i,k,n
453 double precision x(n),y(n),y2(n),u(nmax),sig,p
454 c
455 y2(1)=zero
456 u(1) =zero
457 do 18 i=2,n-1
458 sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
459 p=sig*y2(i-1) + two
460 y2(i)=(sig-one)/p
461 u(i)=(six*( (y(i+1)-y(i))/(x(i+1)-x(i))
462 & -(y(i)-y(i-1))/(x(i)-x(i-1)) )
463 & /(x(i+1)-x(i-1))
464 & - sig*u(i-1))/p
465 18 continue
466 y2(n)=zero
467 do 19 k=n-1,1,-1
468 y2(k)=y2(k)*y2(k+1)+u(k)
469 19 continue
470 return
471 end
472
473 c----------------------------------------------------------------------
474 c ====================
475 c subroutine SPLNAY
476 c ====================
477 c
478 c Modification of Numerical Recipes spline interpolation routine (SPLINT)
479 c which interpolates an entire array at once. Given the original N
480 c data points in XA,YA and the second derivative YA2 (calculated by SPLINE
481 c or NCSPLN) and the set of NS X values starting at X0 and spaced by DX,
482 c this routine returns the interpolated function values in Y.
483 c The original binary search in subroutine SPLINT has been replaced,
484 c since the interpolations start near the lower bound and are repeated
485 c for successively higher, but closely spaced x values.
486 c----------------------------------------------------------------------
487 subroutine splnay(xa,ya,y2a,n,x0,dx,y,ns)
488 implicit none
489 integer i,klo,khi,n,ns
490 double precision xa(n),ya(n),y2a(n),y(ns),x,x0,dx,h,a,b
491 c
492 if (x0 .lt. xa(1) .or. x0+dx*(ns-1) .gt. xa(n)) then
493 print *, 'SPLNAY: Bad interpolated X range.'
494 print *, '[execution paused, press enter to continue]'
495 read (*,*)
496 end if
497 x=x0-dx
498 klo=1
499 khi=2
500 do 3 i=1, ns
501 x=x+dx
502 2 if (x.gt.xa(khi) .and. khi.lt.n) then
503 klo=khi
504 khi=khi+1
505 goto 2
506 endif
507 h=xa(khi)-xa(klo)
508 if (h .eq. 0.0d0) then
509 print *, 'SPLNAY: Bad XA input.'
510 print *, '[execution paused, press enter to continue]'
511 read (*,*)
512 end if
513 a=(xa(khi)-x)/h
514 b=(x-xa(klo))/h
515 y(i)=a*ya(klo) + b*ya(khi) +
516 * ((a**3-a)*y2a(klo) + (b**3-b)*y2a(khi))*(h**2)/6.0d0
517 3 continue
518 return
519 end
520
521 c----------------------------------------------------------------------
522 c =========================
523 c subroutine NORMLZ
524 c =========================
525 c
526 c Normalizes an array to unit integral, given the x-spacing dx
527 c
528 c Inputs
529 c arry Double precision y array
530 c n Length of array
531 c dx Assumed x-value increment (equally spaced array assumed)
532 c ideriv Derivative flag (0=0th, otherwise 1st)
533 c lumsg Logical unit to receive output messages (0 for no msgs)
534 c
535 c Outputs
536 c arry Normalized array
537 c
538 c Uses
539 c sglint Single integration of a data array
540 c dblint Double integration of a data array
541 c
542 c----------------------------------------------------------------------
543 c
544 subroutine normlz(arry,n,dx,ideriv,lumsg,anorm)
545 implicit none
546 integer n,ideriv,lumsg
547 double precision arry(n),dx,anorm
548 c
549 double precision base,sntgrl
550 integer i
551 c
552 double precision sglint,dblint
553 external sglint,dblint
554 c
555 if (ideriv.eq.0) then
556 c
557 c ---------------------------------------------------------------------
558 c Find normalization constant by single integration of 0th-deriv data
559 c ---------------------------------------------------------------------
560 anorm=dx*sglint(arry,n)
561 c
562 else
563 c
564 c -----------------------------------------------------------------
565 c If first-derivative data are to be normalized, first subtract
566 c a constant so that the integral of the curve is zero
567 c -----------------------------------------------------------------
568 sntgrl=sglint(arry,n)
569 base=sntgrl/dfloat(n)
570 do i=1,n
571 arry(i)=arry(i)-base
572 end do
573 if (lumsg.ne.0) write(lumsg,1008) base
574 c
575 c -------------------------------------------------------------------
576 c Find normalization constant by double integration of 1st-deriv data
577 c -------------------------------------------------------------------
578 anorm=dx*dx*dblint(arry,n)
579 end if
580 c
581 if (lumsg.ne.0) write (lumsg,1012) anorm
582 if (anorm.ne.0.0d0) then
583 do i=1,n
584 arry(i)=arry(i)/anorm
585 end do
586
587 end if
588 return
589 c
590 1008 format(' Baseline adjusted by subtracting ',g14.7,
591 # ' before normalization')
592 1012 format(' Data normalized: integral = ',g14.7)
593 end
getdat
integer function getdat(filen, infmt, modebc, nspln, ideriv, norm, lumsg, comment, ncmts, spndat, bi, delb, stddev, xraw, yraw, y2)
Definition: getdat.f90:64
nlsdim::mxcmt
integer, parameter mxcmt
Definition: nlsdim.f90:39
stdio
Definition: stdio.f90:26
sglint
double precision function sglint(arry, n)
Definition: getdat.f90:314
dblint
double precision function dblint(arry, n)
Definition: getdat.f90:337
gettkn
subroutine gettkn(line, token, lth)
Written for free-form input of parameters for slow-motional calculations. Returns a token consisting ...
Definition: strutl1.f90:75
ncspln
subroutine ncspln(x, y, n, y2)
Definition: getdat.f90:446
normlz
subroutine normlz(arry, n, dx, ideriv, lumsg, anorm)
Definition: getdat.f90:545
getasc
integer function getasc(filen, x, y, n, comment, ncmt, maxcmt, maxinp)
Definition: getdat.f90:221
splnay
subroutine splnay(xa, ya, y2a, n, x0, dx, y, ns)
Definition: getdat.f90:488
stdio::ludisk
integer, parameter ludisk
Definition: stdio.f90:29
nlsdim
Definition: nlsdim.f90:36
linebc
subroutine linebc(x, y, n, modebc, c0, c1, stddev)
Definition: getdat.f90:377
nlsdim::mxinp
integer, parameter mxinp
Definition: nlsdim.f90:39