1      subroutine print_exndcf(msg)
2      implicit none
3c $Id$
4#include "nwc_const.fh"
5#include "basP.fh"
6#include "util.fh"
7      character *(*) msg
8      integer i,j
9      write(6,*)'<<<< print_exndcf: ',msg,' >>>>'
10      do i = 1, nbasis_bsmx
11        write(6,10000)i,(exndcf(j,i), j=1,3)
12      enddo
1310000 format(' basis:',i2,' handle :',i10,/
14     &       '         ', ' index  :',i10,/
15     &       '         ', ' size   :',i10/)
16      end
17*.....................................................................
18      logical function bas_add_ucnt_init(basisin)
19      implicit none
20#include "errquit.fh"
21#include "mafdecls.fh"
22#include "nwc_const.fh"
23#include "basP.fh"
24#include "bas_exndcf_dec.fh"
25      integer basisin
26c::local
27      integer input_size
28      parameter(input_size = 10000)
29      integer basis, h_tmp, k_tmp
30c
31#include "bas_exndcf_sfn.fh"
32c
33      basis = basisin + BASIS_HANDLE_OFFSET
34c
35      bas_add_ucnt_init = ma_alloc_get(
36     &    mt_dbl,input_size,' input for basis heap ',
37     &    h_tmp,k_tmp)
38      exndcf(H_exndcf,basis) = h_tmp
39      exndcf(K_exndcf,basis)= k_tmp
40      if (.not. bas_add_ucnt_init) call errquit
41     &    ('bas_add_unct_init: error allocating input heap space',911,
42     &       MEM_ERR)
43      call dfill(input_size,0.0d00,dbl_mb(k_tmp),1)
44      exndcf(SZ_exndcf,basis) = input_size
45      end
46*.....................................................................
47      logical function bas_add_ucnt_tidy(basisin)
48      implicit none
49#include "errquit.fh"
50#include "mafdecls.fh"
51#include "nwc_const.fh"
52#include "basP.fh"
53#include "bas_exndcf_dec.fh"
54      integer basisin
55c::local
56      integer basis
57      integer h_tmp
58c
59#include "bas_exndcf_sfn.fh"
60c
61      basis = basisin + BASIS_HANDLE_OFFSET
62c
63      h_tmp = exndcf(H_exndcf,basis)
64      bas_add_ucnt_tidy = ma_free_heap(h_tmp)
65      if (.not.bas_add_ucnt_tidy) call errquit
66     &    ('bas_add_unct_tidy: error freeing heap',911, MEM_ERR)
67      exndcf(H_exndcf ,basis) = -1
68      exndcf(K_exndcf ,basis) = 0
69      exndcf(SZ_exndcf,basis) = 0
70      bas_add_ucnt_tidy = .true.
71      end
72*.....................................................................
73      logical function bas_set_ecp_basis(basis)
74      implicit none
75#include "basdeclsP.fh"
76#include "nwc_const.fh"
77#include "basP.fh"
78      logical bas_check_handle
79      external bas_check_handle
80c
81      integer basis
82c
83      integer bas
84c
85      bas_set_ecp_basis = bas_check_handle(basis,'bas_set_ecp_basis')
86      if (.not. bas_set_ecp_basis) return
87      bas = basis + BASIS_HANDLE_OFFSET
88c
89      infbs_head(Head_ECP,bas) = 1
90      end
91*.....................................................................
92      logical function bas_set_so_basis(basis)
93      implicit none
94#include "basdeclsP.fh"
95#include "nwc_const.fh"
96#include "basP.fh"
97      logical bas_check_handle
98      external bas_check_handle
99c
100      integer basis
101c
102      integer bas
103c
104      bas_set_so_basis = bas_check_handle(basis,'bas_set_so_basis')
105      if (.not. bas_set_so_basis) return
106      bas = basis + BASIS_HANDLE_OFFSET
107c
108      infbs_head(Head_ECP,bas) = 2
109      end
110*.....................................................................
111      logical function ecp_set_num_elec(ecpid,tag,num_elec,stdtag)
112      implicit none
113#include "basdeclsP.fh"
114#include "nwc_const.fh"
115#include "basP.fh"
116*functions::
117      logical ecp_check_handle
118      logical bas_add_utag
119      external ecp_check_handle
120      external bas_add_utag
121*passed::
122      integer ecpid      ! [input] basis set handle
123      character*16 tag   ! [input] tag to set number of electrons for
124      integer num_elec   ! [input] number of electrons ecp replaces
125      character*(*) stdtag ! [input] name associated with ecp on tag
126c
127*local::
128      integer ecp_indx
129      integer itag
130c
131c     sets the number of electrons replaced by the ecp on the
132c     specified tag.  If the tag is not present it will also add
133c     that by calling bas_add_utag
134c
135      ecp_set_num_elec = ecp_check_handle(ecpid,'ecp_set_num_elec')
136      if (.not. ecp_set_num_elec) return
137      ecp_indx = ecpid + BASIS_HANDLE_OFFSET
138c
139c     Make sure that the tag is in the list
140c
141      ecp_set_num_elec = bas_add_utag(ecpid, tag, stdtag, itag)
142      if (.not. ecp_set_num_elec) return
143      infbs_tags(Tag_Nelec,itag,ecp_indx) = num_elec
144c
145      end
146*.....................................................................
147      logical function ecp_get_num_elec(ecpid,tag,num_elec)
148      implicit none
149#include "basdeclsP.fh"
150#include "nwc_const.fh"
151#include "basP.fh"
152#include "stdio.fh"
153*functions::
154      logical ecp_check_handle
155      external ecp_check_handle
156*passed::
157      integer ecpid      ! [input] basis set handle
158      character*16 tag   ! [input] tag to get number of electrons for
159      integer num_elec   ! [input] number of electrons ecp replaces
160c
161*local::
162      integer ecp_indx
163      integer itag, ntag
164c
165c     gets the number of electrons replaced by the ecp on the
166c     specified tag.  If the tag is not present it will error
167*
168c
169      ecp_get_num_elec = ecp_check_handle(ecpid,'ecp_get_num_elec')
170      if (.not.ecp_get_num_elec) return
171      ecp_indx = ecpid + BASIS_HANDLE_OFFSET
172c
173      ntag = infbs_head(Head_Ntags,ecp_indx)
174      do itag = 1,ntag
175        if (tag.eq.bs_tags(itag,ecp_indx)) then
176          num_elec = infbs_tags(Tag_Nelec,itag,ecp_indx)
177          ecp_get_num_elec = .true.
178          return
179        endif
180      enddo
181c
182      num_elec = 0
183      ecp_get_num_elec = .false.
184c
185      end
186*.....................................................................
187      logical function bas_add_utag(basisin, tag, stdtag, itag)
188      implicit none
189#include "basdeclsP.fh"
190#include "nwc_const.fh"
191#include "basP.fh"
192#include "inp.fh"
193      integer basisin           ! [input] basis handle
194      character*(*) tag         ! [input] name of tag
195      character*(*) stdtag      ! [input] name of basis set on tag
196      integer itag              ! [output] index of tag
197c
198      integer basis             ! [local] index into basis arrays
199      logical bas_check_handle
200      external bas_check_handle
201      integer tmp
202c
203c     Add the unique tag to the list of tags in the basis,
204c     incrementing the no. of tags if necessary.
205c     Return in itag the index of the unique tag
206c
207      bas_add_utag = bas_check_handle(basisin, 'bas_add_utag')
208      if (.not. bas_add_utag) return
209      basis = basisin + BASIS_HANDLE_OFFSET
210c
211      do itag = 1, infbs_head(HEAD_NTAGS,basis)
212        if (bs_tags(itag,basis) .eq. tag) then
213          if (bs_stdname(itag,basis).eq.'unknown') then
214            bs_stdname(itag,basis) = stdtag
215          else if (bs_stdname(itag,basis) .ne. stdtag) then
216            if (.not.(bs_stdname(itag,basis)(1:9).eq.'modified:')) then
217              tmp = inp_strlen(bs_stdname(itag,basis))
218              bs_stdname(itag,basis) =
219     &            'modified:'//bs_stdname(itag,basis)(1:tmp)
220            endif
221          endif
222          return
223        endif
224      enddo
225c
226c     No match found ... append new tag to the list
227c
228      itag = infbs_head(HEAD_NTAGS,basis) + 1
229      if (itag .gt. ntags_bsmx) then
230         write(6,*) 'bas_add_utag: too many tags', itag
231         bas_add_utag = .false.
232         return
233      endif
234c
235      infbs_head(HEAD_NTAGS,basis) = itag
236      bs_tags(itag,basis) = tag
237      bs_stdname(itag,basis) = stdtag
238c
239      end
240*.....................................................................
241      subroutine bas_err_info(info)
242      implicit none
243#include "nwc_const.fh"
244#include "basP.fh"
245c
246      character*(*) info        ! [input]
247      integer bas,basin
248      integer nbas
249      logical status
250c
251c     For internal use of the basis set routines only: print out
252c     info of known basis sets to aid in diagnosing a problem
253c
254c::function
255      logical bas_print
256      external bas_print
257c
258      nbas = 0
259      do 00100 bas = 1, nbasis_bsmx
260        if (bsactive(bas)) nbas = nbas + 1
26100100 continue
262      write(6,'(1x,a,a,i2)')
263     &       info, ': open basis sets:',nbas
264c
265      nbas = 0
266      do 00200 bas = 1, nbasis_bsmx
267        if (bsactive(bas)) then
268          basin = bas - BASIS_HANDLE_OFFSET
269          status = bas_print(basin)
270        endif
27100200 continue
272c
273      if (nbasis_rtdb .gt. 0) then
274        write(6,'(1x,a,a,i3)')
275     &         info,': basis sets in current rtdb ',nbasis_rtdb
276        do 00300 bas = 1, nbasis_rtdb
277          write(6,'(1x,a,1x,i3,3x,a,1x,a)')
278     &           'number:',bas,
279     &           'basis set name:',
280     &           bs_names_rtdb(bas)(1:len_bs_rtdb(bas))
28100300   continue
282      endif
283c
284      end
285*.....................................................................
286      logical function bas_ucontinfo(basisin,icont,itype,
287     &       nprimo,ngeno,sphcart)
288      implicit none
289#include "nwc_const.fh"
290#include "basP.fh"
291#include "geobasmapP.fh"
292#include "basdeclsP.fh"
293c::function
294      logical bas_check_handle
295      external bas_check_handle
296c::passed
297      integer basisin, icont, nprimo, ngeno, sphcart, itype
298c::local
299      integer basis,myucont,icontmax
300c
301      nprimo = -123
302      ngeno  = -456
303      sphcart = -789
304c
305      bas_ucontinfo = bas_check_handle(basisin,'bas_ucontinfo')
306      if (.not.bas_ucontinfo) return
307
308      basis = basisin + BASIS_HANDLE_OFFSET
309c
310      icontmax = infbs_head(HEAD_NCONT,basis)
311c
312      if (.not.(icont.gt.0.and.icont.le.icontmax)) then
313        write(6,*)' bas_continfo: ERROR '
314        write(6,*)' unique contraction range for basis is 1:',
315     &         icontmax
316        write(6,*)' information requested for contraction:',icont
317        bas_ucontinfo = .false.
318        return
319      endif
320c
321      myucont = icont
322      if (bas_spherical(basis)) then
323        sphcart = 1
324      else
325        sphcart = 0
326      endif
327      itype   = infbs_cont(CONT_TYPE,myucont,basis)
328      nprimo  = infbs_cont(CONT_NPRIM,myucont,basis)
329      ngeno   = infbs_cont(CONT_NGEN,myucont,basis)
330      bas_ucontinfo=.true.
331      return
332      end
333*.....................................................................
334      logical function bas_unumcont(basisin,numcont)
335      implicit none
336#include "nwc_const.fh"
337#include "basP.fh"
338#include "geobasmapP.fh"
339#include "basdeclsP.fh"
340c::function
341      logical bas_check_handle
342      external bas_check_handle
343c::passed
344      integer basisin,numcont
345c::local
346      integer basis
347c
348      numcont = -6589
349      bas_unumcont = bas_check_handle(basisin,'bas_numcont')
350      if (.not.bas_unumcont) return
351
352      basis = basisin + BASIS_HANDLE_OFFSET
353
354      numcont = infbs_head(HEAD_NCONT,basis)
355
356      bas_unumcont = .true.
357      return
358      end
359*.....................................................................
360      block data basis_data
361c
362c Block data structure to initialize the common block variables in the
363c  internal basis set object data structures
364c
365      implicit none
366#include "nwc_const.fh"
367#include "basP.fh"
368c
369      data nbasis_rtdb /0/
370      data bsactive /nbasis_bsmx*.false./
371      data bas_spherical /nbasis_bsmx*.false./
372      data angular_bs /nbasis_bsmx*-565/
373      data bas_norm_id /nbasis_bsmx*-565/
374      data nbfmax_bs /nbasis_bsmx*-565/
375      data bsversion /5.00d00/
376* version 5 includes so stuff
377c
378      end
379*.....................................................................
380      integer function nbf_from_ucont(ucont,basisin)
381c
382c function that returns the number of basis functions in a contraction
383c
384c  types 0->S, 1->P, 2->D, 3->F etc. -1->SP -2->SPD
385c
386      implicit none
387#include "errquit.fh"
388#include "nwc_const.fh"
389#include "basP.fh"
390#include "basdeclsP.fh"
391c:: function
392      logical bas_check_handle
393      external bas_check_handle
394c:: passed
395      integer ucont   ! [input] unique contraction
396      integer basisin ! [input] basis set handle
397c:: local
398      integer type
399      integer basis
400      integer ngen
401c
402      if(.not.bas_check_handle(basisin,'nbf_from_ucont'))
403     &  call errquit('nbf_from_ucont: bad basis handle',basisin,
404     &       BASIS_ERR)
405c
406      basis = basisin + BASIS_HANDLE_OFFSET
407c
408      type = infbs_cont(CONT_TYPE,ucont,basis)
409      ngen = infbs_cont(CONT_NGEN,ucont,basis)
410      if (type.ge.0) then
411        if (bas_spherical(basis)) then
412          nbf_from_ucont = ngen*(2*type+1)
413        else
414          nbf_from_ucont = ngen*(type+1)*(type+2)/2
415        endif
416      else if (type.eq.-1) then
417        nbf_from_ucont = ngen*2
418      else if (type.eq.-2) then
419        if (bas_spherical(basis)) then
420          nbf_from_ucont = ngen*9/3
421        else
422          nbf_from_ucont = ngen*10/3
423        endif
424      else
425        call errquit('nbf_from_ucont: bad cont type',type, BASIS_ERR)
426      endif
427      end
428*.....................................................................
429      logical function bas_set_spherical(basisin, ospherical)
430      implicit none
431#include "nwc_const.fh"
432#include "basP.fh"
433#include "basdeclsP.fh"
434c
435      integer basisin    ! [input] basis set handle
436      logical ospherical ! [input] logical for spherical setting
437c
438      integer basis
439c
440      bas_set_spherical = .false.
441c
442      basis = basisin + BASIS_HANDLE_OFFSET
443      if (ospherical) then
444        infbs_head(HEAD_SPH,basis) = 1
445        bas_spherical(basis) = .true.
446      else
447        infbs_head(HEAD_SPH,basis) = 0
448        bas_spherical(basis) = .false.
449      endif
450      bas_set_spherical = .true.
451      end
452*.....................................................................
453      logical function bas_get_spherical(basisin, is_spherical)
454      implicit none
455#include "nwc_const.fh"
456#include "basP.fh"
457#include "basdeclsP.fh"
458c
459      integer basisin      ! [input] basis get handle
460      logical is_spherical ! [output] logical for spherical getting
461c
462      integer basis
463c
464      bas_get_spherical = .false.
465c
466      basis = basisin + BASIS_HANDLE_OFFSET
467      if (infbs_head(head_sph,basis).eq.1) then
468        is_spherical = .true.
469      else
470        is_spherical = .false.
471      endif
472      bas_get_spherical = .true.
473      end
474*.....................................................................
475      logical function bas_name_exist_rtdb(rtdb,name)
476      implicit none
477#include "errquit.fh"
478*
479* function to determin if "name" has been stored on the
480* current rtdb in actual or translated by a set directive.
481*
482#include "mafdecls.fh"
483#include "rtdb.fh"
484#include "context.fh"
485#include "inp.fh"
486#include "nwc_const.fh"
487#include "basP.fh"
488c::functions
489      logical  bas_rtdb_in
490      external bas_rtdb_in
491c::passed
492      integer rtdb ! [input] run time data base handle
493      character*(*) name ! [input] test name
494c::local
495      integer index
496      character*256 trans_name
497c
498      bas_name_exist_rtdb = bas_rtdb_in(rtdb)
499      if (.not.bas_name_exist_rtdb) call errquit
500     &    ('bas_name_exist_rtdb: bas_rtdb_in failed',911, RTDB_ERR)
501c
502      bas_name_exist_rtdb = .false.
503      if (inp_match
504     &    (nbasis_rtdb,.false.,name,bs_names_rtdb,index)) then
505        bas_name_exist_rtdb = .true.
506        return
507      endif
508      if (context_rtdb_match(rtdb,name,trans_name)) then
509        if (inp_match
510     &      (nbasis_rtdb,.false.,trans_name,bs_names_rtdb,index)) then
511          bas_name_exist_rtdb = .true.
512          return
513        endif
514      endif
515      end
516