NLSL: series.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

series.f90
Go to the documentation of this file.
1 c NLSL Version 1.5 beta 11/24/95
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine SERIES
5 c =========================
6 c
7 c Interpret a "series" command from the given line.
8 c The command is of the form:
9 c
10 c series <name> { {=} <value>, <value> { , <value>...} }
11 c
12 c name : Name of a variable parameter
13 c value : List of values assumed by the named parameter
14 c for each spectrum in the series
15 c
16 c If a "series" command is given without an argument, it resets
17 c the calculation to a single spectum
18 c----------------------------------------------------------------------
19 subroutine series( line )
20 c
21 use nlsdim
22 use eprprm
23 use expdat
24 use mspctr
25 use parcom
26 use stdio
27 c
28 implicit none
29 character line*80
30 c
31 integer i,ix,lth,nser1,iser1
32 double precision fval
33 character token*30
34 c
35 integer ipfind
36 logical ftoken
37 external ftoken,ipfind
38 c
39 iser1=iser
40 nser1=nser
41 c
42 c----------------------------------------------------------------------
43 c Get name of series parameter
44 c----------------------------------------------------------------------
45 call gettkn(line,token,lth)
46 lth=min(lth,6)
47 c *** No series variable specified: reset
48 if (lth.eq.0) then
49 iser=0
50 nser=1
51 write(luout,1002)
52 return
53 end if
54 c
55 c----------------------------------------
56 c Check whether parameter may be varied
57 c----------------------------------------
58 call touppr(token,lth)
59 ix=ipfind(token,lth)
60 c
61 if (ix.eq.0.or.ix.gt.ib0) then
62 write (luttyo,1001) token(:lth)
63 return
64 end if
65 c
66 iser=ix
67 nser=0
68 c
69 c----------------------------------------------------------------------
70 c Get a list of values for the series parameter
71 c----------------------------------------------------------------------
72 10 call gettkn(line,token,lth)
73 c
74 c------------------------------
75 c No more values--exit
76 c------------------------------
77 if (lth.eq.0) then
78 c *** Must have been at least 2 in series
79 if (nser.lt.2) then
80 write(luttyo,1004)
81 iser=iser1
82 nser=nser1
83 end if
84 c
85 c --- Copy spectral parameters from spectrum 1 for all new
86 c series members (Note that B0, FIELDI, DFLD, RANGE, NFIELD,
87 c IDERIV supplied here as defaults will be obtained from the
88 c datafiles if they are available
89
90 if (nser.gt.nser1) then
91 do ix=nser1+1,nser
92 slb(ix)=slb(1)
93 sphs(ix)=sphs(1)
94 spsi(ix)=spsi(1)
95 sb0(ix)=sb0(1)
96 sbi(ix)=sbi(1)
97 sdb(ix)=sdb(1)
98 srng(ix)=srng(1)
99 npts(ix)=npts(1)
100 nft(ix)=nft(1)
101 idrv(ix)=idrv(1)
102 c
103 do i=1,mxsite
104 sfac(i,ix)=1.0d0
105 end do
106 c
107 end do
108 c
109 end if
110 return
111 c
112 end if
113 c
114 c Check for optional '=' after parameter name
115 c
116 if (token(:lth).eq.'='.and.nser.eq.0) goto 10
117 c
118 if (ftoken(token,lth,fval)) then
119 if (nser.ge.mxspc) then
120 write (luttyo,1005) mxspc
121 return
122 end if
123 c
124 c *** Increment series list
125 nser=nser+1
126 serval(nser)=fval
127 c *** Illegal real number
128 else
129 write(luttyo,1003) token(:lth)
130 end if
131 c
132 go to 10
133 c
134 c ###### format statements ######################################
135 c
136 1001 format('*** ''',a,''' is not a variable parameter ***')
137 1002 format('*** SERIES reset to single spectrum ***')
138 1003 format('*** Real value expected: ''',a,''' ***')
139 1004 format('*** SERIES must have at least 2 values ***')
140 1005 format('*** SERIES may not have more than',i2,
141 # ' values: remainder ignored ***')
142 end
stdio::luout
integer, save luout
Definition: stdio.f90:32
expdat::sbi
double precision, dimension(mxspc), save sbi
Definition: expdat.f90:40
expdat::sdb
double precision, dimension(mxspc), save sdb
Definition: expdat.f90:40
expdat::nft
integer, dimension(mxspc), save nft
Definition: expdat.f90:45
expdat::srng
double precision, dimension(mxspc), save srng
Definition: expdat.f90:40
series
subroutine series(line)
Definition: series.f90:20
mspctr::sfac
double precision, dimension(mxsite, mxspc), save sfac
Definition: mspctr.f90:33
stdio
Definition: stdio.f90:26
expdat::spsi
double precision, dimension(mxspc), save spsi
Definition: expdat.f90:40
touppr
subroutine touppr(string, lth)
Definition: strutl2.f90:22
parcom
Definition: parcom.f90:42
parcom::serval
double precision, dimension(mxspc), save serval
Definition: parcom.f90:56
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
expdat::sphs
double precision, dimension(mxspc), save sphs
Definition: expdat.f90:40
nlsdim::mxsite
integer, parameter mxsite
Definition: nlsdim.f90:39
parcom::nser
integer, save nser
Definition: parcom.f90:62
eprprm::ib0
integer, parameter ib0
Definition: eprprm.f90:92
expdat::idrv
integer, dimension(mxspc), save idrv
Definition: expdat.f90:45
parcom::iser
integer, save iser
Definition: parcom.f90:62
expdat
Definition: expdat.f90:36
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
eprprm
Definition: eprprm.f90:51
nlsdim
Definition: nlsdim.f90:36
expdat::sb0
double precision, dimension(mxspc), save sb0
Definition: expdat.f90:40
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