-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathMULTI_FRILLS.FOR
276 lines (266 loc) · 11.2 KB
/
MULTI_FRILLS.FOR
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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
subroutine MULTI_FRILLS (fun)
! Based on: FRILLS: An Interactive Least Squares Fitting Package
! R. Osborn, Rutherford Appleton Laboratory Report RAL 91-011 (1991)
! Modified: Adapted for fitting of multiple datasets in May 1993 by
! R.Osborn, Materials Science Division, Argonne, National Laboratory, Argonne, IL 60439-4845, USA
! Command List
! ------------
! Help - help provided on each command
! Display - display data, parameters, calculation or fit
! Plot - plot data, calculation, fit, or residuals
! Output - output parameters or fit to disk file
! Input - input parameters from disk file
! Keep - keep hardcopy for plotting on the laser printer
! Use - use selected set of data points in future commands
! Modify - modify data points
! Remove - remove data points
! Set - set parameters
! Fix - fix parameters
! Bind - bind parameters
! Clear - clear fixed parameters or modified data
! Limit - limit parameters
! Alter - alter fitting parameters, plot characteristics and terminal emulation
! Title - change fit title
! Go - fit functions to data
! Jump - spawns DCL sub-process
! Exit - exit from routine
! @focus - focus defined command
include 'CF_SOURCES:FRILLS.INC'
include 'CF_SOURCES:CONTROL.INC'
integer no_commands,no_options
parameter(no_commands=21,no_options=5)
external fun
character word*12, line*80
character command(no_commands)*8, option(no_options)*11
character*8 chint
logical fitted
integer*4 i, line_len, getlin, l, word_len, getwrd, j
data command / 'DISPLAY', 'PLOT', 'INPUT', 'OUTPUT', 'MODIFY', 'REMOVE', 'SET', 'FIX', 'BIND', 'CLEAR', 'LIMIT',
> 'ALTER', 'TITLE', 'GO', 'HELP', 'KEEP', 'JUMP', 'USE', 'EXIT', '@FOCUS', 'ZERO'/
data option /'PARAMETERS', 'DATA', 'CALCULATION', 'FIT', 'MATRIX'/
!-----------------------------------------------------------------------------------------------------------------------------------
! Initialization
if (ns .le. 0) then
call remark ('ERROR: No. of datasets <= 0')
return
end if
do i = 1,ns
if (nd(i) .le. 0) then
call remark ('ERROR: No. of data points in dataset '//chint(i)//' <= 0')
return
end if
end do
if (nptot .le. 0) then
call remark ('ERROR: No. of parameters <= 0')
return
end if
call setup
fitted = .FALSE.
!-----------------------------------------------------------------------------------------------------------------------------------
! Input Command
1 call prompt ('#')
line_len = getlin (line)
if (line_len .eq. 0) go to 1
l = 1
word_len = getwrd (line(1:line_len), l, word)
if (word_len .gt. 0) then
call upcase (word(1:word_len))
else
go to 1
end if
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is DISPLAY
if (word(1:word_len) .eq. command(1)(1:word_len)) then
word_len = getwrd (line(1:line_len), l, word)
do while (word_len .eq. 0)
call prompt ('Data, Parameters, Calculation, Fit, Matrix :')
line_len = getlin (line)
if (line_len .eq. 0) then
word_len = 0
else
l = 1
word_len = getwrd (line(1:line_len), l, word)
end if
end do
if (word_len .gt. 0) call upcase (word(1:word_len))
! Option is PARAMETERS
if (word(1:word_len) .eq. option(1)(1:word_len)) then
call pardis (line, l)
! Option is DATA
else if (word(1:word_len) .eq. option(2)(1:word_len)) then
call datdis (line, l)
! Option is CALCULATION
else if (word(1:word_len) .eq. option(3)(1:word_len)) then
call caldis (fun, line, l)
! Option is FIT
else if (word(1:word_len) .eq. option(4)(1:word_len)) then
if (fitted) then
call fitdis
else
call remark ('ERROR: No fitted parameters available')
end if
! Option is MATRIX
else if (word(1:word_len) .eq. option(5)(1:word_len)) then
if (fitted) then
call print_corr (6)
else
call remark ('ERROR: Correlation matrix not yet determined')
end if
else
call remark ('ERROR: "'//word(1:word_len)//'" not recognized')
end if
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is PLOT
else if (word(1:word_len) .eq. command(2)(1:word_len)) then
call plot (line, l, fitted, fun)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is INPUT
else if (word(1:word_len) .eq. command(3)(1:word_len)) then
if (l .gt. line_len) then
call prompt ('Input filename :')
line_len = getlin (line)
l = 1
else
l = l + 1
end if
if (line_len .gt. 0 .and. l .le. line_len) call parin (line(l:line_len))
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is OUTPUT
else if (word(1:word_len) .eq. command(4)(1:word_len)) then
word_len = getwrd (line(1:line_len), l, word)
do while (word_len .eq. 0)
call prompt ('Parameters or Fit :')
line_len = getlin (line)
l = 1
word_len = getwrd (line(1:line_len), l, word)
end do
if (word_len .gt. 0) call upcase (word(1:word_len))
! Option is PARAMETERS
if (word(1:word_len) .eq. option(1)(1:word_len)) then
call parout (line, l)
! Option is CALCULATION
else if (word(1:word_len) .eq. option(3)(1:word_len)) then
call calout (fun, line, l)
! Option is FIT
else if (word(1:word_len) .eq. option(4)(1:word_len)) then
if (fitted) then
call fitout (line, l)
else
call remark ('ERROR: No fitted parameters available')
end if
else
call remark ('ERROR: "'//word(1:word_len)//'" not recognized')
end if
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is MODIFY
else if (word(1:word_len) .eq. command(5)(1:word_len)) then
call modify (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is REMOVE
else if (word(1:word_len) .eq. command(6)(1:word_len)) then
call remove_data (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is SET
else if (word(1:word_len) .eq. command(7)(1:word_len)) then
call setpar (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is FIX
else if (word(1:word_len) .eq. command(8)(1:word_len)) then
call fixpar (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is BIND
else if (word(1:word_len) .eq. command(9)(1:word_len)) then
call bndpar (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is CLEAR
else if (word(1:word_len) .eq. command(10)(1:word_len)) then
word_len = getwrd (line(1:line_len), l, word)
if (word_len .gt. 0) call upcase (word(1:word_len))
if (word_len .eq. 0) then
call setup
! Option is PARAMETERS
else if (word(1:word_len) .eq. option(1)(1:word_len)) then
call clepar (line, l)
! Option is DATA
else if (word(1:word_len) .eq. option(2)(1:word_len)) then
call cledat (line, l)
else
call remark ('ERROR: "'//word(1:word_len)//'" not recognized')
end if
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is LIMIT
else if (word(1:word_len) .eq. command(11)(1:word_len)) then
call limpar (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is ALTER
else if (word(1:word_len) .eq. command(12)(1:word_len)) then
call alter (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is TITLE
else if (word(1:word_len) .eq. command(13)(1:word_len)) then
i = 80
do while (i .gt. 1 .and. title(is)(i:i) .eq. ' ')
i = i - 1
end do
call remark ('Old title : '//title(is)(1:i))
call prompt ('Give new title :')
line_len = getlin (line)
if (line_len .gt. 0) title(is) = line(1:line_len)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is GO
else if (word(1:word_len) .eq. command(14)(1:word_len)) then
do i = 1,ns
do j = 1,nv(i)
if (vsig(inv(j,i),i) .le. 0.0) then
call remark ('ERROR: Zero error in point '//chint(inv(j,i)))
go to 1
end if
end do
end do
setnowarnings=1
call prtin
call pmfit (fun)
call prtout
setnowarnings=0
fitted = .TRUE.
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is HELP
else if (word(1:word_len) .eq. command(15)(1:word_len)) then
call help (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is KEEP
else if (word(1:word_len) .eq. command(16)(1:word_len)) then
call keep_plot (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is JUMP
else if (word(1:word_len) .eq. command(17)(1:word_len)) then
if (l .lt. line_len) then
call lib$spawn (line(l:line_len))
else
call remark ('# Spawning DCL sub-process - LOGOUT to return to FRILLS')
call lib$spawn ()
end if
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is USE
else if (word(1:word_len) .eq. command(18)(1:word_len)) then
call use_data (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is EXIT
else if (word(1:word_len) .eq. command(19)(1:word_len)) then
setnowarnings=1
return
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is @USER
else if (word(1:word_len) .eq. command(20)(1:word_len)) then
call user_command (fun, line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is ZERO
else if (word(1:word_len) .eq. command(21)(1:word_len)) then
call unlimpar (line, l)
!-----------------------------------------------------------------------------------------------------------------------------------
! Command is unrecognized
else
call remark ('ERROR: "'//word(1:word_len)//'" not recognized')
end if
go to 1
end