NLSL: letc.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

letc.f90
Go to the documentation of this file.
1 c Version 1.5.1 beta 2/3/96
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine LETC
5 c =========================
6 c
7 c let <name>{(index)} {, <name>,...} = <value> {, <value> ... }
8 c
9 c name : name of the parameter to be assigned a value
10 c index : site or spectral index of parameter
11 c value : value to be assigned to the given parameter
12 c
13 c Up to 10 variables may be assigned values in a single let command
14 c
15 c----------------------------------------------------------------------
16 subroutine letc( line )
17 c
18 use nlsdim
19 use eprprm
20 use expdat
21 c use prmeqv
22 use parcom
23 use lpnam
24 use stdio
25 c
26 implicit none
27 character*80 line
28 c
29 integer MXLFT
30 parameter(mxlft=10)
31 c
32 integer i,ileft,irt,ival,ixf,ixr,ixr2,ixs,ixt,ixxa,
33 # lth,llth,left(mxlft),leftx(mxlft)
34 double precision fval
35 character token*30,prmID*9
36 logical rhs,logflg
37 c
38 integer ipfind,isfind,indtkn,itrim,ixlim
39 double precision getprm
40 logical ftoken,itoken,tcheck,spcpar
41 character*7 ptype
42 external ftoken,itoken,tcheck,ipfind,isfind,itrim,indtkn,
43 # spcpar,ptype,ixlim,getprm
44 c
45 c######################################################################
46 c
47 rhs=.false.
48 logflg=.false.
49 ileft=1
50 c
51 c----------------------------------------------------------------------
52 c Get the next parameter name (or value for right-hand-side of statement)
53 c----------------------------------------------------------------------
54 1 call gettkn(line,token,lth)
55 lth=min(lth,6)
56 call touppr(token,lth)
57 c
58 c----------------------------------------------------------------------
59 c No more tokens: check for error conditions
60 c----------------------------------------------------------------------
61 if (lth.eq.0) then
62 if (rhs) then
63 c *** not enough values
64 write (luttyo,1000)
65 else
66 if (ileft.eq.1) then
67 c *** variable name expected
68 write (luttyo,1001)
69 else
70 c *** no '=' given
71 write(luttyo,1002)
72 end if
73 end if
74 return
75 end if
76 c
77 if (token.eq.')' .or. (logflg.and.token.eq.'(')) goto 1
78 c
79 if (token.eq.'LOG'.and.rhs) then
80 logflg=.true.
81 go to 1
82 end if
83 c
84 c----------------------------------------------------------------------
85 c Check for '=' sign in assignment
86 c----------------------------------------------------------------------
87 if (token.eq.'=') then
88 rhs=.true.
89 irt=1
90 go to 1
91 end if
92 c
93 c----------------------------------------------------------------------
94 c Right-hand side: assign value to parameter specified in left array
95 c----------------------------------------------------------------------
96 if (rhs) then
97 ixr=left(irt)
98 ixr2=leftx(irt)
99 irt=irt+1
100 c
101 c ---------------------------------------------------
102 c Make assignment for legal parameter names/indices
103 c ---------------------------------------------------
104 if (ixr.ne.0) then
105 if (ixr2.lt.1) ixr2=0
106 c
107 c ---------------------------------------------
108 c Set the name of the parameter being assigned
109 c ---------------------------------------------
110 if (ixr.lt.-100 .and. ixr.gt.-200) then
111 prmid=alias2(-99-(iwxx+ixr))
112 else if (ixr.lt.0) then
113 prmid=alias1(1-(iwxx+ixr))
114 else if (ixr.gt.100) then
115 prmid=parnam(ixr-100)
116 else if (ixr.gt.0 .and. ixr.lt.100) then
117 prmid=parnam(ixr)
118 end if
119 c
120 c -----------------------------
121 c Get the value being assigned
122 c -----------------------------
123 if (ixr.lt.100) then
124 c
125 c -------------------------------
126 c Look for a floating-point token
127 c -------------------------------
128 if (.not.ftoken(token,lth,fval)) then
129 write(luttyo,1004) token(:lth)
130 else
131 if(logflg) then
132 if (fval.gt.0.0d0) then
133 fval=dlog10(fval)
134 else
135 c *** illegal log arg
136 write(luttyo,1011) fval
137 end if
138 logflg=.false.
139 end if
140 end if
141 c
142 else
143 c
144 c --------------------------------------------------------
145 c Look for a symbolic value: pre-defined symbol or ID name
146 c --------------------------------------------------------
147 ixs=isfind(token,lth)
148 if (ixs.ne.0) then
149 if (ixs.gt.0) ival=symval(ixs)
150 if (ixs.lt.0) ival=abs(ixs)
151 c
152 c -------------------------
153 c Look for an integer token
154 c -------------------------
155 else if (.not.itoken(token,lth,ival)) then
156 write(luttyo,1005) token(:lth)
157 end if
158 c
159 c if (ixr.lt.100)...else...
160 end if
161 c
162 c -------------------------------
163 c Assign the floating point value
164 c -------------------------------
165 if (ixr.lt.100) then
166 if (tcheck(ixr,ixr2,prmid,luout)) then
167 c
168 c ---------------------------------------------
169 c Issue a warning if:
170 c (1) the parameter is being set for a specific
171 c site/spectrum when it is being varied for
172 c *all* sites/spectra
173 c (2) the parameter is being set for all sites/spectra
174 c when its current value is different for the
175 c currently defined sites/spectra
176 c ---------------------------------------------
177 c
178 c
179 llth=itrim(prmid)
180 ixxa=ixx(iabs(mod(ixr,100)),ixr2+1)
181 if (ixxa.gt.0 .and. (ixr2.ge.1 .and. ixst(ixxa).lt.1))
182 # write (luttyo,1012) parnam(ixr)(:llth)
183 c
184 if (ixr2.lt.1) then
185 do i=2,ixlim(ixr)
186 if (getprm(ixr,i).ne.getprm(ixr,1)) then
187 write(luttyo,1013) parnam(ixr)(:llth),
188 # ptype(ixr)
189 go to 2
190 end if
191 end do
192 end if
193
194 c
195 2 call setprm(ixr,ixr2,fval)
196 c
197 end if
198 c
199 else
200 c ------------------------
201 c Assign the integer value
202 c ------------------------
203 call setipr(ixr,ixr2,ival)
204 c
205 end if
206 c
207 c if (ixr.ne.0) ....
208 end if
209 c
210 c --------------------------------------------------
211 c Return if all assignments have been made
212 c --------------------------------------------------
213 if (irt.ge.ileft) return
214 c
215 c----------------------------------------------------------------------
216 c Left-hand side: build a list of indices of parameters to be assigned
217 c----------------------------------------------------------------------
218 c
219 else if (ileft.le.mxlft) then
220 left(ileft)=ipfind(token,lth)
221 if (left(ileft).eq.0) write (luttyo,1003) token(:lth)
222 leftx(ileft)=indtkn(line)
223 ileft=ileft+1
224 end if
225 go to 1
226 c
227 c ###### format statements ########################################
228 c
229 1000 format('*** Not enough values specified ***')
230 1001 format('*** Variable name expected ***')
231 1002 format('*** No ''='' specified ***')
232 1003 format('*** ''',a,''' is not a parameter ***')
233 1004 format('*** Real value expected: ''',a,''' ***')
234 1005 format('*** Integer value expected: ''',a,''' ***')
235 1011 format('*** Illegal log argument:',g12.5,' ***')
236 1012 format('*** Warning: ',a,' is being varied globally ***')
237 1013 format('*** Warning: ',a,' is now the same for all ',a,' ***')
238 end
stdio::luout
integer, save luout
Definition: stdio.f90:32
parcom::ixst
integer, dimension(mxvar), save ixst
Definition: parcom.f90:62
setipr
subroutine setipr(ixparm, ixsite, ival)
Analogous routine to setprm for integer parameters There are only two user-settable integer spectrum ...
Definition: setprm.f90:142
lpnam::alias1
character *6, dimension(nalias), save alias1
Definition: lpnam.f90:45
lpnam::symval
integer, dimension(nsymbl), save symval
Definition: lpnam.f90:64
stdio
Definition: stdio.f90:26
touppr
subroutine touppr(string, lth)
Definition: strutl2.f90:22
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
eprprm::iwxx
integer, parameter iwxx
Definition: eprprm.f90:92
lpnam
Definition: lpnam.f90:18
expdat
Definition: expdat.f90:36
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
eprprm
Definition: eprprm.f90:51
nlsdim
Definition: nlsdim.f90:36
parcom::ixx
integer, dimension(nfprm, mxsite), save ixx
Definition: parcom.f90:62
setprm
subroutine setprm(ixparm, ixsite, fval)
This file contains two routines that set a given parameter, specified by an index into the fparm or i...
Definition: setprm.f90:34
lpnam::parnam
character *6, dimension(nfprm), save parnam
Definition: lpnam.f90:27
letc
subroutine letc(line)
Definition: letc.f90:17
lpnam::alias2
character *6, dimension(nalias), save alias2
Definition: lpnam.f90:51