NLSL: scalec.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

scalec.f90
Go to the documentation of this file.
1 c NLSL Version 1.5 beta 11/23/95
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine SCALEC
5 c =========================
6 c
7 c Interprets a line containing the "scale" command. Used for adjusting
8 c scale factor and automatic scaling for a specific site or range of
9 c sites.
10 c
11 c Syntax:
12 c
13 c scale <index>|ALL|* <value>|AUTO|FIX
14 c
15 c <index> Site for which scale factor is to be adjusted
16 c
17 c <value> New value of scale factor
18 c
19 c ALL|* Apply command to all currently defined sites
20 c
21 c AUTO Enables automatic scaling of the site
22 c
23 c FIX Fixes scaling at present value
24 c
25 c Includes:
26 c nlsdim.inc
27 c expdat.inc
28 c parcom.inc
29 c stdio.inc
30 c----------------------------------------------------------------------
31 subroutine scalec( line )
32 c
33 use nlsdim
34 use expdat
35 use lmcom
36 use parcom
37 use mspctr
38 use iterat
39 use stdio
40 c
41 implicit none
42 character*80 line
43 c
44 integer i,iact,iflag,ival,ixsm,jx,jx1,jx2,lth
45 double precision fval
46 character*30 token
47 c
48 integer NKEYWD
49 parameter(nkeywd=2)
50 character*8 keywrd(nkeywd)
51 c
52 double precision ZERO
53 parameter(zero=0.0d0)
54 c
55 integer IAUTO,IFIX,IADJST
56 parameter(iauto=1,ifix=2,iadjst=3)
57 c
58 integer itrim
59 logical ftoken,itoken
60 double precision enorm
61 external enorm,ftoken,itoken,itrim
62 c
63 data keywrd /'AUTO', 'FIX' /
64 c
65 c
66 c ----------------------------------------
67 c Look for an index identifying spectrum
68 c ----------------------------------------
69 call gettkn(line,token,lth)
70 c
71 c *** Site index expected
72 if (lth.eq.0) then
73 write (luout,1000)
74 return
75 end if
76 c
77 c ----------------------------------------
78 c Look for ALL keyword or wildcard index
79 c ----------------------------------------
80 if (.not.itoken(token,lth,ival)) then
81 if (token(:lth).eq.'ALL'.or.token(:lth).eq.'*') then
82 ival=-1
83 c *** Illegal index
84 else
85 write(luout,1001) token(:lth)
86 return
87 end if
88 end if
89 c
90 if (ival.le.0) then
91 jx1=1
92 jx2=nsite
93 else
94 jx1=ival
95 jx2=ival
96 endif
97 c
98 c --------------------
99 c Look for a keyword
100 c --------------------
101 5 call gettkn(line,token,lth)
102 lth=min(lth,8)
103 if (lth.eq.0) go to 10
104 c
105 call touppr(token,lth)
106 do i=1,nkeywd
107 if (token(:lth).eq.keywrd(i)(:lth)) then
108 iact=i
109 go to 5
110 end if
111 end do
112 c
113 c ---------------------------------------------
114 c Not a keyword: is token a floating pt number?
115 c ---------------------------------------------
116 if (.not.ftoken(token,lth,fval)) then
117 write (luout,1003) token(:itrim(token))
118 if (luout.ne.luttyo) write(luttyo,1003) token(:itrim(token))
119 go to 5
120 else
121 iact=iadjst
122 end if
123 c
124 c -----------------------------------------------
125 c Do not fix scale factor if shifting is enabled
126 c -----------------------------------------------
127 if ((iact.eq.ifix .or. iact.eq.iadjst) .and. ishglb.ne.0) then
128 write (luout,1005)
129 if (luout.ne.luttyo) write (luttyo,1005)
130 return
131 end if
132 c
133 c --------------------------------------------
134 c Perform action for specified range of sites
135 c --------------------------------------------
136 10 do jx=jx1,jx2
137 c
138 c Float scale factor
139 if (iact.eq.iauto) then
140 iscal(jx)=1
141 c
142 c Fix scale factor at present value
143 else if (iact.eq.ifix) then
144 iscal(jx)=0
145 c
146 c Set scale factor to given value
147 else if (iact.eq.iadjst) then
148 do i=1,nspc
149 sfac(jx,i)=fval
150 end do
151 iscal(jx)=0
152 end if
153 end do
154 c
155 c ------------------------------------------------------------------
156 c Set flag indicating whether autoscaling is enabled for all sites
157 c ------------------------------------------------------------------
158 iscglb=1
159 do i=1,nsite
160 if (iscal(i).eq.0) iscglb=0
161 end do
162 c
163 c ------------------------------------------------------------
164 c Repeat function calculation if a scale factor was "floated"
165 c or changed by the user, and report the results
166 c ------------------------------------------------------------
167 if (iact.eq.iauto .or. iact.eq.iadjst) then
168 call catchc( hltfit )
169 call xpack( x, nprm )
170 c
171 iflag=1
172 call lfun(ndatot,nprm,x,fvec,fjac,mxpt,iflag)
173 c
174 fnorm=enorm(ndatot,fvec)
175 write(luout,1004) fnorm
176 if (luout.ne.luttyo) write(luttyo,1004) fnorm
177 call sclstt( luout )
178 c
179 lmflag=1
180 info=11
181 call uncatchc( hltfit )
182 end if
183 c
184 return
185 c
186 c######################################################################
187 c
188 1000 format('*** Site index expected ***')
189 1001 format('*** Illegal index: ''',a,''' ***')
190 1003 format('*** Unrecognized SCALE keyword: ''',a,''' ***')
191 1004 format(/10x,'Recalculated RMS deviation =',g12.5/)
192 1005 format('*** Scale cannot be fixed when shifting is enabled ***')
193 end
stdio::luout
integer, save luout
Definition: stdio.f90:32
iterat
Definition: iterat.f90:11
nlsdim::mxpt
integer, parameter mxpt
Definition: nlsdim.f90:39
info
char info[81]
Definition: genio.c:45
lfun
subroutine lfun(m, n, x, fvec, fjac, ldfjac, iflag)
Subroutine for interfacing EPRLL spectral calculations with the MINPACK version of the Levenberg-Marq...
Definition: lfun.f90:68
expdat::ndatot
integer, save ndatot
Definition: expdat.f90:45
mspctr::iscglb
integer, save iscglb
Definition: mspctr.f90:32
uncatchc
void FORTRAN() uncatchc(int *flag)
Definition: catch.c:49
mspctr::sfac
double precision, dimension(mxsite, mxspc), save sfac
Definition: mspctr.f90:33
stdio::hltfit
integer, save hltfit
Definition: stdio.f90:32
stdio
Definition: stdio.f90:26
touppr
subroutine touppr(string, lth)
Definition: strutl2.f90:22
iterat::fnorm
double precision, save fnorm
Definition: iterat.f90:15
parcom
Definition: parcom.f90:42
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::nprm
integer, save nprm
Definition: parcom.f90:62
expdat::nspc
integer, save nspc
Definition: expdat.f90:45
parcom::nsite
integer, save nsite
Definition: parcom.f90:62
mspctr::iscal
integer, dimension(mxsite), save iscal
Definition: mspctr.f90:32
lmcom::fjac
double precision, dimension(mxpt, mxjcol), save fjac
Definition: lmcom.f90:17
lmcom::fvec
double precision, dimension(mxpt), save fvec
Definition: lmcom.f90:17
lmcom::lmflag
integer, save lmflag
Definition: lmcom.f90:24
scalec
subroutine scalec(line)
Definition: scalec.f90:32
sclstt
subroutine sclstt(lu)
Definition: statc.f90:401
catchc
void FORTRAN() catchc(int *flag)
Definition: catch.c:33
lmcom
Definition: lmcom.f90:13
expdat
Definition: expdat.f90:36
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
nlsdim
Definition: nlsdim.f90:36
xpack
subroutine xpack(x, n)
Definition: fitl.f90:222
mspctr
Definition: mspctr.f90:28
expdat::ishglb
integer, save ishglb
Definition: expdat.f90:45
lmcom::x
double precision, dimension(mxjcol), save x
Definition: lmcom.f90:17