NLSL: assgnc.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

assgnc.f90
Go to the documentation of this file.
1 c NLSL Version 1.3.2 2/27/94
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine ASSGNC
5 c =========================
6 c
7 c Interprets command line for "assign" command
8 c
9 c Assigns a given basis set to a given set of spectrum, site indices
10 c
11 c assign <basis_indx> { to } { spectrum <spec_indx> site <site_indx> }
12 c
13 c If no spectral or site indices are given, the assignment is made
14 c for all currently defined sites/spectra
15 c----------------------------------------------------------------------
16 subroutine assgnc(line)
17 c
18 use nlsdim
19 use eprprm
20 use parcom
21 use tridag
22 use basis
23 use stdio
24 c
25 implicit none
26 character*80 line
27 c
28 integer i,ibn,isi,isp,ival,ixsi1,ixsi2,ixsm,ixsp1,ixsp2,
29 # ixss(2),lth
30 character*30 token
31 c
32 integer isfind
33 logical itoken
34 external itoken,isfind
35 c
36 ibn=0
37 c
38 c----------------------------------------------------------------------
39 c Get the index/name name of the basis set file
40 c----------------------------------------------------------------------
41 call gettkn(line,token,lth)
42 c
43 c *** No index/filename specified
44 if (lth.eq.0) then
45 write(luttyo,1000)
46 return
47 endif
48 c
49 ixsm=isfind(token,lth)
50 call touppr(token,lth)
51 if (ixsm.eq.0) then
52 c *** Illegal index
53 if (.not.itoken(token,lth,ibn)) then
54 write(luout,1001) token(:lth)
55 if (luout.ne.luttyo) write(luttyo,1001) token(:lth)
56 return
57 end if
58 else
59 ibn=abs(ixsm)
60 end if
61 c *** Index out of range
62 if (ibn.lt.0 .or.ibn.gt.nbas) then
63 write(luout,1004) ibn
64 if (luout.ne.luttyo) write(luttyo,1004) ibn
65 return
66 end if
67 c
68 c----------------------------------------------------------------------
69 c Got basis set index/name: now get site/spectrum indices
70 c----------------------------------------------------------------------
71 call getss(line,ixss)
72 c
73 c Set ranges of spectra, site indices
74 c
75 if (ixss(2).le.0) then
76 ixsi1=1
77 ixsi2=mxsite
78 else
79 ixsi1=ixss(2)
80 ixsi2=ixss(2)
81 end if
82 c
83 if (ixss(1).le.0) then
84 ixsp1=1
85 ixsp2=mxspc
86 else
87 ixsp1=ixss(1)
88 ixsp2=ixss(1)
89 end if
90 c
91 c----------------------------------------------------------------------
92 c Now assign basis set
93 c----------------------------------------------------------------------
94 do isi=ixsi1,ixsi2
95 do isp=ixsp1,ixsp2
96 basno(isi,isp)=ibn
97 modtd(isi,isp)=1
98 end do
99 end do
100 return
101 c
102 c #### Formats #######################################################
103 1000 format('*** Basis set number/ID required ***')
104 1001 format('*** Illegal index: ''',a,''' ***')
105 1004 format('*** basis set ',i2,' is not defined ***')
106 end
107
108
109
110 c----------------------------------------------------------------------
111 c =========================
112 c subroutine GETSS
113 c =========================
114 c
115 c Interprets command line as follows
116 c {TO} { {SITE} <n> {SPECTRUM} <m> }
117 c
118 c Returns a 2-vector with the site and spectrum specified on the
119 c line (or zero for an index that wasn't specified)
120 c
121 c If <n> and <m> are given withouth the SITE/SPECTRUM keywords,
122 c the routine interprets them in the order site, spectrum
123 c----------------------------------------------------------------------
124 c
125 subroutine getss(line,ixss)
126 c
127 use stdio
128 c
129 implicit none
130 character*80 line
131 integer ixss(2)
132 c
133 integer i,ival,ixn,ixsm,lth
134 character*30 token
135 c
136 integer isfind
137 logical itoken
138 external isfind,itoken
139 c
140 integer NKEYWD
141 parameter(nkeywd=3)
142 c
143 character*8 keywrd(nkeywd)
144 data keywrd /'SPECTRUM','SITE','TO'/
145 c
146 ixss(1)=0
147 ixss(2)=0
148 ixn=1
149 c
150 c----------------------------------------------------------------------
151 c Look for a keyword or index
152 c----------------------------------------------------------------------
153 5 call gettkn(line,token,lth)
154 c
155 if (lth.ne.0) then
156 lth=min(lth,8)
157 call touppr(token,lth)
158 do i=1,nkeywd
159 if (token(:lth).eq.keywrd(i)(:lth)) go to 7
160 end do
161 c
162 c----------------------------------------------------------------------
163 c Token is not a keyword: check whether it is a symbolic or
164 c integer value
165 c----------------------------------------------------------------------
166 ixsm=isfind(token,lth)
167 if (ixsm.eq.0) then
168 if (.not.itoken(token,lth,ival)) then
169 c *** Illegal index
170 write(luout,1001) token(:lth)
171 go to 5
172 end if
173 else
174 ival=abs(ixsm)
175 end if
176 c
177 c --- Assign index
178 c
179 ixss(ixn)=ival
180 ixn=1+mod(ixn,2)
181 c
182 c----------------------------------------------------------------------
183 c Keyword found: set index accordingly (ignore "TO" keyword)
184 c----------------------------------------------------------------------
185 7 if (i.lt.3) ixn=i
186 go to 5
187 end if
188 c
189 c----------------------------------------------------------------------
190 c No more tokens on the line: return
191 c----------------------------------------------------------------------
192 c
193 return
194 1001 format('*** Illegal index: ''',a,''' ***')
195 end
stdio::luout
integer, save luout
Definition: stdio.f90:32
basis::basno
integer, dimension(mxsite, mxspc), save basno
Definition: basis.f90:23
tridag::modtd
integer, dimension(mxsite, mxspc), save modtd
Definition: tridag.f90:28
stdio
Definition: stdio.f90:26
touppr
subroutine touppr(string, lth)
Definition: strutl2.f90:22
basis
Definition: basis.f90:19
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
assgnc
subroutine assgnc(line)
Definition: assgnc.f90:17
nlsdim::mxspc
integer, parameter mxspc
Definition: nlsdim.f90:39
nlsdim::mxsite
integer, parameter mxsite
Definition: nlsdim.f90:39
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
eprprm
Definition: eprprm.f90:51
nlsdim
Definition: nlsdim.f90:36
basis::nbas
integer, save nbas
Definition: basis.f90:23
getss
subroutine getss(line, ixss)
Definition: assgnc.f90:126
tridag
Definition: tridag.f90:24