1c $Id$ 2 3 subroutine bq_tag_ncent(namespace,tag) 4 implicit none 5#include "util.fh" 6#include "inp.fh" 7 8 character*(*) tag 9c 10 integer n 11 character*255 namespace 12c 13 n=inp_strlen(namespace) 14 tag="bq:"//namespace(1:n)//":ncenter" 15 16 end 17 18 subroutine bq_tag_coord(namespace,tag) 19 implicit none 20#include "util.fh" 21#include "inp.fh" 22 23 character*(*) tag 24c 25 integer n 26 character*255 namespace 27c 28 n=inp_strlen(namespace) 29 tag="bq:"//namespace(1:n)//":coord" 30 31 end 32 33 subroutine bq_tag_charge(namespace,tag) 34 implicit none 35#include "util.fh" 36#include "inp.fh" 37 38 character*(*) tag 39c 40 integer n 41 character*255 namespace 42c 43 n=inp_strlen(namespace) 44 tag="bq:"//namespace(1:n)//":charge" 45 46 end 47C> 48C> \ingroup bq 49C> @{ 50C> 51C> \brief Store a Bq instance on the runtime database 52C> 53 function bq_rtdb_store(irtdb,handle) 54 implicit none 55#include "mafdecls.fh" 56#include "errquit.fh" 57#include "rtdb.fh" 58 integer irtdb !< [Input] The RTDB handle 59 integer handle !< [Input] The Bq instance handle 60 logical bq_rtdb_store 61c local variables 62 integer ncent 63 integer i_c 64 integer i_q 65 character*(32) pname 66 character*(255) tag 67 character*(255) namespace 68 69 logical bq_ncenter 70 external bq_ncenter 71 72 logical bq_check_handle 73 external bq_check_handle 74 75 logical bq_namespace 76 external bq_namespace 77 78 logical bq_index_coord 79 external bq_index_coord 80 81 logical bq_index_charge 82 external bq_index_charge 83 84 pname = "bq_rtdb_store" 85 86 bq_rtdb_store= .true. 87 if(.not.bq_check_handle(handle)) then 88 bq_rtdb_store = .false. 89 return 90 end if 91 92 if(.not.bq_ncenter(handle,ncent)) 93 & call errquit('bq_ncenter failed',0,0) 94 if(.not.bq_namespace(handle,namespace)) 95 & call errquit('bq_namespace failed',0,0) 96 if(.not.bq_index_coord(handle,i_c)) 97 & call errquit('bq_index_coord failed',0,0) 98 if(.not.bq_index_charge(handle,i_q)) 99 & call errquit('bq_index_charge failed',0,0) 100 101 call bq_tag_ncent(namespace,tag) 102 if(.not. rtdb_put(irtdb,tag,mt_int,1,ncent)) 103 & call errquit( 104 & pname//' unable to store ncenter', 105 & 0, RTDB_ERR) 106 107 108 call bq_tag_coord(namespace,tag) 109 if(.not. rtdb_put(irtdb,tag,mt_dbl,3*ncent,dbl_mb(i_c))) 110 & call errquit( 111 & pname//' unable to store coord', 112 & 0, RTDB_ERR) 113 114 call bq_tag_charge(namespace,tag) 115 if(.not. rtdb_put(irtdb,tag,mt_dbl,ncent,dbl_mb(i_q))) 116 & call errquit( 117 & pname//' unable to store charge', 118 & 0, RTDB_ERR) 119 120 return 121 end 122C> 123C> \brief Delete a Bq instance from the runtime database 124C> 125 subroutine bq_rtdb_delete(irtdb,namespace) 126 implicit none 127#include "mafdecls.fh" 128#include "errquit.fh" 129#include "rtdb.fh" 130 integer irtdb !< [Input] The RTDB handle 131 character*(*) namespace !< [Input] The Bq instance name 132c local variables 133 character*(32) pname 134 character*(255) tag 135 logical ignore 136 137 pname = "bq_rtdb_delete" 138 139 call bq_tag_ncent(namespace,tag) 140 ignore = rtdb_delete(irtdb,tag) 141 142 call bq_tag_coord(namespace,tag) 143 ignore = rtdb_delete(irtdb,tag) 144 145 call bq_tag_charge(namespace,tag) 146 ignore = rtdb_delete(irtdb,tag) 147 148 if(rtdb_cget(irtdb,"bq" , 1,tag)) then 149 if(tag.eq.namespace) then 150 ignore = rtdb_delete(irtdb,"bq") 151 end if 152 end if 153 154 return 155 end 156C> 157C> \brief Load a Bq instance from the runtime database 158C> 159C> Attempts to load a Bq instance from the runtime database. 160C> If the Bq instance on the RTDB is incomplete this function 161C> will abort with an error message and not return. 162C> 163C> \return Returns .true. if the Bq instance was loaded successfully, 164C> and .false. if it was not found. 165C> 166 function bq_rtdb_load(irtdb,handle) 167 implicit none 168#include "mafdecls.fh" 169#include "errquit.fh" 170#include "rtdb.fh" 171 integer irtdb !< [Input] The RTDB handle 172 integer handle !< [Input] The Bq instance handle 173 logical bq_rtdb_load 174c local variables 175 integer ncent 176 integer h_c 177 integer h_q 178 character*(32) pname 179 character*(255) tag 180 character*(255) namespace 181 182 integer ma_type,n 183 184 logical bq_ncenter 185 external bq_ncenter 186 187 logical bq_check_handle 188 external bq_check_handle 189 190 logical bq_namespace 191 external bq_namespace 192 193 logical bq_pset_mem 194 external bq_pset_mem 195 196 pname = "bq_rtdb_load" 197 198 bq_rtdb_load= .true. 199 if(.not.bq_check_handle(handle)) then 200 bq_rtdb_load = .false. 201 return 202 end if 203 204 if(.not.bq_ncenter(handle,ncent)) 205 & call errquit('bq_ncenter failed',0,0) 206 if(ncent.ne.0) then 207 bq_rtdb_load = .false. 208 write(*,*) pname//"empty bq set first" 209 return 210 end if 211 if(.not.bq_namespace(handle,namespace)) 212 & call errquit('bq_namespace failed',0,0) 213 214 call bq_tag_ncent(namespace,tag) 215 if(.not. rtdb_get(irtdb,tag,mt_int,1,ncent)) then 216 bq_rtdb_load = .false. 217 return 218 end if 219 220 call bq_tag_coord(namespace,tag) 221 if(.not. rtdb_ma_get(irtdb,tag,ma_type,n,h_c)) 222 & call errquit( 223 & pname//' unable to get coord', 224 & 0, RTDB_ERR) 225 if(ma_type.ne.MT_DBL) call errquit( 226 & pname//' illegal type for coord',ma_type,MA_ERR) 227 228 229 call bq_tag_charge(namespace,tag) 230 if(.not. rtdb_ma_get(irtdb,tag,ma_type,n,h_q)) 231 & call errquit( 232 & pname//' unable to get charge', 233 & 0, RTDB_ERR) 234 if(ma_type.ne.MT_DBL) call errquit( 235 & pname//' illegal type for charge',ma_type,MA_ERR) 236 237 if(.not. bq_pset_mem(handle,ncent,h_q,h_c)) 238 & call errquit( 239 & pname//' unable to pset bq', 240 & 0, 0) 241 242 return 243 end 244C> @} 245