NLSL: shiftc.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

shiftc.f90
Go to the documentation of this file.
1 c NLSL Version 1.5.1 beta 1/20/96
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine SHIFTC
5 c =========================
6 c
7 c Interprets a line containing the "shift" command, which adjusts
8 c the shifting parameters for a selected spectrum, or for all spectra.
9 c
10 c Syntax:
11 c
12 c shift spectrum|index|ALL|* <value>|ON|OFF|RESET
13 c
14 c <spectrum>|<index> Spectrum name or index for which shifting
15 c is to be changed
16 c
17 c <value> New value of shift parameter
18 c
19 c ON Enable automatic shifting
20 c
21 c OFF Disable automatic shifting (fix at current
22 c value)
23 c
24 c RESET Add the shift parameter to B0 and reset
25 c the shift parameter to zero
26 c
27 c Includes:
28 c nlsdim.inc
29 c expdat.inc
30 c parcom.inc
31 c stdio.inc
32 c----------------------------------------------------------------------
33 subroutine shiftc( line )
34 c
35 use nlsdim
36 use expdat
37 use lmcom
38 use parcom
39 use iterat
40 use stdio
41 c
42 implicit none
43 character*80 line
44 c
45 integer NKEYWD
46 parameter(nkeywd=3)
47 c
48 double precision ZERO
49 parameter(zero=0.0d0)
50 c
51 integer ION,IOFF,IRESET,ISET,IADJST
52 parameter(ion=1,ioff=2,ireset=3,iset=4,iadjst=5)
53 c
54 integer i,iact,iflag,ival,ixsm,jx,jx1,jx2,lth
55 double precision fval
56 character*8 keywrd(nkeywd)
57 character*30 token
58 c
59 integer isfind,itrim,itemp(mxspc)
60 logical ftoken,itoken
61 double precision enorm
62 external enorm,ftoken,isfind,itoken,itrim
63 c
64 data keywrd /'ON','OFF','RESET'/
65 c
66 c ----------------------------------------
67 c Look for an index identifying spectrum
68 c ----------------------------------------
69 call gettkn(line,token,lth)
70 c
71 c Spectrum name/index expected
72 if (lth.eq.0) then
73 write (luout,1000)
74 return
75 end if
76 c
77 ixsm=isfind(token,lth)
78 if (ixsm.eq.0) then
79 if (.not.itoken(token,lth,ival)) then
80 if (token(:lth).eq.'ALL'.or.token(:lth).eq.'*') then
81 ival=-1
82 c *** Illegal index
83 else
84 write(luout,1001) token(:lth)
85 return
86 end if
87 end if
88 else
89 ival=abs( ixsm )
90 end if
91 c
92 if (ival.le.0) then
93 jx1=1
94 jx2=nspc
95 else
96 jx1=ival
97 jx2=ival
98 endif
99 c
100 c ---------------------
101 c Look for keywords
102 c ---------------------
103 5 call gettkn(line,token,lth)
104 lth=min(lth,8)
105 if (lth.eq.0) then
106 iact=iadjst
107 go to 10
108 end if
109 c
110 call touppr(token,lth)
111 do i=1,nkeywd
112 if (token(:lth).eq.keywrd(i)(:lth)) then
113 iact=i
114 go to 5
115 end if
116 end do
117 c
118 c -----------------------------------------------
119 c Not a keyword: is token a floating pt number?
120 c -----------------------------------------------
121 if (.not.ftoken(token,lth,fval)) then
122 write (luout,1003) token(:itrim(token))
123 if (luout.ne.luttyo) write(luttyo,1003) token(:itrim(token))
124 go to 5
125 else
126 iact=iset
127 end if
128 c
129 c ----------------------------------------------
130 c Make adjustment for specified range of sites
131 c ----------------------------------------------
132 10 do jx=jx1,jx2
133 if (iact.eq.ireset) then
134 sb0(jx)=sb0(jx)+shft(jx)
135 shft(jx)=zero
136 else if (iact.eq.iadjst) then
137 itemp(jx)=ishft(jx)
138 ishft(jx)=1
139 else if (iact.eq.ion) then
140 ishft(jx)=1
141 else if (iact.eq.ioff) then
142 ishft(jx)=0
143 else if (iact.eq.iset) then
144 shft(jx)=fval
145 ishft(jx)=0
146 end if
147 end do
148 c
149 c ----------------------------------------------------------------
150 c Set flag indicating whether shifting is enabled for any spectrum
151 c ----------------------------------------------------------------
152 ishglb=0
153 do i=1,nspc
154 if (ishft(i).ne.0) ishglb=1
155 end do
156 c
157 c --------------------------------------------------
158 c If shifting was turned on or a shift was adjusted,
159 c recalculate the spectra
160 c --------------------------------------------------
161 if (iact.eq.ion .or.iact.eq.iset .or.iact.eq.iadjst) then
162 call catchc( hltfit )
163 call xpack( x, nprm )
164 c
165 iflag=1
166 call lfun(ndatot,nprm,x,fvec,fjac,mxpt,iflag)
167 c
168 fnorm=enorm(ndatot,fvec)
169 write(luout,1046) fnorm
170 if (luout.ne.luttyo) write(luttyo,1046) fnorm
171 call sclstt( luout )
172 c
173 c --------------------------------------------------
174 c Reset shift parameters after single calculation
175 c --------------------------------------------------
176 do i=1,nspc
177 shft(i)=shft(i)+tmpshft(i)
178 tmpshft(i)=zero
179 end do
180 lmflag=1
181 info=11
182 call uncatchc( hltfit )
183 c
184 if (iact.eq.iadjst) then
185 do jx=jx1,jx2
186 ishft(jx)=itemp(jx)
187 end do
188 end if
189 end if
190 c
191 return
192 c
193 c######################################################################
194 c
195 1000 format('*** Spectrum ID expected ***')
196 1001 format('*** Illegal index: ''',a,''' ***')
197 1003 format('*** Illegal SHIFT value: ''',a,''' ***')
198 1046 format(/10x,'Recalculated RMS deviation =',g12.5/)
199 end
stdio::luout
integer, save luout
Definition: stdio.f90:32
iterat
Definition: iterat.f90:11
nlsdim::mxpt
integer, parameter mxpt
Definition: nlsdim.f90:39
shiftc
subroutine shiftc(line)
Definition: shiftc.f90:34
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
uncatchc
void FORTRAN() uncatchc(int *flag)
Definition: catch.c:49
expdat::ishft
integer, dimension(mxspc), save ishft
Definition: expdat.f90:45
expdat::tmpshft
double precision, dimension(mxspc), save tmpshft
Definition: expdat.f90:40
expdat::shft
double precision, dimension(mxspc), save shft
Definition: expdat.f90:40
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
nlsdim::mxspc
integer, parameter mxspc
Definition: nlsdim.f90:39
parcom::nprm
integer, save nprm
Definition: parcom.f90:62
expdat::nspc
integer, save nspc
Definition: expdat.f90:45
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
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
expdat::sb0
double precision, dimension(mxspc), save sb0
Definition: expdat.f90:40
xpack
subroutine xpack(x, n)
Definition: fitl.f90:222
expdat::ishglb
integer, save ishglb
Definition: expdat.f90:45
lmcom::x
double precision, dimension(mxjcol), save x
Definition: lmcom.f90:17