1 subroutine util_file_info_rtdb(rtdb) 2 implicit none 3#include "errquit.fh" 4#include "cfileprefix.fh" 5#include "rtdb.fh" 6 integer rtdb 7c 8c Store the file prefix in the database. If the scratch_dir 9c and permanent_dir have been set by the user then store them 10c otherwise restore them from the database. They are stored 11c as 'scratch_dir' and 'permanent_dir' so that unset can 12c be used to delete them so that defaults may be restored. 13c 14 if (.not. rtdb_cput(rtdb, 'file_prefix', 1, file_prefix)) 15 $ call errquit('rtdb_put of file_prefix failed', 0, RTDB_ERR) 16c 17 if (scratch_dir .ne. ' ') then 18 if (.not. rtdb_cput(rtdb, 'scratch_dir', 1, scratch_dir)) 19 $ call errquit('rtdb_put of scratch_dir failed', 0, 20 & RTDB_ERR) 21 else 22 if (.not. rtdb_cget(rtdb, 'scratch_dir', 1, scratch_dir)) 23 $ scratch_dir = ' ' 24 endif 25c 26 if (permanent_dir .ne. ' ') then 27 if (.not. rtdb_cput(rtdb, 'permanent_dir', 1, permanent_dir)) 28 $ call errquit('rtdb_put of permanent_dir failed', 0, 29 & RTDB_ERR) 30 else 31 if (.not. rtdb_cget(rtdb, 'permanent_dir', 1, permanent_dir)) 32 $ permanent_dir = ' ' 33 endif 34c 35 end 36 subroutine util_file_prefix_get(fullname) 37 implicit none 38#include "cfileprefix.fh" 39 character*(*) fullname 40 41 fullname = file_prefix 42c 43 end 44 subroutine util_file_prefix_set(fullname) 45 implicit none 46#include "cfileprefix.fh" 47 character*(*) fullname 48 49 file_prefix = fullname 50c 51 end 52 subroutine util_file_prefix(name, fullname) 53 implicit none 54#include "errquit.fh" 55#include "cfileprefix.fh" 56#include "inp.fh" 57#include "stdio.fh" 58 character*(*) name, fullname 59c 60c prepend the file_prefix onto name as <file_prefix>.name 61c returning the result in fullname. 62c 63 if ((inp_strlen(name)+inp_strlen(file_prefix)+1) .gt. 64 $ len(fullname)) then 65 write(LuOut,*) ' file_prefix: name = ', name 66 write(LuOut,*) ' file_prefix: prfx = ', file_prefix 67 call util_flush(LuOut) 68 call errquit('file_prefix: insufficient space ', len(fullname), 69 & DISK_ERR) 70 endif 71c 72 fullname = ' ' 73 write(fullname,'(a,''.'',a)') 74 $ file_prefix(1:inp_strlen(file_prefix)), 75 $ name(1:inp_strlen(name)) 76c 77 end 78 subroutine util_file_name(stub, oscratch, oparallel, name) 79 implicit none 80#include "errquit.fh" 81#include "util.fh" 82#include "inp.fh" 83#include "cfileprefix.fh" 84#include "global.fh" 85#include "stdio.fh" 86c 87 character*(*) stub ! [input] stub name for file 88 logical oscratch ! [input] true=scratch, false=permanent 89 logical oparallel ! [input] true=append .nodeid 90 character*(*) name ! [output] full filename 91c 92 93 call util_file_name0(stub, oscratch, oparallel, name, -1) 94c 95 end 96 subroutine util_file_name0(stub, oscratch, oparallel, name, nodgs) 97 implicit none 98#include "errquit.fh" 99#include "util.fh" 100#include "inp.fh" 101#include "cfileprefix.fh" 102#include "global.fh" 103#include "stdio.fh" 104c 105 character*(*) stub ! [input] stub name for file 106 logical oscratch ! [input] true=scratch, false=permanent 107 logical oparallel ! [input] true=append .nodeid 108 character*(*) name ! [output] full filename 109 integer nodgs ! [input] no. of digits for prefix 110c 111 character*(nw_max_path_len) dir, tmp 112 integer ltmp, ldir, me 113 logical util_file_parse_dir 114 external util_file_parse_dir 115c 116 me = ga_nodeid() 117c 118 call util_directory_name(dir, oscratch, me) 119c 120* write(LuOut,*) 'a stub= |',stub(1:inp_strlen(stub)),'|' 121* write(LuOut,*) 'a dir = |', dir(1:inp_strlen(dir)),'|' 122c 123 call util_file_prefix(stub, tmp) 124 ltmp = inp_strlen(tmp) 125 ldir = inp_strlen(dir) 126 if (ltmp+ldir+1 .gt. len(name)) then 127 write(LuOut,*) ' util_file_name: stub = ', stub 128 write(LuOut,*) ' util_file_name: ltmp, ldir, lname', 129 $ ltmp, ldir, len(name) 130 call util_flush(LuOut) 131 call errquit('util_file_name: name too small', ltmp+ldir+1, 132 & INPUT_ERR) 133 endif 134 if (dir .ne. ' ') then 135 name = dir 136 name(ldir+1:ldir+1) = '/' 137 name(ldir+2:) = tmp 138 else 139 name = tmp 140 endif 141c 142 if (oparallel) then 143 if (inp_strlen(name) .gt. len(tmp)) then 144 write(LuOut,*) ' util_file_name: name = ', name 145 call util_flush(LuOut) 146 call errquit('util_file_name: tmp too small', 147 $ inp_strlen(name), INPUT_ERR) 148 endif 149 tmp = name 150 if(nodgs.eq.-1) then 151 call util_pname(tmp, name) 152 else 153 call util_pname0(tmp, name,ga_nodeid(),10**nodgs) 154 endif 155 156 endif 157c 158 end 159 subroutine util_file_print_dirs() 160 implicit none 161#include "util.fh" 162#include "inp.fh" 163#include "cfileprefix.fh" 164#include "stdio.fh" 165#include "global.fh" 166c 167c Print a summary of the permanent and scratch file directories 168c 169 character*(nw_max_path_len) sdir, pdir, prevsdir, prevpdir 170 integer node 171 logical util_file_parse_dir 172 external util_file_parse_dir 173c 174 prevpdir = ' ' 175 prevsdir = ' ' 176 if (ga_nodeid().eq.0) then 177 do node = 0, ga_nnodes()-1 178c 179 call util_directory_name(sdir, .true., node) 180 call util_directory_name(pdir, .false., node) 181c 182 if ((pdir.ne.prevpdir .or. sdir.ne.prevsdir)) then 183 write(LuOut,1) node, pdir(1:inp_strlen(pdir)), node, 184 $ sdir(1:inp_strlen(sdir)) 185 1 format(i3,' permanent = ', a/ 186 $ i3,' scratch = ', a) 187 endif 188 prevpdir = pdir 189 prevsdir = sdir 190 enddo 191 write(LuOut,*) 192 call util_flush(LuOut) 193 endif 194c 195 end 196 logical function util_file_parse_dir(dirlist, dir, nodeid) 197 implicit none 198#include "errquit.fh" 199#include "inp.fh" 200#include "util.fh" 201#include "stdio.fh" 202 character*(*) dirlist ! [input] List of dirs (by host/proc) 203 character*(*) dir ! [output] Returns matching dir 204c 205c Dirlist is the input line from the scratch_dir/permanent_dir 206c directives ... attempt to find a match for process nodeid. 207c 208c Return true if a match was found, or false (with dir=' ') 209c 210 character*256 hostname 211 character*1024 default, specific 212 character*1 numbers(10) 213 integer nodeid 214c 215 integer istart, iend, i, ind, p, ihostend, def1, spe1, nspe, ndef 216 data numbers /'0','1','2','3','4','5','6','7','8','9'/ 217c 218* write(LuOut,*) nodeid, ' dirlist in ufpd |',dirlist,'|' 219c 220#if defined(CYGNUS) || defined(WIN32) 221 call fix_windows_path(dirlist) 222#endif 223 util_file_parse_dir = .true. 224 ndef = 0 ! No. of default dirs found 225 nspe = 0 ! No. of host specific dirs found 226 def1 = 1 ! Pointer to end of default list 227 spe1 = 1 ! Pointer to end of specific list 228 default = ' ' 229 specific = ' ' 230 hostname = ' ' 231c 232c Go thru and assemble a space separated list of directories that 233c are either specific to this host or are defaults for all processes. 234c If we encounter a process specific directory immediately return. 235c 236 istart = 0 237 10 if (inp_strtok(dirlist, ' ', istart, iend)) then ! While loop 238c 239c Check if there is a host/id present ... a colon in the token 240c On Windows platforms this could be part of a legitimate local 241c path name, so we let it through - note that this precludes 242c specification of hosts this way here 243#if !defined(CYGNUS) && !defined(WIN32) 244 do i = istart, iend 245 if (dirlist(i:i) .eq. ':') goto 20 246 enddo 247#endif 248 ndef = ndef + 1 249 default(def1:) = dirlist(istart:iend) ! No colon=add to default list 250 def1 = def1 + iend - istart + 2 251 goto 10 252 20 ihostend = i-1 253 if (ihostend .lt. istart) call errquit 254 $ ('util_dir_parse: colon at start of dirname?',0, 255 & INPUT_ERR) 256c 257c Found host/process ID in dirlist(istart:ihostend). If the 258c first character is a number, then assume it's all a process id 259c 260 if (inp_match(10, .true., dirlist(istart:istart), 261 $ numbers, ind)) then 262 p = 0 263 do i = istart, ihostend 264 if (.not. inp_match(10, .true., dirlist(i:i), 265 $ numbers, ind)) call errquit 266 $ ('util_dir_parse: bad character in process id',0, 267 & INPUT_ERR) 268 p = p*10 + ind - 1 269 enddo 270* write(LuOut,*) ' p ',p 271 if (p .eq. nodeid) then ! Dir for me and only me 272 dir = dirlist(ihostend+2:iend) 273 return 274 endif 275 else 276 if (hostname .eq. ' ') call util_hostname(hostname) 277* write(LuOut,*) ' hostname ', hostname 278* write(LuOut,*) ' ........ ', dirlist(istart:ihostend) 279 if (inp_compare(.false., hostname, 280 $ dirlist(istart:ihostend))) then 281 specific(spe1:) = dirlist(ihostend+2:iend) 282 nspe = nspe + 1 283 spe1 = spe1 + iend - ihostend-2 + 2 284* write(LuOut,*) ' set spe to |',specific,'|' 285 endif 286 endif 287 goto 10 288 endif ! End of while 289c 290c Round robin allocation from either host specific or default lists. 291c Exploit sequential number of processes on a given host. 292c 293 if (nspe .gt. 0) then 294 istart = 0 295 do i = 0, mod(nodeid,nspe) 296 if (.not. inp_strtok(specific, ' ', istart, iend)) 297 $ call errquit('util_file_parse_dir: internal err?',0, 298 & INPUT_ERR) 299 enddo 300 dir = specific(istart:iend) 301 return 302 endif 303 if (ndef .gt. 0) then 304 istart = 0 305 do i = 0, mod(nodeid,ndef) 306 if (.not. inp_strtok(default, ' ', istart, iend)) 307 $ call errquit('util_file_parse_dir: internal err?',1, 308 & INPUT_ERR) 309 enddo 310 dir = default(istart:iend) 311 return 312 endif 313c 314c Nothing matched 315c 316 dir = ' ' 317 util_file_parse_dir = .false. 318c 319 end 320c 321c----------------------------------------------------------------------- 322c 323 subroutine util_set_default_scratch_dir(scratch_dir) 324 implicit none 325c 326c Sets the default scratch directory name (this may yet be 327c overriden by the name specified in the input). 328c 329c The order of precedence is as follows: 330c 1) the value of NWCHEM_SCRATCH_DIR environment variable 331c 2) the value of scratch_dir key in nwchemrc file(s) 332c 3) the value of the compiled in name 333c 334#include "stdio.fh" 335#include "inp.fh" 336#include "util.fh" 337c 338 character*(*) scratch_dir ! output 339c 340 logical from_environment 341 logical from_nwchemrc 342 logical from_compile 343 logical debug 344c 345 debug = .false. 346 from_nwchemrc = .false. 347c 348c 1: check for NWCHEM_SCRATCH_DIR environment variable 349c 350 call util_getenv('NWCHEM_SCRATCH_DIR',scratch_dir) 351 if (debug) then 352 write(luout,*) 353 & 'env return value of NWCHEM_SCRATCH_DIR <', 354 & scratch_dir(1:inp_strlen(scratch_dir)),'>' 355 endif 356 from_environment = (inp_strlen(scratch_dir).gt.0) 357c 358c 2: check for scratch_dir defined in nwchemrc config file(s) 359c 360 if (.not.from_environment) then 361 if (.not.util_nwchemrc_get('scratch_dir',scratch_dir)) then 362 if (debug) then 363 write(luout,*)'util_nwchemrc_get failed for scratch_dir' 364 endif 365 else 366 from_nwchemrc = .true. 367 if (debug) then 368 write(luout,*) 369 & 'nwchemrc return value of scratch_dir <', 370 & scratch_dir(1:inp_strlen(scratch_dir)),'>' 371 endif 372 endif 373 endif 374c 375c 3: use compiled in default setting 376c 377 if (.not.from_environment.and..not.from_nwchemrc) then 378 scratch_dir = ' ' 379 from_compile = .true. 380 endif 381c 382 end 383c 384c----------------------------------------------------------------------- 385c 386 subroutine util_set_default_permanent_dir(permanent_dir) 387 implicit none 388c 389c Sets the default permanent directory name (this may yet be 390c overriden by the name specified in the input). 391c 392c The order of precedence is as follows: 393c 1) the value of NWCHEM_PERMANENT_DIR environment variable 394c 2) the value of permanent_dir key in nwchemrc file(s) 395c 3) the value of the compiled in name 396c 397#include "stdio.fh" 398#include "inp.fh" 399#include "util.fh" 400c 401 character*(*) permanent_dir ! output 402c 403 logical from_environment 404 logical from_nwchemrc 405 logical from_compile 406 logical debug 407c 408 debug = .false. 409 from_nwchemrc = .false. 410 from_environment = .false. 411c 412c 1: check for NWCHEM_PERMANENT_DIR environment variable 413c 414 call util_getenv('NWCHEM_PERMANENT_DIR',permanent_dir) 415 if (debug) then 416 write(luout,*) 417 & 'env return value of NWCHEM_PERMANENT_DIR <', 418 & permanent_dir(1:inp_strlen(permanent_dir)),'>' 419 endif 420 from_environment = (inp_strlen(permanent_dir).gt.0) 421c 422c 2: check for scratch_dir defined in nwchemrc config file(s) 423c 424 if (.not.from_environment) then 425 if (.not.util_nwchemrc_get('permanent_dir',permanent_dir)) then 426 if (debug) then 427 write(luout,*)'util_nwchemrc_get failed for permanent_dir' 428 endif 429 else 430 from_nwchemrc = .true. 431 if (debug) then 432 write(luout,*) 433 & 'nwchemrc return value of permanent_dir <', 434 & permanent_dir(1:inp_strlen(permanent_dir)),'>' 435 endif 436 endif 437 endif 438c 439c 3: use compiled in default setting 440c 441 if (.not.from_environment.and..not.from_nwchemrc) then 442 permanent_dir = ' ' 443 from_compile = .true. 444 endif 445c 446 end 447c 448c----------------------------------------------------------------------- 449c 450 subroutine input_file_info(input_filename, 451 $ rtdb_name, ostartup, ocontinue) 452C$Id$ 453 implicit none 454#include "errquit.fh" 455#include "inp.fh" 456#include "global.fh" 457#include "mafdecls.fh" 458#include "msgids.fh" 459#include "cfileprefix.fh" 460#include "util.fh" 461#include "stdio.fh" 462 character*(*) input_filename ! [input] 463 character*(*) rtdb_name ! [output] 464 logical ostartup ! [output] 465 logical ocontinue ! [output] 466c 467 character*(nw_max_path_len) ecce_file_name 468 character*(nw_max_path_len) a_temporary_file 469 logical status, odirective, echo 470 logical bad_permanent_dir, bad_scratch_dir 471 logical already 472 integer nkeys, istart, iend 473 parameter (nkeys = 7) 474 logical iocheckk 475 integer mitob1 476 character*16 keys(nkeys), field 477 data keys/'start','restart','continue', 478 & 'scratch_dir','permanent_dir', 'ecce_print', 479 $ 'echo'/ 480c 481c Scan the input for start/restart directives and attempt 482c to figure out the name of the desired data base, if the 483c job is a startup or a restart, what the file_prefix is. 484c 485c While we're doing this also scan for scratch_dir and permanent_dir 486c 487c (start || restart) [<file_prefix> = 'from input file base'] \ 488c [rtdb <rtdb_file_name>] 489c 490c scratch_dir <read rest of line as character string> 491c permanent_dir <read rest of line as character string> 492c 493c Only process 0 reads ... everyone else jumps to the broadcast 494c 495 mitob1=MA_sizeof(MT_INT,1,MT_BYTE) 496 scratch_dir = ' ' 497 permanent_dir = ' ' 498 call util_set_default_scratch_dir(scratch_dir) 499 call util_set_default_permanent_dir(permanent_dir) 500 iocheckk=.true. 501#if defined(NOFSCHECK) || defined(CRAYXT) || defined(BGP) || defined(BGQ) 502c on catamount all fs are parallel, therefore we need only node0 503c on BGP/BGQ all fs are parallel, therefore we need only node0 504 iocheckk=ga_nodeid().eq.0 505#endif 506c 507 rtdb_name = ' ' 508 509 if (ga_nodeid() .gt. 0) goto 10000 510c 511c default is a startup with name extracted from that of the input 512c file unless a database of that name is present in which case 513c you get a restart. Overriden by presenting start/restart. 514c 515 odirective = .false. ! True if find a start/restart/continue 516 ostartup = .true. 517 ocontinue = .false. 518 echo = .false. 519 call input_default_file_prefix(input_filename,file_prefix) 520c 521 rewind LuIn 522 call inp_init(LuIn,LuOut) 523 10 if (inp_search(.false., keys, nkeys)) then ! While 524 if (.not. inp_a(field)) call errquit('input_start: inp?',0, 525 & INPUT_ERR) 526 if (inp_compare(.false.,'start',field)) then 527 odirective = .true. 528 ostartup = .true. 529 ocontinue = .false. 530 call util_read_start_dir(file_prefix, rtdb_name) 531 else if (inp_compare(.false.,'continue',field)) then 532 call errquit('continue directive is no longer supported', 533 * 555, INPUT_ERR) 534 odirective = .true. 535 ostartup = .false. 536 ocontinue = .true. 537 call util_read_start_dir(file_prefix, rtdb_name) 538 else if (inp_compare(.false.,'restart',field)) then 539 odirective = .true. 540 ostartup = .false. 541 ocontinue = .false. 542 call util_read_start_dir(file_prefix, rtdb_name) 543 else if (inp_compare(.false.,'scratch_dir',field)) then 544 status = inp_line(scratch_dir) 545 istart = 0 546 status = inp_strtok(scratch_dir,' ',istart, iend) 547 scratch_dir(istart:iend) = ' ' 548 else if (inp_compare(.false.,'permanent_dir',field)) then 549 status = inp_line(permanent_dir) 550 istart = 0 551 status = inp_strtok(permanent_dir,' ',istart, iend) 552 permanent_dir(istart:iend) = ' ' 553 else if (inp_compare(.false.,'echo',field)) then 554 echo = .true. 555 else if (inp_compare(.false.,'ecce_print', field)) then 556 if (inp_a(ecce_file_name)) then 557 call ecce_print_file_open(ecce_file_name) 558 call ecce_print_echo_input(input_filename) 559 endif 560 else 561 call errquit('input_start_opt: wierd error',0, INPUT_ERR) 562 endif 563 goto 10 ! End while 564 endif 565 rewind LuIn 566 call inp_init(LuIn,LuOut) 567c 568 if (echo) call input_echo(LuIn,LuOut) 569c 570 if (rtdb_name .eq. ' ') 571 $ call util_file_name('db',.false.,.false.,rtdb_name) 572c 573 if (.not. odirective) then 574c 575c No start/restart directive presented. See if we can find a database, 576c if so, assume a restart. Otherwise it must be a startup. 577c 578 inquire(file=rtdb_name,exist=status) 579 ostartup = .not. status 580 endif 581c 582 rewind LuIn 583 call inp_init(LuIn,LuOut) 584c 585c Broadcast start options to everyone else 586c 58710000 call ga_brdcst(Msg_StartUp, ostartup, mitob1, 0) 588 call ga_brdcst(Msg_StartUp, ocontinue, mitob1, 0) 589 call util_char_ga_brdcst(Msg_startup, file_prefix, 0) 590 call util_char_ga_brdcst(Msg_startup, scratch_dir, 0) 591 call util_char_ga_brdcst(Msg_startup, permanent_dir, 0) 592* 593* now confirm (on each node) that scratch_dir and permanent_dir 594* can have files 595* 596 call ga_sync() 597*check permanent directory 598 if(iocheckk) then 599 call util_file_name('dir_check_p',.false.,.true., 600 & a_temporary_file) 601 inquire(file=a_temporary_file, exist=already) 602 bad_permanent_dir = .true. 603 if(already) then 604 iend = inp_strlen(a_temporary_file) 605 write(luout,*)' Warning: test file already existed: ', 606 & a_temporary_file(1:iend) 607C Assume all is well in the world, since file might be 608C chmod 000 609 bad_permanent_dir = .false. 610 else 611 open(UNIT=42,FILE=a_temporary_file,STATUS="new",ERR=91111) 612 close(UNIT=42,STATUS="delete") 613 call util_file_unlink(a_temporary_file) 614 bad_permanent_dir = .false. 615 endif 61691111 continue 617*check scratch directory 618 call util_file_name('dir_check_s',.true.,.true., 619 & a_temporary_file) 620 inquire(file=a_temporary_file, exist=already) 621 bad_scratch_dir = .true. 622 if(already) then 623 iend = inp_strlen(a_temporary_file) 624 write(luout,*)' Warning: test file already existed: ', 625 & a_temporary_file(1:iend) 626C Assume all is well in the world, since file might be 627C chmod 000 628 bad_scratch_dir = .false. 629 else 630 open(UNIT=43,FILE=a_temporary_file,STATUS="new",ERR=91122) 631 close(UNIT=43,STATUS="delete") 632 call util_file_unlink(a_temporary_file) 633 bad_scratch_dir = .false. 634 endif 63591122 continue 636 else 637 bad_permanent_dir=.false. 638 bad_scratch_dir=.false. 639 endif 640* 641 if (bad_permanent_dir) then 642 iend = inp_strlen(permanent_dir) 643 write(luout,*)' could not open a file in permanent directory: ', 644 & permanent_dir(1:iend) 645 endif 646 if (bad_scratch_dir) then 647 iend = inp_strlen(scratch_dir) 648 write(luout,*)' could not open a file in scratch directory: ', 649 & scratch_dir(1:iend) 650 endif 651 if (bad_permanent_dir.and.bad_scratch_dir) then 652 write(luout,*) 653 & ' Both permanent and scratch directory not accessible' 654 call errquit('******** Fatal Error ********',911, INPUT_ERR) 655 else if (bad_permanent_dir) then 656 call errquit 657 & ('Fatal Error: permanent directory not accessible',911, 658 & INPUT_ERR) 659 else if (bad_scratch_dir) then 660 call errquit 661 & ('Fatal Error: scratch directory not accessible',911, 662 & INPUT_ERR) 663 else 664 return 665 endif 666c 667 end 668 subroutine input_default_file_prefix(input_file_name,file_prefix) 669 implicit none 670#include "inp.fh" 671 character*(*) input_file_name, file_prefix 672c 673 integer i, start, end 674c 675 end = inp_strlen(input_file_name) 676 do start = end,1,-1 ! Ignore any directories in the path 677 if (input_file_name(start:start) .eq. '/') goto 10 678 enddo 679 10 start = start + 1 680c 681 do i = end,start,-1 ! Remove last trailing .* 682 if (input_file_name(i:i) .eq. '.') then 683 end = i - 1 684 goto 20 685 endif 686 enddo 687c 688 20 if (end .lt. start) then 689 file_prefix = 'calc' ! Confused ... just punt 690 else 691 file_prefix = input_file_name(start:end) 692 endif 693c 694 end 695 subroutine util_read_start_dir(file_prefix, rtdb_name) 696 implicit none 697#include "errquit.fh" 698#include "inp.fh" 699#include "util.fh" 700 character*(*) file_prefix, rtdb_name 701c 702c (start|restart|continue) [<file_prefix>] [rtdb <rtdb_name>] 703c 704 character*(nw_max_path_len) test 705c 706 10 if (inp_a(test)) then 707 if (inp_compare(.false.,test,'rtdb')) then 708 if (.not. inp_a(rtdb_name)) call errquit 709 $ ('util_read_start_directive: missing rtdb name',0, 710 & INPUT_ERR) 711 else 712 file_prefix = test 713 endif 714 goto 10 715 endif 716c 717 end 718 subroutine util_directory_name(dir, oscratch, node) 719 implicit none 720#include "cfileprefix.fh" 721#include "inp.fh" 722#include "global.fh" 723 character*(*) dir ! [output] 724 logical oscratch ! [input] 725 integer node ! [input] 726 logical util_file_parse_dir 727 external util_file_parse_dir 728 character*1024 envscr 729 integer istart,util_getblnk,lencrd 730 external util_getblnk 731c 732c return the name of the scratch/permanent directory for the 733c specified process 734c 735 if (oscratch) then 736 call util_getenv('SCRATCH_DIR',envscr) 737 if(.not.util_file_parse_dir(envscr, dir, ga_nodeid())) 738 I then 739 if (.not. util_file_parse_dir(scratch_dir, dir, node)) then 740 dir = '. ' ! Final default is blank 741 endif 742 endif 743 else 744 call util_getenv('PERMANENT_DIR',envscr) 745 if(.not.util_file_parse_dir(envscr, dir, ga_nodeid())) 746 I then 747 if (.not. util_file_parse_dir(permanent_dir, dir, node)) then 748 dir = '. ' ! Final default is blank 749 endif 750 endif 751 endif 752c 753 end 754 double precision function util_scratch_dir_avail_for_me() 755 implicit none 756#include "errquit.fh" 757#include "global.fh" 758#include "util.fh" 759#include "eaf.fh" 760#include "cfileprefix.fh" 761#include "inp.fh" 762#include "mafdecls.fh" 763#include "stdio.fh" 764#include "msgids.fh" 765c 766c Return the amount of space in Kb available in the scratch 767c directory for this process. 768c 769c Eventually this will be hooked up to input control. 770c Presently, it does the following. 771c 772c For the IBM SP if the directory is /scratch or the same 773c as the default scratch directory, then it assumes that a 774c local (non-shared) scratch directory is being used. 775c FOR ALL OTHER MACHINES it tries to determine the number of 776c processes sharing the directory by looping thru all nodes 777c and seeing if they map to the same directory. This is valid 778c for machines with shared filesystems. 779c 780 integer me, nproc, ierr 781 character*(nw_max_path_len) mine 782 integer nuse 783 integer avail0,avail1 784 integer fd 785 character*8 fstype 786 integer l1megabyte,i_k,l_k,nuse_fail,nattpt, 787 , availmin 788 character*255 dirscr 789 parameter(l1megabyte=2*1000000) 790 logical util_file_parse_dir,oprint 791 external util_file_parse_dir 792c 793 oprint=util_print('available disk',print_high) 794c 795c Construct a name in the scratch directory of the current 796c process and inquire how much space is available 797c 798 me = ga_nodeid() 799 nproc = ga_nnodes() 800 nattpt=0 801 avail0=0 802 avail1=0 803#ifdef NOIO 804 avail0=10**8 805 nuse=ga_nnodes() 806 avail1=-16d0*nuse+avail0 807#else 8081025 call util_file_name('junk',.true.,.true.,mine) 809 ierr=eaf_delete(mine) 810 ierr=eaf_open(mine, eaf_rw, fd) 811 if(ierr.ne.0) call errquit('utilscratchavail: eaf_open',ierr, 812 & DISK_ERR) 813 call ga_sync() 814 ierr = eaf_stat(mine, avail0, fstype) 815c 816c now write 5M of doubles 817c 818 if (.not.ma_push_get(MT_Dbl,l1megabyte,'cc',l_k,i_k)) 819 & call errquit('utilfname: cannot allocate ',0, MA_ERR) 820 call dcopy(l1megabyte,0d0,0,dbl_mb(i_k),1) 821 ierr = eaf_write(fd, 0d0, dbl_mb(i_k),8*l1megabyte) 822 if (.not.ma_pop_stack(l_k)) 823 & call errquit('utilfname: cannot deallocate ',0, MA_ERR) 824 ierr=eaf_close(fd) 825 call ga_sync() 826 ierr = eaf_stat(mine, avail1, fstype) 827 if (ierr .ne. 0) call errquit('util_scratch_avail: eaf_stat',ierr, 828 & DISK_ERR) 829 ierr=eaf_delete(mine) 830 nuse=nint((avail0-avail1)/16d0) 831 nuse_fail=0 832 if (nuse .le. 0) nuse_fail= 1 833 call ga_igop(msg_utscr,nuse_fail,1,'+') 834 if(nuse_fail.ne.0) then 835 if(oprint.and.ga_nodeid().eq.0) write(luout,*) ' negative nuse' 836 nattpt=nattpt+1 837 if(nattpt.gt.3) then 838 if(oprint.and.ga_nodeid().eq.0) then 839 write(luout,*)'utilscravail: too many attempts',nattpt 840 write(luout,*)'utilscravail: set nuse = ga_nnodes' 841 endif 842c 843c something wrong with filesystem: go for upper bound, ie nuse=nproc 844c 845 nuse=ga_nnodes() 846 else 847 goto 1025 848 endif 849 endif 850#endif 851c 852c get min disk space (if you have thin & fat nodes) 853c 854 availmin=avail0/nuse 855 call ga_igop(msg_utscr2,availmin,1,'min') 856 if(oprint) then 857 call util_directory_name(dirscr, .true., ga_nodeid()) 858 write(luout,11) ga_nodeid(),nuse,(avail0-avail1)/16d0, 859 . availmin,avail0/nuse, 860 . dirscr(1:inp_strlen(dirscr)) 861 11 format(i4,': nuse=',i4,'(',f6.1,') avail=',i9,'Mb (out of', 862 . i9,'Mb) on ',A) 863 endif 864c 865c now eaf_stat returns Mb instead of kb 866c 867! avail=avail0*1024 868 869c 870 util_scratch_dir_avail_for_me = 1024d0*dble(availmin) 871c 872 end 873 subroutine util_file_name_resolve(filename, oscratch) 874 implicit none 875#include "errquit.fh" 876#include "inp.fh" 877#include "util.fh" 878#include "global.fh" 879#include "stdio.fh" 880 character*(*) filename ! [input/output] 881 logical oscratch ! [input] 882c 883c If the given filename is not a full path (begins with /) 884c or explicitly relative to the current directory (./ or ../) 885c then resolve it to the scratch/permanent directory for the 886c current process according to oscratch. 887c 888c Note that this resolution cannot happen at input time since only 889c process 0 reads the input and the directories are process specific. 890cc 891 character*(nw_max_path_len) dir 892 integer flen, dlen 893c 894 if ((filename(1:1).ne.'/') .and. (filename(1:2).ne.'./') 895 $ .and. (filename(1:3).ne.'../')) then 896 call util_directory_name(dir, oscratch, ga_nodeid()) 897c 898* write(LuOut,*) 'b fnm = |',filename(1:inp_strlen(filename)),'|' 899* write(LuOut,*) 'b dir = |',dir(1:inp_strlen(dir)),'|' 900c 901 dlen = inp_strlen(dir) 902 if (dlen .gt. 0) then 903 flen = inp_strlen(filename) 904 if ((flen+dlen+1).gt.len(filename)) call errquit 905 $ ('util_file_name_resolve: filename too small', 906 $ flen+dlen+1, INPUT_ERR) 907 dir(dlen+1:dlen+1) = '/' 908 dir(dlen+2:) = filename 909c 910* write(6,*) ' RESOLVED ', filename(1:flen), ' TO ', 911* $ dir(1:inp_strlen(dir)) 912c 913 filename = dir 914 endif 915 endif 916c 917 end 918 subroutine fix_windows_path(path) 919 implicit none 920#include "inp.fh" 921 character*(*) path ! [input/output] 922#if defined(CYGNUS) || defined(WIN32) 923 integer i, l 924c On Windows platforms a backslash is a valid directory separator. 925c Replace backslashes with forward slashes so these pathnames are 926c accepted. 927 l = inp_strlen(path) 928 do i = 1, l 929#if defined(CYGNUS) 930 if (path(i:i) .eq. '\\') then 931#elif defined(WIN32) 932 if (path(i:i) .eq. '\') then 933#endif 934 path(i:i) = '/' 935 endif 936 enddo 937#endif 938 return 939 end 940 941c **** added by EJB 11/7/00 **** 942 subroutine util_file_name_noprefix(stub, oscratch, 943 > oparallel, 944 > name) 945 implicit none 946#include "errquit.fh" 947#include "util.fh" 948#include "inp.fh" 949#include "cfileprefix.fh" 950#include "global.fh" 951#include "stdio.fh" 952c 953 character*(*) stub ! [input] stub name for file 954 logical oscratch ! [input] true=scratch, false=permanent 955 logical oparallel ! [input] true=append .nodeid 956 character*(*) name ! [output] full filename 957c 958 character*(nw_max_path_len) dir, tmp 959 integer ltmp, ldir, me 960 logical util_file_parse_dir 961 external util_file_parse_dir 962c 963 me = ga_nodeid() 964c 965 call util_directory_name(dir, oscratch, me) 966c 967* write(LuOut,*) 'c stub= |',stub(1:inp_strlen(stub)),'|' 968* write(LuOut,*) 'c dir = |', dir(1:inp_strlen(dir)),'|' 969c 970 971 tmp = stub 972 ltmp = inp_strlen(tmp) 973 ldir = inp_strlen(dir) 974 if (ltmp+ldir+1 .gt. len(name)) then 975 write(LuOut,*) ' util_file_name: stub = ', stub 976 write(LuOut,*) ' util_file_name: ltmp, ldir, lname', 977 $ ltmp, ldir, len(name) 978 call util_flush(LuOut) 979 call errquit('util_file_name: name too small', ltmp+ldir+1, 980 & INPUT_ERR) 981 endif 982 if (dir .ne. ' ') then 983 name = dir 984 name(ldir+1:ldir+1) = '/' 985 name(ldir+2:) = tmp 986 else 987 name = tmp 988 endif 989c 990 if (oparallel) then 991 if (inp_strlen(name) .gt. len(tmp)) then 992 write(LuOut,*) ' util_file_name: name = ', name 993 call util_flush(LuOut) 994 call errquit('util_file_name: tmp too small', 995 $ inp_strlen(name), INPUT_ERR) 996 endif 997 tmp = name 998 call util_pname(tmp, name) 999 endif 1000c 1001 end 1002 logical function util_find_dir(dname) 1003 implicit none 1004c 1005c hack that returns true if directory exists 1006c 1007#include "eaf.fh" 1008#include "inp.fh" 1009 character*(*) dname 1010c 1011 double precision availkb 1012 character*20 fstype 1013c 1014 util_find_dir=eaf_stat(dname(1:inp_strlen(dname)), 1015 . availkb, fstype).eq.0 1016 return 1017 end 1018c 1019 subroutine util_full_file_name(filename, oscratch, name) 1020 implicit none 1021#include "errquit.fh" 1022#include "util.fh" 1023#include "inp.fh" 1024#include "cfileprefix.fh" 1025#include "global.fh" 1026#include "stdio.fh" 1027c 1028 character*(*) filename ! [input] raw file name 1029 logical oscratch ! [input] true=scratch, false=permanent 1030 character*(*) name ! [output] full filename including scratch path 1031c 1032 character*(nw_max_path_len) dir, tmp 1033 integer ltmp, ldir, me 1034 logical util_file_parse_dir 1035 external util_file_parse_dir 1036c 1037 me = ga_nodeid() 1038c 1039 call util_directory_name(dir, oscratch, me) 1040c 1041* write(LuOut,*) 'd fnm = |',filename(1:inp_strlen(filename)),'|' 1042* write(LuOut,*) 'd dir = |', dir(1:inp_strlen(dir)),'|' 1043c 1044 tmp = filename 1045 ltmp = inp_strlen(tmp) 1046 ldir = inp_strlen(dir) 1047 if (ltmp+ldir+1 .gt. len(name)) then 1048 write(LuOut,*) ' util_full_file_name: filename = ', filename 1049 write(LuOut,*) ' util_full_file_name: ltmp, ldir, lname', 1050 $ ltmp, ldir, len(name) 1051 call util_flush(LuOut) 1052 call errquit('util_full_file_name: name too small', ltmp+ldir+1, 1053 & INPUT_ERR) 1054 endif 1055 if (dir .ne. ' ') then 1056 name = dir 1057 name(ldir+1:ldir+1) = '/' 1058 name(ldir+2:) = tmp 1059 else 1060 name = tmp 1061 endif 1062c 1063 end 1064 subroutine cphf_fname(cphf_str1,cphf_str2) 1065 implicit none 1066#include "inp.fh" 1067#include "global.fh" 1068 character*(*) cphf_str1 ! [in] 1069 character*(*) cphf_str2 ! [out] 1070c file is managed serially (node 0) on perm_dir 1071c 1072 integer str1len 1073c 1074 str1len=inp_strlen(cphf_str1) 1075 call util_file_name0(cphf_str1(1:str1len), 1076 L .false.,.false., 1077 S cphf_str2,1) 1078 return 1079 end 1080 subroutine cphf_fname_parallel(cphf_str1,cphf_str2) 1081 implicit none 1082#include "inp.fh" 1083#include "global.fh" 1084 character*(*) cphf_str1 ! [in] 1085 character*(*) cphf_str2 ! [out] 1086c file is managed in parallel on scratch_dir 1087c 1088 integer str1len 1089c 1090 str1len=inp_strlen(cphf_str1) 1091 call util_file_name(cphf_str1(1:str1len), 1092c scratch_dir, parallel 1093 L .true.,.true., 1094 S cphf_str2) 1095 write(6,*) ga_nodeid(),' fparal ',cphf_str1(1:str1len), 1096 A cphf_str2(1:inp_strlen(cphf_str2)) 1097 return 1098 end 1099