NLSL: basisc.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

basisc.f90
Go to the documentation of this file.
1 c NLSL Version 1.5 beta 11/23/95
2 c----------------------------------------------------------------------
3 c =========================
4 c subroutine BASISC
5 c =========================
6 c
7 c Reads in the basis index contained in the given file name
8 c
9 c basis <name> { spectrum <specindx> site <siteindx> }
10 c
11 c name : name of the basis index file (without .ind extension)
12 c specindx: optional index of the spectrum to which the basis set
13 c is to be assigned (may be a dataID)
14 c siteindx: optional index of the spectrum to which the basis set
15 c is to be assigned (may be a dataID)
16 c
17 c----------------------------------------------------------------------
18 subroutine basisc(line)
19 c
20 use nlsdim
21 use eprprm
22 use parcom
23 use basis
24 use tridag
25 use stdio
26 c
27 implicit none
28 character*80 line
29 c
30 integer i,ierr,isi,isp,ival,ixsp1,ixsp2,ixsi1,ixsi2,ixss(2),
31 # lth,maxb,new
32 character token*30,ixname*30
33 c
34 integer iroot
35 logical itoken
36 external iroot,itoken
37 c
38 c----------------------------------------------------------------------
39 c Get the name of the basis set file
40 c----------------------------------------------------------------------
41 call gettkn(line,token,lth)
42 c
43 c *** No filename specified
44 if (lth.eq.0) then
45 write(luttyo,1000)
46 if (lth.eq.0) return
47 end if
48 c
49 c *** Max # basis sets exceeded
50 if (nbas.ge.mxtdm) then
51 write(luout,1004) mxtdm
52 if (luout.ne.luttyo) write (luttyo,1004) mxtdm
53 return
54 end if
55 nbas=nbas+1
56 basisid(nbas)=token
57 ixname=token
58 c
59 call getss(line,ixss)
60 c
61 c----------------------------------------------------------------------
62 c Get the basis set
63 c----------------------------------------------------------------------
64 c
65 maxb=mxdim-nextbs+1
66 new=0
67 call lbasix(ixname,ibasis(1,nextbs),mts(1,nbas),
68 # ltbas(nbas),maxb,new,ierr)
69 c
70 if (ierr.eq.0) then
71 ixbas(nbas)=nextbs
72 nextbs=nextbs+ltbas(nbas)
73 c
74 lth = iroot(ixname)
75 write (luout,1001) ixname(:lth)//'.ind',(mts(i,nbas),i=1,7)
76 if (luout.ne.luttyo)
77 * write (luttyo,1001) ixname(:lth)//'.ind',(mts(i,nbas),i=1,7)
78 c
79 if (ixss(1).le.mxspc .and. ixss(2).le.mxsite) then
80 c
81 c -----------------------------------
82 c Set ranges of spectra, site indices
83 c -----------------------------------
84 if (ixss(2).le.0) then
85 ixsi1=1
86 ixsi2=mxsite
87 else
88 ixsi1=ixss(2)
89 ixsi2=ixss(2)
90 end if
91 c
92 if (ixss(1).le.0) then
93 ixsp1=1
94 ixsp2=mxspc
95 else
96 ixsp1=ixss(1)
97 ixsp2=ixss(1)
98 end if
99 c
100 c -----------------------
101 c Now assign basis set
102 c ----------------------
103 do isi=ixsi1,ixsi2
104 do isp=ixsp1,ixsp2
105 basno(isi,isp)=nbas
106 modtd(isi,isp)=1
107 end do
108 end do
109 c
110 end if
111 c
112 else
113 nbas=nbas-1
114 write (luout,1006) ixname(:lth)
115 if (luout.ne.luttyo) write (luttyo,1006) ixname(:lth)
116 end if
117 c
118 return
119 c
120 c ###### format statements ############################################
121 c
122 1000 format('*** No basis set file ID specifed ***')
123 1001 format('*** File ',a,' read ***'/' Lemx=',i3,' Lomx=',i3,
124 * ' K{mn,mx}= {',i3,',',i3,'} M{mn,mx}= {',i3,',',i3,
125 * '} ipnmx =',i2)
126 1004 format('*** Maximum of',i2,' basis sets exceeded ***')
127 1006 format('*** Error reading ''',a,''': no basis set added ***')
128 end
129
130 c----------------------------------------------------------------------
131 c =========================
132 c subroutine DELETC
133 c =========================
134 c
135 c Deletes the specified basis set from the buffer
136 c
137 c Syntax:
138 c delete <name>|index
139 c
140 c name : I.D. of the basis set
141 c index : Index number of the basis set
142 c
143 c----------------------------------------------------------------------
144 subroutine deletc(line)
145
146 c use nlsdim
147 use eprprm
148 use parcom
149 use basis
150 use tridag
151 use stdio
152 c
153 implicit none
154 character*80 line
155 c
156 integer istrt,isi,isp,ixsm,ival,lth,i,j,k,m
157 character token*30,ixname*30
158 c
159 logical itoken
160 integer isfind
161 external itoken,isfind
162 c
163 c----------------------------------------------------------------------
164 c Get the name of the basis set file
165 c----------------------------------------------------------------------
166 call gettkn(line,token,lth)
167 c
168 c *** No basis set specified
169 if (lth.eq.0) then
170 write(luttyo,1000)
171 if (lth.eq.0) return
172 end if
173 c
174 c ----------------------------------------------------------
175 c Token is not a keyword: check whether it is a symbolic or
176 c integer value
177 c -----------------------------------------------------------
178 ixsm=isfind(token,lth)
179 if (ixsm.eq.0) then
180 if (.not.itoken(token,lth,ival)) then
181 c *** Illegal index
182 write(luout,1002) token(:lth)
183 if (luout.ne.luttyo)write(luttyo,1002) token(:lth)
184 return
185 end if
186 else
187 ival=abs(ixsm)
188 end if
189 c *** Undefined index
190 if (ival.le.0 .or. ival.gt.nbas) then
191 write (luout,1002) token(:lth)
192 if (luout.ne.luttyo) write (luttyo,1002) token(:lth)
193 return
194 end if
195 c
196 c ------------------------------
197 c Move basis set parameters down
198 c ------------------------------
199 istrt=ixbas(ival)
200 lth=ltbas(ival)
201 nbas=nbas-1
202 do i=ival,nbas
203 ixbas(i)=ixbas(i+1)
204 ltbas(i)=ltbas(i+1)
205 bsused(i)=bsused(i+1)
206 basisid(i)=basisid(i+1)
207 do m=1,9
208 mts(m,i)=mts(m,i+1)
209 end do
210 end do
211 c
212 c ------------------------------
213 c Move basis set indices down
214 c ------------------------------
215 j=istrt
216 k=istrt+lth
217 do i=1,lth
218 do m=1,5
219 ibasis(m,j)=ibasis(m,k)
220 end do
221 j=j+1
222 k=k+1
223 end do
224 nextbs=nextbs-lth
225 c
226 c ------------------------------------
227 c Now deassign the deleted basis set
228 c ------------------------------------
229 do isi=1,mxsite
230 do isp=1,mxspc
231 if (basno(isi,isp).eq.ival) then
232 basno(isi,isp)=0
233 modtd(isi,isp)=1
234 end if
235 end do
236 end do
237 c
238 return
239 c
240 c ###### format statements ############################################
241 c
242 1000 format('*** No basis set specifed ***')
243 1002 format('*** Basis set ''',a,''' not defined ***')
244 end
245
stdio::luout
integer, save luout
Definition: stdio.f90:32
basis::bsused
integer, dimension(mxtdm), save bsused
Definition: basis.f90:23
basisc
subroutine basisc(line)
Definition: basisc.f90:19
basis::ibasis
integer, dimension(5, mxdim), save ibasis
Definition: basis.f90:23
basis::basisid
character *30, dimension(mxtdm), save basisid
Definition: basis.f90:27
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
nlsdim::mxtdm
integer, parameter mxtdm
Definition: nlsdim.f90:39
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
basis::mts
integer, dimension(9, mxmts), save mts
Definition: basis.f90:23
nlsdim::mxspc
integer, parameter mxspc
Definition: nlsdim.f90:39
basis::nextbs
integer, save nextbs
Definition: basis.f90:23
nlsdim::mxsite
integer, parameter mxsite
Definition: nlsdim.f90:39
deletc
subroutine deletc(line)
Definition: basisc.f90:145
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
eprprm
Definition: eprprm.f90:51
nlsdim
Definition: nlsdim.f90:36
lbasix
subroutine lbasix(ixname, bss, mts, lthb, maxb, new, ierr)
Definition: lbasix.f90:39
nlsdim::mxdim
integer, parameter mxdim
Definition: nlsdim.f90:39
basis::nbas
integer, save nbas
Definition: basis.f90:23
getss
subroutine getss(line, ixss)
Definition: assgnc.f90:126
basis::ixbas
integer, dimension(mxtdm), save ixbas
Definition: basis.f90:23
basis::ltbas
integer, dimension(mxtdm), save ltbas
Definition: basis.f90:23
tridag
Definition: tridag.f90:24