NLSL: datac.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

datac.f90
Go to the documentation of this file.
1 c NLSL Version 1.5 beta 11/25/95
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine DATAC
5 c =========================
6 c
7 c Interprets a "data" command from the given line. The format of
8 c the command is as follows:
9 c
10 c data <dataid> { format <iform> bcmode <ibc> nspline <n> deriv <idrv> }
11 c dataid : base name for datafile and associated output files:
12 c <dataid>.DAT -- datafile
13 c <dataid>.SPC -- fit spectrum
14 c iform : input format
15 c 0 = ASCII 2-column format (default)
16 c 1 = PC-Genplot binary
17 c ibc : baseline correction mode
18 c 0 = no baseline correction (default)
19 c 1 = subtract constant to give zero integral
20 c n = fit a line to the n points at each end of
21 c of the spectrum
22 c n : number of splined points, or 0 for no spline
23 c (default=zero)
24 c idrv : derivative mode
25 c 0 = 0th derivative (absorption) mode
26 c 1 = 1st derivative mode (default)
27 c
28 c----------------------------------------------------------------------
29 subroutine datac( line )
30 c
31 use nlsdim
32 use expdat
33 use lmcom
34 use parcom
35 use nlsnam
36 use mspctr
37 use stdio
38 use rnddbl
39 c
40 implicit none
41 character line*80,token*30
42 c
43 integer NKEYWD
44 parameter(nkeywd=9)
45 c
46 integer i,iret,ispc,ival,ix,ixs,j,lth,ncmts,normlz
47 character*80 comment(mxcmt)
48 c
49 logical itoken
50 integer getdat,itrim,newwindow
51 external itoken,itrim,getdat,newwindow
52 c
53 character*8 keywrd(nkeywd)
54 data keywrd /'ASCII','BINARY','BCMODE','DERIV','NSPLINE',
55 # 'NOSHIFT','SHIFT','NORM','NONORM'/
56 c
57 c----------------------------------------------------------------------
58 c Get the name of the datafile
59 c----------------------------------------------------------------------
60 call gettkn(line,token,lth)
61 c
62 c----------------------------------------------------------------------
63 c If (1) no data name was specified, or (2) the number of datafiles
64 c already read in equals the number of spectra to be calculated (nser)
65 c then reset the data buffer
66 c----------------------------------------------------------------------
67 if (lth.eq.0.or.nspc.ge.nser) then
68 nspc=0
69 ndatot=0
70 write(luttyo,1020)
71 if (lth.eq.0) return
72 end if
73 c
74 nspc=nspc+1
75 dataid(nspc)=token
76 c
77 c -----------------------------------------------------
78 c Force normalization for multisite-multispectrum fits
79 c -----------------------------------------------------
80 if (nsite.gt.1.and.nser.gt.1) normflg=1
81 c
82 c --------------------
83 c Look for a keyword
84 c --------------------
85 5 call gettkn(line,token,lth)
86 if (lth.ne.0) then
87 lth=min(lth,8)
88 call touppr(token,lth)
89 do i=1,nkeywd
90 if (token(:lth).eq.keywrd(i)(:lth)) go to 7
91 end do
92 c
93 write (luttyo,1000) token(:lth)
94 go to 5
95 c
96 c----------------------------------------------------------------------
97 c Keyword found: assign appropriate value using next token
98 c----------------------------------------------------------------------
99 c
100 c ---------------------------------------------------
101 c The BCMODE, DERIV, and NSPLINE keywords require an
102 c integer argument
103 c -------------------------------------------------------
104 7 if (i.ge.3 .and. i.le.5) then
105 c
106 call gettkn(line,token,lth)
107 c *** No value given
108 if (lth.eq.0) then
109 write(luttyo,1003) keywrd(i)(:itrim(keywrd(i)))
110 return
111 end if
112 c
113 if (itoken(token,lth,ival)) then
114 c *** BCMODE keyword
115 if (i.eq.3) then
116 bcmode=ival
117 c *** DERIV keyword
118 else if (i.eq.4) then
119 drmode=ival
120 c *** NSPLINE keyword
121 else if (i.eq.5) then
122 nspline=ival
123 end if
124 c *** Illegal integer token!
125 else
126 write(luttyo,1010) token(:lth)
127 end if
128 c
129 c----------------------------------------------------------------------
130 c --- Non-argument keywords:
131 c ASCII, BINARY, SHIFT, NOSHIFT, NORM, NONORM
132 c----------------------------------------------------------------------
133 c
134 else
135 c *** ASCII keyword
136 if (i.eq.1) then
137 inform=0
138 c *** BINARY keyword
139 else if (i.eq.2) then
140 inform=1
141 c *** NOSHIFT keyword
142 else if (i.eq.6) then
143 shftflg=0
144 c *** SHIFT keyword
145 else if (i.eq.7) then
146 shftflg=1
147 c *** NORM keyword
148 else if (i.eq.8) then
149 normflg=1
150 c *** NONORM keyword
151 else if (i.eq.9) then
152 normflg=0
153 end if
154 end if
155 go to 5
156 c
157 c----------------------------------------------------------------------
158 c No more tokens on the line: read in datafile
159 c----------------------------------------------------------------------
160 else
161 iform(nspc)=inform
162 ibase(nspc)=bcmode
163 ishft(nspc)=shftflg
164 npts(nspc)=nspline
165 idrv(nspc)=drmode
166 nrmlz(nspc)=normflg
167 c
168 call setdat( dataid(nspc) )
169 c
170 c -----------------------------------------------------
171 c Check whether an acceptable number of spline points
172 c has been specified and modify if necessary
173 c -----------------------------------------------------
174
175 if ( npts(nspc).ne.0 .and.
176 # (npts(nspc).lt.4 .or. npts(nspc).gt.mxspt)
177 # ) then
178 npts(nspc)=max(4,npts(nspc))
179 npts(nspc)=min(mxspt,npts(nspc))
180 write(luttyo,1040) npts(nspc)
181 end if
182 c
183 c -------------------------------------------------------
184 c Check whether there is enough storage for the new data
185 c --------------------------------------------------------
186 ix=ndatot+1
187 if ( (npts(nspc).eq.0 .and. ix+mxspt.gt.mxpt)
188 # .or.(npts(nspc).gt.0 .and. ix+npts(nspc).gt.mxpt) ) then
189 write(luttyo,1050) mxpt
190 nspc=nspc-1
191 return
192 end if
193 c
194 iret=getdat(dtname,iform(nspc),ibase(nspc),npts(nspc),
195 # idrv(nspc),nrmlz(nspc),luout,comment,ncmts,data(ix),
196 # sbi(nspc),sdb(nspc),rmsn(nspc),spltmp,spltmp(1,2),
197 # spltmp(1,3) )
198 c
199 c *** Error opening/reading datafile
200 if (iret.ne.0) then
201 write(luttyo,1060) dtname(:lthdnm)
202 nspc=nspc-1
203 return
204 end if
205 c
206 c -------------------------------------------------------------
207 c Find smallest power of 2 greater than or equal to the number
208 c of data points (for Fourier-Transform applications)
209 c -------------------------------------------------------------
210 nft(nspc)=1
211 9 nft(nspc)=nft(nspc)*2
212 if (nft(nspc).lt.npts(nspc)) go to 9
213 c
214 ixsp(nspc)=ix
215 shft(nspc)=0.0d0
216 slb(nspc)=0.0d0
217 srng(nspc)=sdb(nspc)*(npts(nspc)-1)
218 if (ishft(nspc).ne.0) ishglb=1
219 c
220 write (wndoid(nspc),1070) nspc,
221 # dataid(nspc)(:itrim(dataid(nspc))),char(0)
222 if (rmsn(nspc).le.rndoff) rmsn(nspc)=1.0d0
223 ndatot=ndatot+npts(nspc)
224 c
225 c -----------------------------------
226 c If nspc > nwin create a new window
227 c -----------------------------------
228 c if (nspc.gt.nwin) then
229 c nwin = newwindow( wndoid )
230 c
231 c
232 c ------------------------------------------------------------------
233 c Call getwindows and plot files when the last datafile is read in
234 c nser = number of spectra in the series
235 c wndoid = character array of window I.D.'s
236 c defined as character*20 wndoid(mxspc) in expdat.inc
237 c ------------------------------------------------------------------
238 if (nspc.eq.nser) then
239 call getwndws( nspc, wndoid )
240
241 c ------------------------------------------
242 c Set fvec array to equal the data array
243 c (calculated spectrum=0) and plot the data
244 c -------------------------------------------
245 do ispc=1,nspc
246 do i=1,npts(ispc)
247 j=ixsp(ispc)+i-1
248 fvec(j)=data(j)
249 end do
250 c
251 ixs=ixsp(ispc)
252 sfac(1,ispc)=1.0d0
253 c call pltwin( data(ixs),fvec(ixs),spectr(ixs,1),
254 c * sfac(1,ispc),MXPT,npts(ispc),nsite,ispc )
255 call fstplt( data(ixsp(ispc)), fvec(ixsp(ispc)),
256 # sbi(ispc), sdb(ispc), npts(ispc), ispc )
257 c
258 end do
259 c
260 end if
261 c
262 end if
263 return
264 c
265 c #### format statements ########################################
266 c
267 1000 format('*** Unrecognized DATA keyword: ''',a,''' ***')
268 1003 format('*** No value given for ''',a,''' ***')
269 1010 format('*** Integer value expected: ''',a,''' ***')
270 1020 format('*** Data buffer has been reset *** ')
271 1040 format('*** Number of splined points reset to ',i4,' ***')
272 1050 format('*** Maximum number of data points (',i4,') exceeded ***')
273 1060 format(/13x,'*** Error opening or reading datafile ''',a,
274 # ''' ***'/)
275 1070 format(i2,': ',a,a1)
276 end
277
stdio::luout
integer, save luout
Definition: stdio.f90:32
expdat::nrmlz
integer, dimension(mxspc), save nrmlz
Definition: expdat.f90:45
nlsdim::mxpt
integer, parameter mxpt
Definition: nlsdim.f90:39
expdat::sbi
double precision, dimension(mxspc), save sbi
Definition: expdat.f90:40
expdat::drmode
integer, save drmode
Definition: expdat.f90:45
expdat::ndatot
integer, save ndatot
Definition: expdat.f90:45
expdat::sdb
double precision, dimension(mxspc), save sdb
Definition: expdat.f90:40
fstplt
void FORTRAN() fstplt(double *y1, double *y2, double *xmin1, double *xstep1, int *indx1, int *wnum)
Definition: pltx.c:805
nlsnam::dtname
character *30, save dtname
Definition: nlsnam.f90:28
expdat::nft
integer, dimension(mxspc), save nft
Definition: expdat.f90:45
expdat::ixsp
integer, dimension(mxspc), save ixsp
Definition: expdat.f90:45
expdat::inform
integer, save inform
Definition: expdat.f90:45
expdat::srng
double precision, dimension(mxspc), save srng
Definition: expdat.f90:40
expdat::ishft
integer, dimension(mxspc), save ishft
Definition: expdat.f90:45
expdat::ibase
integer, dimension(mxspc), save ibase
Definition: expdat.f90:45
nlsdim::mxcmt
integer, parameter mxcmt
Definition: nlsdim.f90:39
mspctr::sfac
double precision, dimension(mxsite, mxspc), save sfac
Definition: mspctr.f90:33
expdat::shft
double precision, dimension(mxspc), save shft
Definition: expdat.f90:40
nlsdim::mxspt
integer, parameter mxspt
Definition: nlsdim.f90:39
stdio
Definition: stdio.f90:26
expdat::dataid
character *30, dimension(mxspc), save dataid
Definition: expdat.f90:51
expdat::wndoid
character *20, dimension(mxspc), save wndoid
Definition: expdat.f90:52
nlsnam::lthdnm
integer, save lthdnm
Definition: nlsnam.f90:27
touppr
subroutine touppr(string, lth)
Definition: strutl2.f90:22
expdat::normflg
integer, save normflg
Definition: expdat.f90:45
parcom
Definition: parcom.f90:42
nlsnam
Definition: nlsnam.f90:21
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
expdat::bcmode
integer, save bcmode
Definition: expdat.f90:45
expdat::nspc
integer, save nspc
Definition: expdat.f90:45
parcom::nsite
integer, save nsite
Definition: parcom.f90:62
setdat
subroutine setdat(dataid)
Definition: setnm.f90:67
lmcom::fvec
double precision, dimension(mxpt), save fvec
Definition: lmcom.f90:17
parcom::nser
integer, save nser
Definition: parcom.f90:62
expdat::spltmp
double precision, dimension(mxinp, 3), save spltmp
Definition: expdat.f90:40
expdat::nspline
integer, save nspline
Definition: expdat.f90:45
expdat::idrv
integer, dimension(mxspc), save idrv
Definition: expdat.f90:45
lmcom
Definition: lmcom.f90:13
getwndws
void FORTRAN() getwndws(int *n, word *title)
Definition: pltx.c:589
expdat
Definition: expdat.f90:36
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
rnddbl
Definition: rnddbl.f90:77
expdat::iform
integer, dimension(mxspc), save iform
Definition: expdat.f90:45
datac
subroutine datac(line)
Definition: datac.f90:30
nlsdim
Definition: nlsdim.f90:36
expdat::rmsn
double precision, dimension(mxspc), save rmsn
Definition: expdat.f90:40
expdat::shftflg
integer, save shftflg
Definition: expdat.f90:45
expdat::npts
integer, dimension(mxspc), save npts
Definition: expdat.f90:45
expdat::slb
double precision, dimension(mxspc), save slb
Definition: expdat.f90:40
mspctr
Definition: mspctr.f90:28
expdat::ishglb
integer, save ishglb
Definition: expdat.f90:45
rnddbl::rndoff
double precision, parameter rndoff
Definition: rnddbl.f90:86
lmcom::x
double precision, dimension(mxjcol), save x
Definition: lmcom.f90:17