1 subroutine smd_rtdb_close(action) 2 implicit none 3#include "rtdb.fh" 4#include "smd_rtdb_data.fh" 5#include "mafdecls.fh" 6c 7 character*(*) action 8c 9 integer rtdb 10 logical result 11 character*30 pname 12 13 pname = "smd_rtdb_close" 14 call smd_rtdb_get_handle(rtdb) 15 if(rtdb.lt.0) call errquit(pname//"no rtdb to close") 16 if(.not.rtdb_close(rtdb,action)) 17 > call errquit(pname//" while rtdb_close",0,0) 18 call smd_rtdb_set_handle(-1000) 19 20 end 21 22 subroutine smd_rtdb_open(fname,action) 23 implicit none 24#include "rtdb.fh" 25#include "smd_rtdb_data.fh" 26#include "mafdecls.fh" 27c 28 character*(*) fname 29 character*(*) action 30c 31 integer rtdb 32 logical result 33 character*30 pname 34 35 pname = "smd_rtdb_close" 36 call smd_rtdb_get_handle(rtdb) 37 if(rtdb.ge.0) call errquit(pname//"close rtdb first") 38 if(.not.rtdb_open(fname,action,rtdb)) 39 > call errquit(pname//" while rtdb_open",0,0) 40 call smd_rtdb_set_handle(rtdb) 41 42 end 43 44 subroutine smd_rtdb_get_handle(rtdb) 45 implicit none 46#include "rtdb.fh" 47#include "smd_rtdb_data.fh" 48#include "mafdecls.fh" 49c 50 integer rtdb 51c 52 logical result 53 character*30 pname 54 55 pname = "smd_rtdb_get_handle" 56 call smd_rtdb_get_int("smd:rtdb_handle",1,rtdb,result) 57 if(.not.result) call errquit(pname//"no rtdb component",0,0) 58 59 end 60 61 subroutine smd_rtdb_set_handle(rtdb) 62 implicit none 63#include "rtdb.fh" 64#include "smd_rtdb_data.fh" 65#include "mafdecls.fh" 66c 67 integer rtdb 68c 69 logical result 70 character*30 pname 71 72 pname = "smd_rtdb_set_handle" 73 call smd_rtdb_put_int("smd:rtdb_handle",1,rtdb,result) 74 if(.not.result) call errquit(pname//"no rtdb component",0,0) 75 76 end 77 78 subroutine smd_rtdb_get_istart(istart) 79 implicit none 80#include "rtdb.fh" 81#include "smd_rtdb_data.fh" 82#include "mafdecls.fh" 83c 84 integer istart 85c 86 logical result 87 character*30 pname 88c 89 pname = "smd_rtdb_get_istart" 90 call smd_rtdb_get_int("smd:fragment_istart",1,istart,result) 91 if(.not.result) call errquit(pname//"no rtdb component",0,0) 92 93 end 94 95 subroutine smd_rtdb_get_iend(iend) 96 implicit none 97#include "rtdb.fh" 98#include "smd_rtdb_data.fh" 99#include "mafdecls.fh" 100c 101 integer iend 102c 103 logical result 104 character*30 pname 105c 106 pname = "smd_rtdb_get_iend" 107 call smd_rtdb_get_int("smd:fragment_iend",1,iend,result) 108 if(.not.result) call errquit(pname//"no rtdb component",0,0) 109 110 end 111 112 subroutine smd_rtdb_get_nproc(nproc) 113 implicit none 114#include "rtdb.fh" 115#include "smd_rtdb_data.fh" 116#include "mafdecls.fh" 117c 118 integer nproc 119c 120 logical result 121 character*30 pname 122c 123 pname = "smd_rtdb_get_nproc" 124 call smd_rtdb_get_int("smd:fragment_nproc",1,nproc,result) 125 if(.not.result) call errquit(pname//"no rtdb component",0,0) 126 127 end 128 129 subroutine smd_rtdb_get_name(rtdb_name) 130 implicit none 131#include "rtdb.fh" 132#include "smd_rtdb_data.fh" 133#include "mafdecls.fh" 134#include "errquit.fh" 135c 136 character*(*) rtdb_name 137c 138 integer rtdb 139 character*30 pname 140 logical result 141 142 pname = "smd_rtdb_get_name" 143c call smd_rtdb_get_handle(rtdb) 144c if(.not. rtdb_getfname(rtdb, rtdb_name)) call 145c * errquit(pname//'rtdb_getfname failed',0,0) 146 call smd_rtdb_get_string("smd:rtdb_name",1,rtdb_name,result) 147 if(.not.result) call errquit(pname//"no rtdb component",0,0) 148 149 150 end 151 152 subroutine smd_rtdb_get_operiodic(operiodic) 153 implicit none 154#include "rtdb.fh" 155#include "smd_rtdb_data.fh" 156#include "mafdecls.fh" 157c 158 logical operiodic 159c 160 double precision latt(3,3) 161 character*32 pname 162 character*80 tag 163 double precision a(3) 164 integer i 165c 166 pname = "smd_lat_rtdb_read" 167c 168c write(*,*) "in "//pname 169c 170 tag="smd:operiodic" 171 if (rtdb_get(smd_rtdb,tag,mt_log,1,operiodic)) 172 > return 173 174 operiodic = .true. 175 tag="smd:lat_a" 176 if (.not.rtdb_get(smd_rtdb,tag,mt_dbl,3,a(1))) 177 > operiodic=.false. 178 179 180 end 181 182 subroutine smd_rtdb_get_paramfile(filename,result) 183 implicit none 184#include "rtdb.fh" 185#include "smd_rtdb_data.fh" 186#include "mafdecls.fh" 187c 188 character*(*) filename 189 logical result 190c 191 192 result = .true. 193 if(.not.rtdb_cget(smd_rtdb,'smd:paramfile',1,filename)) 194 > result = .false. 195 end 196 197 subroutine smd_rtdb_get_coordfile(filename,result) 198 implicit none 199#include "rtdb.fh" 200#include "smd_rtdb_data.fh" 201#include "mafdecls.fh" 202#include "global.fh" 203 204c 205 character*(*) filename 206 logical result 207c 208 character*30 pname 209 210 pname = "smd_rtdb_get_coordfile" 211 212 result = .true. 213 if(.not.rtdb_cget(smd_rtdb,'smd:coordfile',1,filename)) 214 > result = .false. 215 216 end 217 218 subroutine smd_rtdb_get_veloc_input(filename,result) 219 implicit none 220#include "rtdb.fh" 221#include "smd_rtdb_data.fh" 222#include "mafdecls.fh" 223#include "global.fh" 224 225c 226 character*(*) filename 227 logical result 228c 229 character*30 pname 230 231 pname = "smd_rtdb_get_veloc:input" 232 233 result = .true. 234 if(.not.rtdb_cget(smd_rtdb,'smd:veloc:input',1,filename)) 235 > result = .false. 236 237 end 238 239 subroutine smd_rtdb_init(parallel,rtdb) 240 implicit none 241#include "rtdb.fh" 242#include "smd_rtdb_data.fh" 243#include "mafdecls.fh" 244#include "smd_const_data.fh" 245 246 logical parallel 247 integer rtdb 248c 249 character*(smd_string_size) namespace 250 character*(smd_string_size) tag 251 logical ignore,result,oldmode 252 character*30 pname 253 254 pname = "smd_rtdb_init" 255 oldmode = rtdb_parallel(parallel) 256 smd_rtdb = rtdb 257c if(.not. rtdb_getfname(rtdb, smd_rtdb_name)) call 258c * errquit('rtdb_getfname failed',0,0) 259 260 smd_istart=0 261 smd_iend =0 262 smd_nproc =0 263 ignore = rtdb_get(rtdb,"smd:istart",mt_int,1,smd_istart) 264 ignore = rtdb_get(rtdb,"smd:iend",mt_int,1,smd_iend) 265 ignore = rtdb_get(rtdb,"smd:nproc",mt_int,1,smd_nproc) 266 267 tag = "rtdb" 268 call smd_system_get_component(namespace,tag,result) 269 if(.not.result) 270 > call errquit( 271 > pname//'no component '//tag,0,0) 272 273 call smd_namespace_create(namespace) 274 275 call smd_data_namespace_rtdb_get(rtdb,namespace,"smd") 276 oldmode = rtdb_parallel(oldmode) 277 end 278 279 subroutine smd_rtdb_get_log(dname,ndim,datum,result) 280 implicit none 281c 282#include "mafdecls.fh" 283#include "errquit.fh" 284#include "smd_const_data.fh" 285 character*(smd_string_size) sname 286 character*(*) dname 287 integer ndim 288 logical datum(ndim) 289c 290 integer ind 291 logical result 292 integer ns,nd 293 character*30 pname 294 character*72 buffer 295 integer i 296 integer ndim1 297 298 pname = "smd_rtdb_get_log" 299 300 call smd_system_get_component(sname,"rtdb",result) 301 if(.not.result) call errquit(pname//"no rtdb component",0,0) 302 call smd_data_get_log(sname,dname,ndim,datum,result) 303 return 304 end 305 306 subroutine smd_rtdb_get_int(dname,ndim,datum,result) 307 implicit none 308c 309#include "mafdecls.fh" 310#include "errquit.fh" 311#include "smd_const_data.fh" 312 character*(smd_string_size) sname 313 character*(*) dname 314 integer ndim 315 integer datum(ndim) 316c 317 integer ind 318 logical result 319 integer ns,nd 320 character*30 pname 321 character*72 buffer 322 integer i 323 integer ndim1 324 325 pname = "smd_rtdb_get_int" 326 327 call smd_system_get_component(sname,"rtdb",result) 328 if(.not.result) call errquit(pname//"no rtdb component",0,0) 329 call smd_data_get_int(sname,dname,ndim,datum,result) 330 return 331 end 332 333 subroutine smd_rtdb_put_int(dname,ndim,datum,result) 334 implicit none 335c 336#include "mafdecls.fh" 337#include "errquit.fh" 338#include "smd_const_data.fh" 339 character*(smd_string_size) sname 340 character*(*) dname 341 integer ndim 342 integer datum(ndim) 343c 344 integer ind 345 logical result 346 integer ns,nd 347 character*30 pname 348 character*72 buffer 349 integer i 350 integer ndim1 351 352 pname = "smd_rtdb_put_int" 353 354 call smd_system_get_component(sname,"rtdb",result) 355 if(.not.result) return 356 call smd_data_put_int(sname,dname,ndim,datum) 357 return 358 end 359 360 subroutine smd_rtdb_get_dbl(dname,ndim,datum,result) 361 implicit none 362c 363#include "mafdecls.fh" 364#include "errquit.fh" 365#include "smd_const_data.fh" 366 character*(smd_string_size) sname 367 character*(*) dname 368 integer ndim 369 double precision datum(ndim) 370c 371 integer ind 372 logical result 373 integer ns,nd 374 character*30 pname 375 character*72 buffer 376 integer i 377 integer ndim1 378 379 pname = "smd_rtdb_get_dbl" 380 381 call smd_system_get_component(sname,"rtdb",result) 382 if(.not.result) call errquit(pname//"no rtdb component",0,0) 383 call smd_data_get_dbl(sname,dname,ndim,datum,result) 384 return 385 end 386 387 subroutine smd_rtdb_get_string(dname,ndim,datum,result) 388 implicit none 389c 390#include "mafdecls.fh" 391#include "errquit.fh" 392#include "smd_const_data.fh" 393#include "inp.fh" 394 character*(*) dname 395 integer ndim 396 integer dtype 397 character*(*) datum(ndim) 398c 399 integer ind 400 integer ns,nd 401 character*30 pname 402 character*72 buffer 403 integer i 404 integer ndim1 405 integer chunk 406 logical result 407 character*(smd_string_size) sname 408 409 pname = "smd_rtdb_get_string" 410 411 call smd_system_get_component(sname,"rtdb",result) 412 if(.not.result) call errquit(pname//"no rtdb component",0,0) 413 call smd_data_get_string(sname,dname,ndim,datum,result) 414 return 415 end 416 417c $Id$ 418