1c 2c $Id$ 3c 4 5* ************************************************* 6* * * 7* * brillouin_zone_input * 8* * * 9* ************************************************* 10 subroutine brillouin_zone_input(rtdb) 11 implicit none 12#include "errquit.fh" 13#include "inp.fh" 14#include "bafdecls.fh" 15#include "rtdb.fh" 16c 17 integer rtdb 18c 19 integer ind ! Index of matched directive 20 integer num_dirs ! No. of known directives 21 parameter (num_dirs = 7) 22 character*22 dirs(num_dirs) 23 character*255 test 24 25 character*50 rtdb_name 26 character*50 zone_name 27 integer num_kvectors,k,l,num_kvectors_print 28 double precision kvector(4) 29 integer kvs(2),kvs_new(2) 30 31 data dirs / 'zone_name:','zone_name', 32 > 'kvector:','kvector', 33 > 'path', 34 > 'max_kpoints_print', 35 > 'end'/ 36 37c 38c **** intialize stuff **** 39 num_kvectors = 0 40 num_kvectors_print = 0 41 zone_name = 'zone_default' 42c 43c 44 10 if (.not. inp_read()) 45 > call errquit( 46 > 'brillouine_zone_input: inp_read failed', 0, INPUT_ERR) 47 if (.not. inp_a(test)) 48 > call errquit( 49 > 'brillouine_zone_input: failed to read keyword', 0, 50 & INPUT_ERR) 51 if (.not. inp_match(num_dirs, .false., test, dirs, ind)) 52 > call errquit( 53 > 'brillouine_zone_input: unknown directive', 0, 54 & INPUT_ERR) 55 56 57 goto ( 100,100,200,200,300,400, 58 > 9999) ind 59 call errquit( 60 > 'brillouine_zone_input: unimplemented directive', ind, 61 & INPUT_ERR) 62 63c 64c zone_name 65c 66 100 if (.not. inp_a(zone_name)) 67 > call errquit( 68 > 'brillouine_zone_input: failed to read keyword', 0, 69 & INPUT_ERR) 70 goto 10 71 72 73c 74c kvector 75c 76 200 if (.not. inp_f(kvector(1))) 77 > call errquit( 78 > 'brillouine_zone_input: failed to kvector', 0, 79 & INPUT_ERR) 80 if (.not. inp_f(kvector(2))) 81 > call errquit( 82 > 'brillouine_zone_input: failed to kvector', 0, 83 & INPUT_ERR) 84 if (.not. inp_f(kvector(3))) 85 > call errquit( 86 > 'brillouine_zone_input: failed to kvector', 0, 87 & INPUT_ERR) 88 89 if (.not. inp_f(kvector(4))) kvector(4) = -1.0d0 90 91 92 num_kvectors = num_kvectors + 1 93 if (.not. BA_alloc_get(mt_dbl,(4*num_kvectors), 94 > 'kvs_new',kvs_new(2),kvs_new(1))) 95 > call errquit( 96 > 'brillouine_zone_input: heap failed 1', 0, 97 & INPUT_ERR) 98 99 if (num_kvectors.gt.1) then 100 do k=1,(num_kvectors-1) 101 dbl_mb(kvs_new(1) + 4*(k-1)) = dbl_mb(kvs(1) + 4*(k-1)) 102 dbl_mb(kvs_new(1) + 4*(k-1)+1) = dbl_mb(kvs(1) + 4*(k-1)+1) 103 dbl_mb(kvs_new(1) + 4*(k-1)+2) = dbl_mb(kvs(1) + 4*(k-1)+2) 104 dbl_mb(kvs_new(1) + 4*(k-1)+3) = dbl_mb(kvs(1) + 4*(k-1)+3) 105 end do 106 if (.not.BA_free_heap(kvs(2))) 107 > call errquit( 108 > 'brillouine_zone_input: heap failed 2', 0, MA_ERR) 109 end if 110 dbl_mb(kvs_new(1) + 4*(num_kvectors-1)) = kvector(1) 111 dbl_mb(kvs_new(1) + 4*(num_kvectors-1)+1) = kvector(2) 112 dbl_mb(kvs_new(1) + 4*(num_kvectors-1)+2) = kvector(3) 113 dbl_mb(kvs_new(1) + 4*(num_kvectors-1)+3) = kvector(4) 114 kvs(1) = kvs_new(1) 115 kvs(2) = kvs_new(2) 116 117 goto 10 118 119c 120c path 121c 122 300 call band_path_set(rtdb,num_kvectors,kvs) 123 124 goto 10 125 126 127c 128c max_kpoints_print 129c 130 400 if (.not.inp_i(num_kvectors_print)) num_kvectors_print = 0 131 132 goto 10 133 134 135* ***** add brillouin_zone to rtdb **** 136 9999 continue 137 138 l = index(zone_name,' ') -1 139 140 rtdb_name = zone_name(1:l)//':number_kvectors' 141 if (.not. rtdb_put(rtdb,rtdb_name,mt_int,1,num_kvectors)) 142 > call errquit( 143 > 'brillouin_zone_input: rtdb_put(number_kvectors) failed', 0, 144 & RTDB_ERR) 145 146 if (num_kvectors_print.gt.0) then 147 rtdb_name = zone_name(1:l)//':number_kvectors_print' 148 if (.not. rtdb_put(rtdb,rtdb_name,mt_int,1,num_kvectors_print)) 149 > call errquit( 150 > 'brillouin_zone_input: rtdb_put(number_kvectors) failed', 0, 151 > RTDB_ERR) 152 end if 153 154 rtdb_name = zone_name(1:l)//':kvectors' 155 if (.not. rtdb_put(rtdb,rtdb_name,mt_dbl, 156 > (4*num_kvectors), 157 > dbl_mb(kvs(1)))) 158 > call errquit( 159 > 'brillouin_zone_input: rtdb_put(number_kvectors) failed', 0, 160 & RTDB_ERR) 161 162 163 if (.not.BA_free_heap(kvs(2))) 164 > call errquit( 165 > 'brillouine_zone_input: heap failed 3', 0, MA_ERR) 166 return 167 end 168 169 170* ************************************************* 171* * * 172* * monkhost_pack_set * 173* * * 174* ************************************************* 175 176 subroutine monkhorst_pack_set(rtdb,zone_name,nx,ny,nz) 177 implicit none 178 integer rtdb 179 character*(*) zone_name 180 integer nx,ny,nz 181 182#include "errquit.fh" 183#include "bafdecls.fh" 184#include "rtdb.fh" 185 186 !**** local variables **** 187 logical timereverse 188 character*50 rtdb_name 189 integer i1,i2,i3,k,l,num_kvectors 190 integer kvs(2),nn(3) 191 real*8 kx,ky,kz,xx,yy,zz,xxx,yyy,zzz,weight 192 193 timereverse = .true. 194 if (nx.lt.0) then 195 nx = -nx 196 timereverse = .false. 197 end if 198 if (ny.lt.0) then 199 ny = -ny 200 timereverse = .false. 201 end if 202 if (nz.lt.0) then 203 nz = -nz 204 timereverse = .false. 205 end if 206 207 num_kvectors = nx*ny*nz 208 weight = 1.0d0/dble(num_kvectors) 209 210 if(.not.BA_alloc_get(mt_dbl,(4*num_kvectors),'kvs',kvs(2),kvs(1))) 211 > call errquit( 212 > 'monkhorst_pack_set: heap failed 1', 0, 213 > MA_ERR) 214 215 xxx = 1.0d0/(2.0d0*nx) 216 yyy = 1.0d0/(2.0d0*ny) 217 zzz = 1.0d0/(2.0d0*nz) 218 k = 0 219 do i3=0,(nz-1) 220 do i2=0,(ny-1) 221 do i1=0,(nx-1) 222 xx = 1.0d0 + 2*i1 - nx 223 yy = 1.0d0 + 2*i2 - ny 224 zz = 1.0d0 + 2*i3 - nz 225 226 kx = xx*xxx 227 ky = yy*yyy 228 kz = zz*zzz 229 230 dbl_mb(kvs(1) + 4*(k)) = kx 231 dbl_mb(kvs(1) + 4*(k)+1) = ky 232 dbl_mb(kvs(1) + 4*(k)+2) = kz 233 dbl_mb(kvs(1) + 4*(k)+3) = weight 234 235 k = k + 1 236 end do 237 end do 238 end do 239 240 if (timereverse) 241 > call monkhorst_pack_timereversal_prune(num_kvectors, 242 > dbl_mb(kvs(1))) 243 244 245* ***** add brillouin_zone to rtdb **** 246 l = index(zone_name,' ') -1 247 248 rtdb_name = zone_name(1:l)//':number_kvectors' 249 if (.not. rtdb_put(rtdb,rtdb_name,mt_int,1,num_kvectors)) 250 > call errquit( 251 > 'monkhorst_pack_set: rtdb_put(number_kvectors) failed', 0, 252 & RTDB_ERR) 253 254 rtdb_name = zone_name(1:l)//':kvectors' 255 if (.not. rtdb_put(rtdb,rtdb_name,mt_dbl, 256 > (4*num_kvectors), 257 > dbl_mb(kvs(1)))) 258 > call errquit( 259 > 'monkhorst_pack_set: rtdb_put(kvectors) failed', 0, 260 & RTDB_ERR) 261 262 if (timereverse) then 263 nn(1) = nx 264 nn(2) = ny 265 nn(3) = nz 266 else 267 nn(1) = -nx 268 nn(2) = -ny 269 nn(3) = -nz 270 end if 271 rtdb_name = zone_name(1:l)//':monkhorst-pack' 272 if (.not. rtdb_put(rtdb,rtdb_name,mt_int,3,nn)) 273 > call errquit( 274 > 'monkhorst_pack_set: rtdb_put(monkhorst-pack) failed', 0, 275 & RTDB_ERR) 276 277 278 if (.not.BA_free_heap(kvs(2))) 279 > call errquit( 280 > 'monkhorst_pack_set: heap failed 3', 0, MA_ERR) 281 282 return 283 end 284 285* ************************************************* 286* * * 287* * monkhorst_pack_timereversal_prune * 288* * * 289* ************************************************* 290 subroutine monkhorst_pack_timereversal_prune(nks,ks) 291 implicit none 292 integer nks 293 real*8 ks(4,*) 294 integer i,j,nks2 295 real*8 norm 296 297 do i=1,nks-1 298 if (ks(4,i).gt.0.0d0) then 299 do j=i+1,nks 300 if ((dabs(ks(1,i)+ks(1,j)).lt.1.0d-9).and. 301 > (dabs(ks(2,i)+ks(2,j)).lt.1.0d-9).and. 302 > (dabs(ks(3,i)+ks(3,j)).lt.1.0d-9)) then 303 ks(4,i) = ks(4,i) + ks(4,j) 304 ks(4,j) = 0.0d0 305 end if 306 end do 307 end if 308 end do 309 nks2 = 0 310 do i=1,nks 311 if (ks(4,i).gt.0.0d0) nks2 = nks2+1 312 end do 313 i = 1 314 do while (i.lt.nks2) 315 if (ks(4,i).eq.0.0d0) then 316 do j=i+1,nks 317 ks(1,j-1) = ks(1,j) 318 ks(2,j-1) = ks(2,j) 319 ks(3,j-1) = ks(3,j) 320 ks(4,j-1) = ks(4,j) 321 end do 322 else 323 i = i+1 324 end if 325 end do 326 do i=1,nks2 327 norm = ks(1,i) + ks(2,i) + ks(3,i) 328 if (norm.lt.0.0d0) then 329 ks(1,i) = -ks(1,i) 330 ks(2,i) = -ks(2,i) 331 ks(3,i) = -ks(3,i) 332 end if 333 end do 334 nks = nks2 335 return 336 end 337 338 339* ************************************************* 340* * * 341* * dos_states_set * 342* * * 343* ************************************************* 344 345 subroutine dos_states_set(rtdb,zone_name,nx,ny,nz) 346 implicit none 347 integer rtdb 348 character*(*) zone_name 349 integer nx,ny,nz 350 351#include "errquit.fh" 352#include "bafdecls.fh" 353#include "rtdb.fh" 354 355 !**** local variables **** 356 character*50 rtdb_name 357 integer i1,i2,i3,k,l,num_kvectors,nn(3) 358 integer kvs(2) 359 real*8 kx,ky,kz,xx,yy,zz,xxx,yyy,zzz 360 361 362 num_kvectors = nx*ny*nz 363 364 if(.not.BA_alloc_get(mt_dbl,(4*num_kvectors),'kvs',kvs(2),kvs(1))) 365 > call errquit( 366 > 'dos_states_set: heap failed 1', 0, 367 > MA_ERR) 368 369 xxx = 1.0d0/(1.0d0*nx) 370 yyy = 1.0d0/(1.0d0*ny) 371 zzz = 1.0d0/(1.0d0*nz) 372 k = 0 373 do i3=0,(nz-1) 374 do i2=0,(ny-1) 375 do i1=0,(nx-1) 376 xx = i1 377 yy = i2 378 zz = i3 379 380 kx = xx*xxx 381 ky = yy*yyy 382 kz = zz*zzz 383 384 dbl_mb(kvs(1) + 4*(k)) = kx 385 dbl_mb(kvs(1) + 4*(k)+1) = ky 386 dbl_mb(kvs(1) + 4*(k)+2) = kz 387 dbl_mb(kvs(1) + 4*(k)+3) = -1.0d0 388 389 k = k + 1 390 end do 391 end do 392 end do 393 394 395* ***** add brillouin_zone to rtdb **** 396 l = index(zone_name,' ') -1 397 398 rtdb_name = zone_name(1:l)//':number_kvectors' 399 if (.not. rtdb_put(rtdb,rtdb_name,mt_int,1,num_kvectors)) 400 > call errquit( 401 > 'dos_states_set: rtdb_put(number_kvectors) failed', 0, 402 > RTDB_ERR) 403 404 rtdb_name = zone_name(1:l)//':kvectors' 405 if (.not. rtdb_put(rtdb,rtdb_name,mt_dbl, 406 > (4*num_kvectors), 407 > dbl_mb(kvs(1)))) 408 > call errquit( 409 > 'dos_states_set: rtdb_put(number_kvectors) failed', 0, 410 > RTDB_ERR) 411 412 nn(1) = nx 413 nn(2) = ny 414 nn(3) = nz 415 rtdb_name = zone_name(1:l)//':dos-grid' 416 if (.not. rtdb_put(rtdb,rtdb_name,mt_int,3,nn)) 417 > call errquit( 418 > 'dos_states_set: rtdb_put(monkhorst-pack) failed', 0, 419 & RTDB_ERR) 420 421 422 if (.not.BA_free_heap(kvs(2))) 423 > call errquit( 424 > 'dos_states_set: heap failed 3', 0, MA_ERR) 425 426 return 427 end 428 429* ************************************************* 430* * * 431* * band_path_set * 432* * * 433* ************************************************* 434 435 subroutine band_path_set(rtdb,nk,kvs) 436 implicit none 437 integer rtdb 438 integer nk 439 integer kvs(2) 440 441#include "errquit.fh" 442#include "inp.fh" 443#include "bafdecls.fh" 444#include "rtdb.fh" 445 446* *** local variables *** 447 integer i,k,ii,ind,count,count2 448 character*50 test 449 450 integer num_cells ! No. of known directives 451 parameter (num_cells = 8) 452 character*22 cells(num_cells) 453 data cells / 'sc','fcc','bcc', 454 > 'rhombohedral','hexagonal', 455 > 'simple-tetragonal', 456 > 'simple-orthorhombic', 457 > 'bct' / 458 459c CUB,FCC,BCC,TET,BCT1,BCT2,ORC,ORCF1,ORCF2,ORCF3,ORCI,ORCC,HEX,RHL1,RHL2,MCL, 460c MCLC1,MCLC2,MCLC3,MCLC4,MCLC5,TRI1a,TRI2a,TRI1b,TRI2b 461c FCCconventional,BCCconventional,BCT1conventional,BCT2conventional 462c ORCF1conventional,ORCF2conventional,ORCF3conventional,ORCIconventional 463c ORCCconventional 464c MCLC1conventional,MCLC2conventional,MCLC3conventional,MCLC4conventional,MCLC5conventional 465c 466c Standard unit cell types 467c Simple cubic 468c Face-centered cubic - primitive,conventional 469c Body-centered cubic - primitive,conventional 470c Tetragonal 471c Body-centered tegragonal - primitive,conventional 472c Orthorhombic 473c Face-centered orthorhombic - primitive,conventional 474c Body-centered orthorhombic - primitive,conventional 475c C-centered orthorhombic - primitive,conventional 476c Hexagonal 477c Rhombohedral 478c Monoclinic 479c C-centered monoclinic - primitive,conventional 480c Triclinic 481 482 integer pcount, plist(100) 483 integer pcount2, plist2(100) 484 real*8 kvector(4),kvector1(4),kvector2(4),dist,dk 485 logical goodpoint 486 integer kvs_new(2) 487 488 489 if (.not. inp_f(dk)) dk = 0.05d0 !** read in dk increment 490 491 if (.not. inp_a(test)) 492 > call errquit( 493 > 'band_path_set: inp_read failed', 0, INPUT_ERR) 494 495 if (.not. inp_match(num_cells, .false., test, cells, ind)) 496 > call errquit( 497 > 'band_path_set: unknown cell', 0, 498 > INPUT_ERR) 499 500 call band_path_plist(pcount,plist) 501 502 503* *** remove non-special points *** 504 pcount2 = 0 505 do ii=1,pcount 506 call band_path_point(ind,plist(ii),kvector,goodpoint) 507 if (goodpoint) then 508 pcount2=pcount2+1 509 plist2(pcount2) = plist(ii) 510 end if 511 end do 512 513* *** add segments *** 514 do ii=1,pcount2-1 515 call band_path_point(ind,plist2(ii), kvector1,goodpoint) 516 call band_path_point(ind,plist2(ii+1),kvector2,goodpoint) 517 dist = dsqrt( (kvector2(1)-kvector1(1))**2 518 > + (kvector2(2)-kvector1(2))**2 519 > + (kvector2(3)-kvector1(3))**2) 520 count = dist/dk 521 count2 = count 522 if (ii.eq.(pcount2-1)) count2=count2+1 523 do i=1,count2 524 kvector(1) = kvector1(1) 525 > + (i-1)*((kvector2(1)-kvector1(1))/dble(count)) 526 kvector(2) = kvector1(2) 527 > + (i-1)*((kvector2(2)-kvector1(2))/dble(count)) 528 kvector(3) = kvector1(3) 529 > + (i-1)*((kvector2(3)-kvector1(3))/dble(count)) 530 531 nk = nk + 1 532 if (.not. BA_alloc_get(mt_dbl,(4*nk), 533 > 'kvs_new',kvs_new(2),kvs_new(1))) 534 > call errquit( 535 > 'band_path_set: heap failed 1', 0, MA_ERR) 536 537 if (nk.gt.1) then 538 do k=1,(nk-1) 539 dbl_mb(kvs_new(1) + 4*(k-1)) = dbl_mb(kvs(1) + 4*(k-1)) 540 dbl_mb(kvs_new(1) + 4*(k-1)+1) = dbl_mb(kvs(1) + 4*(k-1)+1) 541 dbl_mb(kvs_new(1) + 4*(k-1)+2) = dbl_mb(kvs(1) + 4*(k-1)+2) 542 dbl_mb(kvs_new(1) + 4*(k-1)+3) = dbl_mb(kvs(1) + 4*(k-1)+3) 543 end do 544 if (.not.BA_free_heap(kvs(2))) 545 > call errquit( 546 > 'band_path_set: heap failed 2', 0, MA_ERR) 547 end if 548 dbl_mb(kvs_new(1) + 4*(nk-1)) = kvector(1) 549 dbl_mb(kvs_new(1) + 4*(nk-1)+1) = kvector(2) 550 dbl_mb(kvs_new(1) + 4*(nk-1)+2) = kvector(3) 551 dbl_mb(kvs_new(1) + 4*(nk-1)+3) = kvector(4) 552 kvs(1) = kvs_new(1) 553 kvs(2) = kvs_new(2) 554 end do 555 end do 556 557 return 558 end 559 560 561 subroutine band_path_plist(pcount,plist) 562 implicit none 563 integer pcount,plist(*) 564 565#include "inp.fh" 566#include "bafdecls.fh" 567#include "rtdb.fh" 568 569* *** local variables *** 570 integer ind 571 character*50 test 572 573 integer num_points 574 parameter (num_points = 24) 575 character*6 points(num_points) 576 data points / 'gamma', 577 > 'a','b','c','d','e', 578 > 'f','g','h','k','l','m', 579 > 'n','p','q','r','s', 580 > 't','u','v','w','x', 581 > 'y','z'/ 582 583 pcount = 0 584 do while (inp_a(test)) 585 586 if (inp_match(num_points, .false., test, points, ind)) then 587 pcount = pcount + 1 588 plist(pcount) = ind 589 end if 590 591 end do 592 593 return 594 end 595 596 597 598 subroutine band_path_point(cell,p,kvector,goodpoint) 599 implicit none 600 integer cell,p 601 real*8 kvector(4) 602 logical goodpoint 603 604#include "errquit.fh" 605 606 goodpoint = .false. 607 kvector(4) = -1.0d0 608 609 goto ( 100, 200, 300, 400, 500, 600, 700, 800) cell 610 call errquit( 611 > 'band_path_point: unimplemented cell',cell,INPUT_ERR) 612 613c 614c sc, special points gamma, m, r,x 615c 616 100 if (p.eq.1) then !gamma 617 kvector(1) = 0.0d0 618 kvector(2) = 0.0d0 619 kvector(3) = 0.0d0 620 goodpoint = .true. 621 end if 622 if (p.eq.12) then !m 623 kvector(1) = 0.5d0 624 kvector(2) = 0.5d0 625 kvector(3) = 0.0d0 626 goodpoint = .true. 627 end if 628 if (p.eq.16) then !r 629 kvector(1) = 0.5d0 630 kvector(2) = 0.5d0 631 kvector(3) = 0.5d0 632 goodpoint = .true. 633 end if 634 if (p.eq.22) then !x 635 kvector(1) = 0.0d0 636 kvector(2) = 0.5d0 637 kvector(3) = 0.0d0 638 goodpoint = .true. 639 end if 640 641 goto 9999 642 643 644c 645c fcc, special points gamma,k,l,u,w,x 646c 647 200 if (p.eq.1) then !gamma 648 kvector(1) = 0.0d0 649 kvector(2) = 0.0d0 650 kvector(3) = 0.0d0 651 goodpoint = .true. 652 end if 653 if (p.eq.10) then !k 654 kvector(1) = 0.375d0 655 kvector(2) = 0.375d0 656 kvector(3) = 0.750d0 657 goodpoint = .true. 658 end if 659 if (p.eq.11) then !l 660 kvector(1) = 0.5d0 661 kvector(2) = 0.5d0 662 kvector(3) = 0.5d0 663 goodpoint = .true. 664 end if 665 if (p.eq.19) then !u 666 kvector(1) = 0.625d0 667 kvector(2) = 0.250d0 668 kvector(3) = 0.625d0 669 goodpoint = .true. 670 end if 671 if (p.eq.21) then !w 672 kvector(1) = 0.50d0 673 kvector(2) = 0.25d0 674 kvector(3) = 0.75d0 675 goodpoint = .true. 676 end if 677 if (p.eq.22) then !x 678 kvector(1) = 0.5d0 679 kvector(2) = 0.0d0 680 kvector(3) = 0.5d0 681 goodpoint = .true. 682 end if 683 684 goto 9999 685 686c 687c bcc, special points gamma,h,n,p 688c 689 300 if (p.eq.1) then !gamma 690 kvector(1) = 0.0d0 691 kvector(2) = 0.0d0 692 kvector(3) = 0.0d0 693 goodpoint = .true. 694 end if 695 if (p.eq.9) then !h 696 kvector(1) = 0.5d0 697 kvector(2) = -0.5d0 698 kvector(3) = 0.5d0 699 goodpoint = .true. 700 end if 701 if (p.eq.13) then !n 702 kvector(1) = 0.0d0 703 kvector(2) = 0.0d0 704 kvector(3) = 0.5d0 705 goodpoint = .true. 706 end if 707 if (p.eq.14) then !p 708 kvector(1) = 0.25d0 709 kvector(2) = 0.25d0 710 kvector(3) = 0.25d0 711 goodpoint = .true. 712 end if 713 714 goto 9999 715 716c 717c rhombohedral 718c 719 400 write(*,*) "Rhombohedral path not implemented" 720 goto 9999 721 722c 723c hexagonal, special points gamma,a,h,k,l,m 724c 725 500 if (p.eq.1) then !gamma 726 kvector(1) = 0.0d0 727 kvector(2) = 0.0d0 728 kvector(3) = 0.0d0 729 goodpoint = .true. 730 end if 731 if (p.eq.2) then !a 732 kvector(1) = 0.00d0 733 kvector(2) = 0.00d0 734 kvector(3) = 0.50d0 735 goodpoint = .true. 736 end if 737 if (p.eq.9) then !h 738 kvector(1) = 1.0d0/3.0d0 739 kvector(2) = 1.0d0/3.0d0 740 kvector(3) = 0.50d0 741 goodpoint = .true. 742 end if 743 if (p.eq.10) then !k 744 kvector(1) = 1.0d0/3.0d0 745 kvector(2) = 1.0d0/3.0d0 746 kvector(3) = 0.00d0 747 goodpoint = .true. 748 end if 749 if (p.eq.11) then !l 750 kvector(1) = 0.50d0 751 kvector(2) = 0.00d0 752 kvector(3) = 0.50d0 753 goodpoint = .true. 754 end if 755 if (p.eq.12) then !m 756 kvector(1) = 0.50d0 757 kvector(2) = 0.00d0 758 kvector(3) = 0.00d0 759 goodpoint = .true. 760 end if 761 goto 9999 762 763c 764c simple tetragonal, special points gamma,a,m,r,x,z 765c 766 600 if (p.eq.1) then !gamma 767 kvector(1) = 0.0d0 768 kvector(2) = 0.0d0 769 kvector(3) = 0.0d0 770 goodpoint = .true. 771 end if 772 if (p.eq.2) then !a 773 kvector(1) = 0.50d0 774 kvector(2) = 0.50d0 775 kvector(3) = 0.50d0 776 goodpoint = .true. 777 end if 778 if (p.eq.12) then !m 779 kvector(1) = 0.50d0 780 kvector(2) = 0.50d0 781 kvector(3) = 0.00d0 782 goodpoint = .true. 783 end if 784 if (p.eq.16) then !r 785 kvector(1) = 0.00d0 786 kvector(2) = 0.50d0 787 kvector(3) = 0.50d0 788 goodpoint = .true. 789 end if 790 if (p.eq.22) then !x 791 kvector(1) = 0.00d0 792 kvector(2) = 0.50d0 793 kvector(3) = 0.00d0 794 goodpoint = .true. 795 end if 796 if (p.eq.24) then !z 797 kvector(1) = 0.00d0 798 kvector(2) = 0.00d0 799 kvector(3) = 0.50d0 800 goodpoint = .true. 801 end if 802 803 goto 9999 804c 805c simple orthorhombic, special points gamma,r,s,t,u,x,y,z 806c 807 700 if (p.eq.1) then !gamma 808 kvector(1) = 0.0d0 809 kvector(2) = 0.0d0 810 kvector(3) = 0.0d0 811 goodpoint = .true. 812 end if 813 if (p.eq.16) then !r 814 kvector(1) = 0.50d0 815 kvector(2) = 0.50d0 816 kvector(3) = 0.50d0 817 goodpoint = .true. 818 end if 819 if (p.eq.17) then !s 820 kvector(1) = 0.50d0 821 kvector(2) = 0.50d0 822 kvector(3) = 0.00d0 823 goodpoint = .true. 824 end if 825 if (p.eq.18) then !t 826 kvector(1) = 0.00d0 827 kvector(2) = 0.50d0 828 kvector(3) = 0.50d0 829 goodpoint = .true. 830 end if 831 if (p.eq.19) then !u 832 kvector(1) = 0.50d0 833 kvector(2) = 0.00d0 834 kvector(3) = 0.50d0 835 goodpoint = .true. 836 end if 837 if (p.eq.22) then !x 838 kvector(1) = 0.50d0 839 kvector(2) = 0.00d0 840 kvector(3) = 0.00d0 841 goodpoint = .true. 842 end if 843 if (p.eq.23) then !y 844 kvector(1) = 0.00d0 845 kvector(2) = 0.50d0 846 kvector(3) = 0.00d0 847 goodpoint = .true. 848 end if 849 if (p.eq.24) then !z 850 kvector(1) = 0.00d0 851 kvector(2) = 0.00d0 852 kvector(3) = 0.50d0 853 goodpoint = .true. 854 end if 855 856 goto 9999 857c 858c bct body-centerd tetragonal, special points gamma,m,n,p,x 859c 860 800 if (p.eq.1) then !gamma 861 kvector(1) = 0.0d0 862 kvector(2) = 0.0d0 863 kvector(3) = 0.0d0 864 goodpoint = .true. 865 end if 866 if (p.eq.12) then !m 867 kvector(1) = 0.00d0 868 kvector(2) = 0.00d0 869 kvector(3) = 0.00d0 870 goodpoint = .true. 871 end if 872 if (p.eq.13) then !n 873 kvector(1) = 0.00d0 874 kvector(2) = 0.00d0 875 kvector(3) = 0.00d0 876 goodpoint = .true. 877 end if 878 if (p.eq.14) then !p 879 kvector(1) = 0.00d0 880 kvector(2) = 0.00d0 881 kvector(3) = 0.00d0 882 goodpoint = .true. 883 end if 884 if (p.eq.22) then !x 885 kvector(1) = 0.00d0 886 kvector(2) = 0.00d0 887 kvector(3) = 0.00d0 888 goodpoint = .true. 889 end if 890 891 goto 9999 892 893 894 9999 continue 895 896 897 898 return 899 end 900