1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
include <pkg/gtools.h>
# FLATTEN -- Flatten a spectrum and normalize to 1.0
# Use ICFIT for fitting the spectrum
procedure flatten (gp, gt, x, y, n)
pointer gp, gt
real x[n]
real y[n]
int n
bool b
real wx, z
int i, key
pointer sp, str, w, gt2, ic, cv
bool clgetb()
real clgetr(), ic_getr(), cveval()
int clgeti(), ic_geti(), btoi(), clgcur()
errchk icg_fit
begin
call smark (sp)
call salloc (str, SZ_FNAME, TY_CHAR)
call salloc (w, n, TY_REAL)
key = '?'
repeat {
switch (key) {
case '/', '-', 'f', 'c', 'n':
call ic_open (ic)
call clgstr ("function", Memc[str], SZ_FNAME)
call ic_pstr (ic, "function", Memc[str])
call ic_puti (ic, "order", clgeti ("order"))
call ic_putr (ic, "low", clgetr ("low_reject"))
call ic_putr (ic, "high", clgetr ("high_reject"))
call ic_puti (ic, "niterate", clgeti ("niterate"))
call ic_putr (ic, "grow", clgetr ("grow"))
call ic_puti (ic, "markrej", btoi (clgetb ("markrej")))
switch (key) {
case '/':
call ic_puti (ic, "key", 4)
case '-':
call ic_puti (ic, "key", 3)
case 'f', 'n', 'c':
call ic_puti (ic, "key", 1)
}
call ic_putr (ic, "xmin", min (x[1], x[n]))
call ic_putr (ic, "xmax", max (x[1], x[n]))
call gt_copy (gt, gt2)
call gt_gets (gt2, GTXLABEL, Memc[str], SZ_FNAME)
call ic_pstr (ic, "xlabel", Memc[str])
call gt_gets (gt2, GTYLABEL, Memc[str], SZ_FNAME)
call ic_pstr (ic, "ylabel", Memc[str])
call gt_gets (gt2, GTXUNITS, Memc[str], SZ_FNAME)
call ic_pstr (ic, "xunits", Memc[str])
call gt_gets (gt2, GTYUNITS, Memc[str], SZ_FNAME)
call ic_pstr (ic, "yunits", Memc[str])
call amovkr (1., Memr[w], n)
call icg_fit (ic, gp, "cursor", gt2, cv, x, y, Memr[w], n)
switch (key) {
case '/':
do i = 1, n {
z = cveval (cv, x[i])
if (abs (z) < 1e-30)
y[i] = 1.
else
y[i] = y[i] / z
}
case '-':
do i = 1, n
y[i] = y[i] - cveval (cv, x[i])
case 'f':
do i = 1, n
y[i] = cveval (cv, x[i])
case 'c':
call ic_clean (ic, cv, x, y, Memr[w], n)
case 'n':
;
}
call ic_gstr (ic, "function", Memc[str], SZ_FNAME)
call clpstr ("function", Memc[str])
call clputi ("order", ic_geti (ic, "order"))
call clputr ("low_reject", ic_getr (ic, "low"))
call clputr ("high_reject", ic_getr (ic, "high"))
call clputi ("niterate", ic_geti (ic, "niterate"))
call clputr ("grow", ic_getr (ic, "grow"))
b = (ic_geti (ic, "markrej") == YES)
call clputb ("markrej", b)
call cv_free (cv)
call gt_free (gt2)
call ic_closer (ic)
break
case 'q':
break
default:
call printf (
"/=normalize, -=subtract, f=fit, c=clean, n=nop, q=quit")
}
} until (clgcur ("cursor", wx, z, i, key, Memc[str], SZ_FNAME) == EOF)
call sfree (sp)
end
|
