NLSL: fitc.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

fitc.f90
Go to the documentation of this file.
1 c Version 1.3 7/3/93
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine FITC
5 c =========================
6 c
7 c fit { trace xtol <xtol> ftol <ftol> gtol <ftol>
8 c maxfun <mxf> maxitr <mxi> bound <factor> }
9 c
10 c trace: Specifies that a ".trc" file should be produced for
11 c the fit
12 c xtol: Convergence tolerance for scaled fitting parameters
13 c ftol: Convergence tolerance for chi-squared
14 c gtol: Convergence tolerance for gradient of chi-squared with
15 c respect to the fitting parameters
16 c mxf: Maximum number of function calls allowed
17 c mxi: Maximum number of iterations allowed
18 c factor: Factor defining initial step bound used in parameter search
19 c
20 c----------------------------------------------------------------------
21 subroutine fitc( line )
22 c
23 use nlsdim
24 use lmcom
25 use parcom
26 use iterat
27 use stdio
28 c
29 implicit none
30 character line*80
31 c
32 logical ftoken
33 external ftoken
34 c
35 integer i,lth
36 double precision fval
37 character*30 token
38 c
39 integer NKEYWD
40 parameter(nkeywd=19)
41 c
42 integer itrim
43 external itrim
44 c
45 character*8 keywrd(nkeywd)
46 data keywrd / 'FTOL', 'GTOL', 'XTOL', 'BOUND', 'MAXFUN',
47 # 'MAXITR', 'SHIFT','SRANGE', 'TRACE', 'JACOBI',
48 # 'NOSHIFT','NEG', 'NONEG', 'TRIDIAG','ITERATES',
49 # 'WRITE', 'WEIGHTED', 'UNWEIGHT', 'CTOL' /
50 c
51 c######################################################################
52 c
53 c -- Reset "non-sticky" flags for fitting procedure
54 c
55 output=0
56 c
57 c----------------------------------------------------------------------
58 c Look for a keyword
59 c----------------------------------------------------------------------
60 c
61 14 call gettkn(line,token,lth)
62 lth=min(lth,8)
63 c
64 c---------------------------------------------------------------
65 c ****************************************
66 c No more keywords: **** call the NLS fitting routine ******
67 c ****************************************
68 c---------------------------------------------------------------
69 if (lth.eq.0) then
70 call fitl
71 return
72 end if
73 c
74 c------------------------------
75 c Check keyword list
76 c------------------------------
77 call touppr(token,lth)
78 do 15 i=1,nkeywd
79 if (token(:lth).eq.keywrd(i)(:lth)) goto 16
80 15 continue
81 c *** Unrecognized keyword
82 write (luttyo,1000) token(:lth)
83 return
84 c
85 c----------------------------------------------------------------------
86 c Keyword found: for keywords requiring an argument, convert
87 c next token and assign appropriate value
88 c----------------------------------------------------------------------
89 16 if ((i.ge.1 .and.i.le.8) .or. i.eq.19) then
90 call gettkn(line,token,lth)
91 c *** No value given
92 if (lth.eq.0) then
93 c *** default 0 for SHIFT keyword
94 if (i.eq.7) then
95 nshift=0
96 c *** otherwise, error
97 else
98 write(luttyo,1003) keywrd(i)(:itrim(keywrd(i)))
99 return
100 end if
101 end if
102 c
103 if (ftoken(token,lth,fval)) then
104 c *** FTOL keyword
105 if (i.eq.1) then
106 ftol=fval
107 c *** GTOL keyword
108 else if (i.eq.2) then
109 gtol=fval
110 c *** XTOL keyword
111 else if (i.eq.3) then
112 xtol=fval
113 c *** BOUND keyword
114 else if (i.eq.4) then
115 factor=fval
116 c *** MAXFUN keyword
117 else if (i.eq.5) then
118 maxev=int(fval)
119 c *** MAXITR keyword
120 else if (i.eq.6) then
121 maxitr=int(fval)
122 c *** SHIFT keyword
123 else if (i.eq.7) then
124 nshift=int(fval)
125 c *** SRANGE keyword
126 else if (i.eq.8) then
127 srange=fval/1.0d2
128 if (srange.gt.1.0d0) srange=1.0d0
129 if (srange.lt.0.0d0) srange=0.0d0
130 end if
131 c *** Illegal numeric value
132 else
133 if (i.eq.7) then
134 nshift=0
135 call ungett(token,lth,line)
136 else
137 write(luttyo,1001) token(:lth)
138 end if
139 end if
140 c *** TRACE keyword
141 else if (i.eq.9) then
142 if (luout.eq.luttyo) then
143 write (luttyo,1050)
144 itrace=0
145 else
146 itrace=1
147 end if
148 c *** JACOBI keyword
149 else if (i.eq.10) then
150 jacobi=1
151 c *** NOSHIFT keyword
152 else if (i.eq.11) then
153 nshift=-1
154 c *** NEG keyword
155 else if (i.eq.12) then
156 noneg=0
157 c *** NONEG keyword
158 else if (i.eq.13) then
159 noneg=1
160 c *** TRIDIAG keyword
161 else if (i.eq.14) then
162 itridg=1
163 c *** ITERATES keyword
164 else if (i.eq.15) then
165 iitrfl=1
166 c *** WRITE keyword
167 else if (i.eq.16) then
168 output=1
169 c *** WEIGHTED keyword
170 else if (i.eq.17) then
171 iwflag=1
172 c *** UNWEIGHT keyword
173 else if (i.eq.18) then
174 iwflag=0
175 c *** CTOL keyword
176 else if (i.eq.19) then
177 ctol=fval
178 end if
179 c
180 go to 14
181 c
182 c######################################################################
183 c
184 1000 format('*** Unrecognized FIT keyword: ''',a,''' ***')
185 1001 format('*** Numeric value expected: ''',a,''' ***')
186 1003 format('*** No value given for ''',a,''' ***')
187 1050 format('*** A log file must be opened before using TRACE ***')
188 end
stdio::luout
integer, save luout
Definition: stdio.f90:32
iterat
Definition: iterat.f90:11
parcom::noneg
integer, save noneg
Definition: parcom.f90:62
parcom::srange
double precision, save srange
Definition: parcom.f90:56
lmcom::ftol
double precision, pointer, save ftol
Definition: lmcom.f90:29
parcom::iitrfl
integer, save iitrfl
Definition: parcom.f90:62
parcom::itridg
integer, save itridg
Definition: parcom.f90:62
fitl
subroutine fitl
Definition: fitl.f90:20
stdio
Definition: stdio.f90:26
lmcom::gtol
double precision, pointer, save gtol
Definition: lmcom.f90:29
touppr
subroutine touppr(string, lth)
Definition: strutl2.f90:22
lmcom::maxev
integer, pointer, save maxev
Definition: lmcom.f90:32
parcom::output
integer, save output
Definition: parcom.f90:62
parcom
Definition: parcom.f90:42
iterat::iwflag
integer, save iwflag
Definition: iterat.f90:14
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
parcom::jacobi
integer, save jacobi
Definition: parcom.f90:62
parcom::nshift
integer, save nshift
Definition: parcom.f90:62
ungett
subroutine ungett(token, lth, line)
Definition: strutl1.f90:165
factor
double factor
Definition: genio.c:44
lmcom::xtol
double precision, pointer, save xtol
Definition: lmcom.f90:29
lmcom
Definition: lmcom.f90:13
fitc
subroutine fitc(line)
Definition: fitc.f90:22
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
parcom::ctol
double precision, save ctol
Definition: parcom.f90:56
nlsdim
Definition: nlsdim.f90:36
lmcom::maxitr
integer, pointer, save maxitr
Definition: lmcom.f90:32
stdio::itrace
integer, save itrace
Definition: stdio.f90:32