Merge pull request #928 from edoapra/hotfix/release-7-2-0

fix for #926
nwchemgit · Jan 2, 2024 · d808e2c · d808e2c
2 parents 57b4784 + a140b97
commit d808e2c
Showing 1 changed file with 15 additions and 4 deletions.
diff --git a/src/NWints/rel/set_modelpotential_params.F b/src/NWints/rel/set_modelpotential_params.F
@@ -23,7 +23,8 @@ subroutine set_modelpotential_params(rtdb, geom, natoms)
       character*32 pname
 c
       integer i,j,k
-      character*16 tagi      ! tag of atom i
+      character*16 tagi         ! tag of atom i
+      integer iptr
       character*2 symi
       character*16 elemi
       double precision ci(3),chgi
@@ -41,8 +42,15 @@ subroutine set_modelpotential_params(rtdb, geom, natoms)
 c     map the model potential onto the geometry
       do i = 1,natoms
         if (.not.geom_cent_get(geom,i,tagi,ci,chgi)) 
-     &    call errquit(pname//'geom_cent_get failed:i',911, GEOM_ERR)
-        status = geom_tag_to_element(tagi,symi,elemi,atni)
+     &      call errquit(pname//'geom_cent_get failed:i',911, GEOM_ERR)
+c     handle bqs
+        if (inp_compare(.false.,tagi(1:2),'bq')) then
+           iptr=3
+        else
+           iptr=1
+        endif
+        if(.not.geom_tag_to_element(tagi(iptr:),symi,elemi,atni))
+     &      call errquit(pname//'geom_tag2elem failed:i',i, GEOM_ERR)
         call inp_lcase(symi)
 cinit
         do k = 1,50
@@ -62,8 +70,11 @@ subroutine set_modelpotential_params(rtdb, geom, natoms)
           end if
         end do ! j = 1,mpmaxelem 
  1984   continue
-        if(ga_nodeid().eq.0.and.(.not.status)) write(6,'(a,i3,2x,a)') 
+        if(ga_nodeid().eq.0.and.(.not.status)) then
+           write(6,'(a,i3,2x,a)') 
      W       ' modelpotential warning: no entry found for atom ',i,tagi
+           call errquit(' set_modelpotential error ',0,0)
+        endif
       end do  ! i = 1,natoms 
 c
 c     set parameters in rtdb