NLSL: lbasix.f90 Source File

NLSL

- Main Page
- Modules
- Data Types List
- Files

- File List
- File Members

lbasix.f90
Go to the documentation of this file.
1 c Version 1.4 (NLS)
2 c**********************************************************************
3 c ===================
4 c SUBROUTINE : LBASIX
5 c ===================
6 c
7 c This routine builds a list of the basis set indices in common
8 c block /indexl/ for the truncation parameters set in /eprdat/
9 c or reads them from the index file "<name>.ind" which contains
10 c a pruned basis set produced by the EPRBL program.
11 c
12 c If one of the following conditions is true:
13 c (1) The "new" flag is set nonzero on input
14 c (2) the input filename is blank
15 c
16 c this routine routine builds the full basis set indicated
17 c by the truncation parameters specified in the MTS array.
18 c These are as follows:
19 c mts(1) lemx Maximum even L
20 c mts(2) lomx Maximum odd L
21 c mts(3) kmn Minimum K (K<0 => jK = -1)
22 c mts(4) kmx Maximum K
23 c mts(5) mmn Minimum M (M<0 => jM = -1)
24 c mts(6) mmx Maximum M
25 c mts(7) ipnmx Maximum pI
26 c mts(8) ldelta L increment
27 c mts(9) kdelta K increment
28 c mts(10) ipsi0 Tilt angle flag
29 c mts(11) in2 Nuclear spin
30 c mts(12) jkmn Minimum jK
31 c mts(13) jmmn Minimum jM
32 c
33 c Uses:
34 c ipar.f
35 c
36 c**********************************************************************
37 c
38 subroutine lbasix( ixname,bss,mts,lthb,maxb,new,ierr )
39 c
40 use nlsdim
41 use eprprm
42 use mtsdef
43 use stdio
44 c
45 implicit none
46 character*30 ixname,fname
47 integer lthb,maxb,new,ierr,bss(5,lthb),mts(mxmts)
48 c
49 integer i,ioerr,ipnr,ipnrmx,ipnrmn,iqnr,iqnrmx,iqnrmn,j,kr,
50 # krmx,kdel,ldel,lth,lr,mr,mrmx,n,nrow,iparlr,krmn,mrmn
51 c
52 logical fexist
53 integer ipar,iroot
54 external ipar,iroot
55 c
56 c######################################################################
57 c
58 ierr=0
59 if (new.eq.0) then
60 c
61 c----------------------------------------------------------------------
62 c Look for the basis set indices in the specified file
63 c----------------------------------------------------------------------
64 c
65 fname=ixname
66 lth=iroot(fname)
67 fname=fname(:lth)//'.ind'
68 lth=lth+4
69 inquire(file=fname(:lth),exist=fexist)
70 if (.not.fexist) then
71 c *** file not found
72 write(luout,1003) fname(:lth)
73 if (luout.ne.luttyo) write (luttyo,1003) fname(:lth)
74 ierr=-1
75 return
76 end if
77 c
78 c----------------------------------------------------------------------
79 c Read basis set information from index file
80 c----------------------------------------------------------------------
81 c
82 open (unit=ludisk,file=fname(:lth),status='old',
83 # access='sequential',form='unformatted',iostat=ioerr)
84 read (ludisk,iostat=ioerr) lthb,(mts(i),i=1,ntrc)
85 if (ioerr.ne.0 .or. lthb.gt.maxb) then
86 if (ioerr.ne.0) then
87 c *** error reading file
88 write(luout,1002) fname(:lth)
89 if (luout.ne.luttyo) write(luttyo,1002) fname(:lth)
90 else
91 c *** insufficient room
92 write(luout,1001) fname(:lth)
93 if (luout.ne.luttyo) write(luttyo,1001) fname(:lth)
94 end if
95 ierr=-1
96 return
97 else
98 read (ludisk,iostat=ioerr) ((bss(i,j),i=1,5),j=1,lthb)
99 end if
100 c *** error reading file
101 if (ioerr.ne.0) then
102 write(luout,1002) fname(:lth)
103 if (luout.ne.luttyo) write(luttyo,1002) fname(:lth)
104 ierr=-1
105 return
106 end if
107 c
108 close(ludisk)
109 c
110 return
111 end if
112 c
113 c----------------------------------------------------------------------
114 c Routine was called with blank filename or "new" flag nonzero:
115 c Construct a basis using specified MTS. First check the MTS
116 c----------------------------------------------------------------------
117 c
118 if (mts(nlemx).le.0 .or. mts(nlomx).lt.0 .or.
119 # mts(nkmx).lt.0 .or. mts(nmmx).lt.0 .or.
120 # mts(nipnmx).lt.0 .or. mts(nkmn).gt.mts(nkmx) .or.
121 # mts(nmmn).gt.mts(nmmx)) then
122 write (luout,1004) (mts(i),i=1,ntrc)
123 ierr=-1
124 return
125 end if
126 c
127 c *** loop over lr ***
128 c
129 nrow=0
130 do 100 lr=0,mts(nlemx),mts(nldel)
131 iparlr=ipar(lr)
132 if((iparlr.ne.1).and.(lr.gt.mts(nlomx))) go to 100
133 c
134 c *** loop over kr ***
135 c
136 krmx=min(mts(nkmx),lr)
137 krmn=max(mts(nkmn),-lr)
138 do 110 kr=krmn,krmx,mts(nkdel)
139 if((kr.eq.0).and.(iparlr.lt.mts(njkmn))) go to 110
140 c
141 c *** loop over mr ***
142 c
143 mrmx=min(mts(nmmx),lr)
144 mrmn=max(mts(nmmn),-lr)
145 do 120 mr=mrmn,mrmx
146 if(mts(nipsi0).eq.0) then
147 ipnrmn=mr
148 ipnrmx=mr
149 else
150 ipnrmx=min(mts(nin2),mts(nipnmx))
151 if(mr.eq.0.and.mts(njmmn).eq.1) then
152 ipnrmn=0
153 else
154 ipnrmn=-ipnrmx
155 end if
156 end if
157 c
158 c *** loop over ipnr ***
159 c
160 do 130 ipnr=ipnrmn,ipnrmx
161 if((mr.eq.0).and.(ipnr.eq.0).and.(iparlr.lt.mts(njmmn)))
162 # go to 130
163 c
164 c *** loop over iqnr ***
165 c
166 iqnrmx=mts(nin2)-iabs(ipnr)
167 iqnrmn=-iqnrmx
168 do 140 iqnr=iqnrmn,iqnrmx,2
169 c
170 nrow=nrow+1
171 if (nrow.le.maxb) then
172 bss(1,nrow)=lr
173 bss(2,nrow)=kr
174 bss(3,nrow)=mr
175 bss(4,nrow)=ipnr
176 bss(5,nrow)=iqnr
177 end if
178 c
179 140 continue
180 130 continue
181 120 continue
182 110 continue
183 100 continue
184 c
185 lthb=nrow
186 return
187 c
188 1001 format('*** Insufficient room for basis set ''',a,''' ***')
189 1002 format('*** Error reading basis set ''',a,''' ***')
190 1003 format('*** file ''',a,''' not found ***')
191 1004 format('*** lbasix called with illegal MTS: (',6(i3,','),
192 # i3,') ***')
193 end
mtsdef::nkmn
integer, parameter nkmn
Definition: mtsdef.f90:29
stdio::luout
integer, save luout
Definition: stdio.f90:32
mtsdef::njkmn
integer, parameter njkmn
Definition: mtsdef.f90:29
mtsdef::ntrc
integer, parameter ntrc
Definition: mtsdef.f90:29
stdio
Definition: stdio.f90:26
nlsdim::mxmts
integer, parameter mxmts
Definition: nlsdim.f90:39
mtsdef::nmmx
integer, parameter nmmx
Definition: mtsdef.f90:29
mtsdef::nlemx
integer, parameter nlemx
Definition: mtsdef.f90:29
mtsdef::nipsi0
integer, parameter nipsi0
Definition: mtsdef.f90:29
mtsdef::nkdel
integer, parameter nkdel
Definition: mtsdef.f90:29
mtsdef::nin2
integer, parameter nin2
Definition: mtsdef.f90:29
stdio::ludisk
integer, parameter ludisk
Definition: stdio.f90:29
mtsdef::nipnmx
integer, parameter nipnmx
Definition: mtsdef.f90:29
stdio::luttyo
integer, parameter luttyo
Definition: stdio.f90:29
mtsdef::nmmn
integer, parameter nmmn
Definition: mtsdef.f90:29
eprprm
Definition: eprprm.f90:51
nlsdim
Definition: nlsdim.f90:36
mtsdef
Definition: mtsdef.f90:26
lbasix
subroutine lbasix(ixname, bss, mts, lthb, maxb, new, ierr)
Definition: lbasix.f90:39
mtsdef::njmmn
integer, parameter njmmn
Definition: mtsdef.f90:29
mtsdef::nkmx
integer, parameter nkmx
Definition: mtsdef.f90:29
mtsdef::nlomx
integer, parameter nlomx
Definition: mtsdef.f90:29
mtsdef::nldel
integer, parameter nldel
Definition: mtsdef.f90:29