1* $Id$ 2* 3 4 5* *********************************** 6* * * 7* * c_geodesic_init * 8* * * 9* *********************************** 10* 11* Uses - c_geodesic common block 12* 13 14 subroutine c_geodesic_init() 15 implicit none 16 17#include "bafdecls.fh" 18#include "errquit.fh" 19#include "c_geodesic_common.fh" 20 21* **** local variables **** 22 integer npack1,neall,nemax,nbrillq 23 24* **** external functions **** 25 integer cpsi_ne,cpsi_neq,cpsi_nbrillq,Pneb_w_size 26 integer cpsi_data_alloc 27 external cpsi_ne,cpsi_neq,cpsi_nbrillq,Pneb_w_size 28 external cpsi_data_alloc 29 30 call Cram_max_npack(npack1) 31 neall = cpsi_neq(1)+cpsi_neq(2) 32 nemax = cpsi_ne(1)+cpsi_ne(2) 33 nbrillq = cpsi_nbrillq() 34 35 U_tag = cpsi_data_alloc(nbrillq,neall,2*npack1) 36 Vt_tag = cpsi_data_alloc(nbrillq,1,2*Pneb_w_size(0,1)) 37 S_tag = cpsi_data_alloc(nbrillq,nemax,1) 38 return 39 end 40 41* *********************************** 42* * * 43* * c_geodesic_finalize * 44* * * 45* *********************************** 46* 47* Uses - c_geodesic common block 48* 49 subroutine c_geodesic_finalize() 50 implicit none 51 52#include "bafdecls.fh" 53#include "errquit.fh" 54#include "c_geodesic_common.fh" 55 56 57 call cpsi_data_dealloc(U_tag) 58 call cpsi_data_dealloc(Vt_tag) 59 call cpsi_data_dealloc(S_tag) 60 return 61 end 62 63 64 65* *********************************** 66* * * 67* * c_geodesic_start * 68* * * 69* *********************************** 70* 71* Uses - c_geodesic common block 72* 73 subroutine c_geodesic_start(A_tag,max_sigma,dE) 74 implicit none 75 integer A_tag 76 real*8 max_sigma,dE 77 78#include "bafdecls.fh" 79#include "errquit.fh" 80#include "c_geodesic_common.fh" 81 82* **** local variables **** 83 logical value 84 integer nb,i,nbrillq,neall,npack1 85 integer ashift,ushift,sshift,vshift,vtshift,V_tag 86 real*8 tmp 87 88* **** external functions **** 89 integer cpsi_nbrillq,cpsi_neq,Pneb_w_size 90 integer cpsi_data_push_stack,cpsi_data_get_chnk 91 real*8 c_electron_eorbit 92 external cpsi_nbrillq,cpsi_neq,Pneb_w_size 93 external cpsi_data_push_stack,cpsi_data_get_chnk 94 external c_electron_eorbit 95 96 97 call nwpw_timing_start(10) 98 99 call Cram_max_npack(npack1) 100 nbrillq = cpsi_nbrillq() 101 neall = cpsi_neq(1)+cpsi_neq(2) 102 103* **** allocate tmp space **** 104 V_tag = cpsi_data_push_stack(nbrillq,1,2*Pneb_w_size(0,1)) 105 106 max_sigma = -1.0d200 107 do nb=1,nbrillq 108 ashift = cpsi_data_get_chnk(A_tag,nb) 109 ushift = cpsi_data_get_chnk(U_tag,nb) 110 vshift = cpsi_data_get_chnk(V_tag,nb) 111 sshift = cpsi_data_get_chnk(S_tag,nb) 112 vtshift = cpsi_data_get_chnk(Vt_tag,nb) 113 114* **** HomeGrown SVD **** 115 call Pneb_SVD(0,nb,npack1, 116 > dbl_mb(ashift), 117 > dbl_mb(ushift), 118 > dbl_mb(sshift), 119 > dbl_mb(vshift) ) 120 121* **** calculate Vt **** 122 call Pneb_w_copy_dagger(0,nb,dbl_mb(vshift),dbl_mb(vtshift)) 123 124* **** find max_sigma **** 125 do i=1,neall 126 tmp=dabs(dbl_mb(sshift)) 127 if (tmp.gt.max_sigma) max_sigma=tmp 128 sshift=sshift+1 129 end do 130 131 end do 132 call K1dB_MaxAll(max_sigma) 133 134* **** calculate 2*<A|H|psi> **** 135 dE = 2.0d0*c_electron_eorbit(A_tag) 136 137* **** deallocate tmp space **** 138 call cpsi_data_pop_stack(V_tag) 139 140 call nwpw_timing_end(10) 141 return 142 end 143 144 145 146* *********************************** 147* * * 148* * c_geodesic_start00 * 149* * * 150* *********************************** 151* 152* Uses - c_geodesic common block 153* 154 subroutine c_geodesic_start00(A_tag,max_sigma,dE) 155 implicit none 156 integer A_tag 157 real*8 max_sigma,dE 158 159#include "bafdecls.fh" 160#include "errquit.fh" 161#include "c_geodesic_common.fh" 162 163* **** local variables **** 164 logical value 165 integer nb,i,nbrillq,neall,npack1 166 integer ashift,ushift,sshift,vshift,vtshift,V_tag 167 real*8 tmp 168 169* **** external functions **** 170 integer cpsi_nbrillq,cpsi_neq,Pneb_w_size 171 external cpsi_nbrillq,cpsi_neq,Pneb_w_size 172 integer cpsi_data_push_stack,cpsi_data_get_chnk 173 external cpsi_data_push_stack,cpsi_data_get_chnk 174 real*8 c_electron_eorbit00 175 external c_electron_eorbit00 176 177 178 call nwpw_timing_start(10) 179 180 call Cram_max_npack(npack1) 181 nbrillq = cpsi_nbrillq() 182 neall = cpsi_neq(1)+cpsi_neq(2) 183 184* **** allocate tmp space **** 185 V_tag = cpsi_data_push_stack(nbrillq,1,2*Pneb_w_size(0,1)) 186 187 max_sigma = -1.0d200 188 do nb=1,nbrillq 189 ashift = cpsi_data_get_chnk(A_tag,nb) 190 ushift = cpsi_data_get_chnk(U_tag,nb) 191 vshift = cpsi_data_get_chnk(V_tag,nb) 192 sshift = cpsi_data_get_chnk(S_tag,nb) 193 vtshift = cpsi_data_get_chnk(Vt_tag,nb) 194 195* **** HomeGrown SVD **** 196 call Pneb_SVD(0,nb,npack1, 197 > dbl_mb(ashift), 198 > dbl_mb(ushift), 199 > dbl_mb(sshift), 200 > dbl_mb(vshift) ) 201 202* **** calculate Vt **** 203 call Pneb_w_copy_dagger(0,nb,dbl_mb(vshift),dbl_mb(vtshift)) 204 205* **** find max_sigma **** 206 do i=1,neall 207 tmp=dabs(dbl_mb(sshift)) 208 if (tmp.gt.max_sigma) max_sigma=tmp 209 sshift=sshift+1 210 end do 211 212 end do 213 call K1dB_MaxAll(max_sigma) 214 215* **** calculate 2*<A|H|psi> **** 216 dE = 2.0d0*c_electron_eorbit00(A_tag) 217 218* **** deallocate tmp space **** 219 call cpsi_data_pop_stack(V_tag) 220 221 call nwpw_timing_end(10) 222 return 223 end 224 225 226 227* *********************************** 228* * * 229* * c_geodesic_start0 * 230* * * 231* *********************************** 232* 233* Uses - c_geodesic common block 234* 235 subroutine c_geodesic_start0(A_tag,max_sigma,dE_tag) 236 implicit none 237 integer A_tag 238 real*8 max_sigma 239 integer dE_tag 240 241#include "bafdecls.fh" 242#include "errquit.fh" 243#include "c_geodesic_common.fh" 244 245* **** local variables **** 246 logical value 247 integer nb,i,nbrillq,neall,npack1 248 integer ashift,ushift,sshift,vshift,vtshift,V_tag,dE_shift 249 real*8 tmp 250 251* **** external functions **** 252 integer cpsi_nbrillq,cpsi_neq,Pneb_w_size 253 external cpsi_nbrillq,cpsi_neq,Pneb_w_size 254 integer cpsi_data_push_stack,cpsi_data_get_chnk 255 external cpsi_data_push_stack,cpsi_data_get_chnk 256 !real*8 c_electron_eorbit 257 !external c_electron_eorbit 258 259 260 call nwpw_timing_start(10) 261 262 call Cram_max_npack(npack1) 263 nbrillq = cpsi_nbrillq() 264 neall = cpsi_neq(1)+cpsi_neq(2) 265 266 !write(*,*) "FERA0, nb=",npack1,nbrillq,neall,Pneb_w_size(0,1) 267 !value = MA_set_auto_verify(.true.) 268 !value = MA_verify_allocator_stuff() 269 !call MA_summarize_allocated_blocks() 270 !write(*,*) "FERA1, nb=",npack1,nbrillq,neall,Pneb_w_size(0,1) 271 272 273* **** allocate tmp space **** 274 V_tag = cpsi_data_push_stack(nbrillq,1,2*Pneb_w_size(0,1)) 275 276 max_sigma = -1.0d200 277 do nb=1,nbrillq 278 ashift = cpsi_data_get_chnk(A_tag,nb) 279 ushift = cpsi_data_get_chnk(U_tag,nb) 280 vshift = cpsi_data_get_chnk(V_tag,nb) 281 sshift = cpsi_data_get_chnk(S_tag,nb) 282 vtshift = cpsi_data_get_chnk(Vt_tag,nb) 283 284* **** HomeGrown SVD **** 285 call Pneb_SVD(0,nb,npack1, 286 > dbl_mb(ashift), 287 > dbl_mb(ushift), 288 > dbl_mb(sshift), 289 > dbl_mb(vshift) ) 290 291* **** calculate Vt **** 292 call Pneb_w_copy_dagger(0,nb,dbl_mb(vshift),dbl_mb(vtshift)) 293 294* **** find max_sigma **** 295 do i=1,neall 296 tmp=dabs(dbl_mb(sshift)) 297 if (tmp.gt.max_sigma) max_sigma=tmp 298 sshift=sshift+1 299 end do 300 301 end do 302 call K1dB_MaxAll(max_sigma) 303 304* **** calculate 2*<A|H|psi> **** 305 call c_electron_eorbit0_tag(A_tag,dE_tag) 306 do nb=1,nbrillq 307 dE_shift = cpsi_data_get_chnk(dE_tag,nb) 308 dbl_mb(dE_shift) = 2.0d0*dbl_mb(dE_shift) 309 end do 310 311 312 !dE = 2.0d0*c_electron_eorbit(A_tag) 313 314* **** deallocate tmp space **** 315 call cpsi_data_pop_stack(V_tag) 316 317 call nwpw_timing_end(10) 318 return 319 end 320 321 322 323 324 325 326 327* ******************************* 328* * * 329* * c_geodesic_get * 330* * * 331* ******************************* 332* 333* Uses - c_geodesic common block 334* 335 336 subroutine c_geodesic_get(t,Yold_tag,Ynew_tag) 337 implicit none 338 real*8 t 339 integer Yold_tag 340 integer Ynew_tag 341 342#include "bafdecls.fh" 343#include "errquit.fh" 344#include "c_geodesic_common.fh" 345 346* **** local variables **** 347 complex*16 zero,one 348 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 349 350 logical value 351 integer nb,npack1,nemax,nbrillq 352 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 353 integer yoldshift,ynewshift,ushift,sshift,vtshift 354 355 356* **** external functions **** 357 logical Pneb_w_push_get,Pneb_w_pop_stack 358 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 359 external Pneb_w_push_get,Pneb_w_pop_stack 360 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 361 362 call nwpw_timing_start(10) 363 call Cram_max_npack(npack1) 364 nemax = cpsi_ne(1)+cpsi_ne(2) 365 nbrillq = cpsi_nbrillq() 366 367* **** allocate tmp space **** 368 value = Pneb_w_push_get(0,1,tmp1) 369 value = value.and.Pneb_w_push_get(0,1,tmp2) 370 value = value.and.Pneb_w_push_get(0,1,tmp3) 371 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 372 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 373 if (.not. value) 374 > call errquit('c_geodesic_get: out of stack memory',0,MA_ERR) 375 376 do nb=1,nbrillq 377 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 378 ynewshift = cpsi_data_get_chnk(Ynew_tag,nb) 379 ushift = cpsi_data_get_chnk(U_tag,nb) 380 sshift = cpsi_data_get_chnk(S_tag,nb) 381 vtshift = cpsi_data_get_chnk(Vt_tag,nb) 382 call Pneb_SCVtrans1(0,nb,t, 383 > dbl_mb(sshift), 384 > dbl_mb(vtshift), 385 > dcpl_mb(tmp1(1)), 386 > dcpl_mb(tmp3(1)), 387 > dbl_mb(tmpC(1)), 388 > dbl_mb(tmpS(1))) 389 390 call Pneb_www_Multiply2(0,nb, 391 > one, 392 > dbl_mb(vtshift), 393 > dcpl_mb(tmp1(1)), 394 > zero, 395 > dcpl_mb(tmp2(1))) 396 397 call Pneb_fwf_Multiply(0,nb, 398 > one, 399 > dbl_mb(yoldshift),npack1, 400 > dcpl_mb(tmp2(1)), 401 > zero, 402 > dbl_mb(ynewshift)) 403 404 call Pneb_fwf_Multiply(0,nb, 405 > one, 406 > dbl_mb(ushift),npack1, 407 > dcpl_mb(tmp3(1)), 408 > one, 409 > dbl_mb(ynewshift)) 410 411* **** Orthonormality Check **** 412 call Pneb_orthoCheckMake(.true.,0,nb,npack1,dbl_mb(ynewshift)) 413 end do 414 415* **** deallocate tmp space **** 416 value = BA_pop_stack(tmpS(2)) 417 value = value.and.BA_pop_stack(tmpC(2)) 418 value = value.and.Pneb_w_pop_stack(tmp3) 419 value = value.and.Pneb_w_pop_stack(tmp2) 420 value = value.and.Pneb_w_pop_stack(tmp1) 421 if (.not. value) 422 > call errquit('error popping stack memory',0, MA_ERR) 423 424 call nwpw_timing_end(10) 425 426 return 427 end 428 429 430 431* ******************************* 432* * * 433* * c_geodesic_get0 * 434* * * 435* ******************************* 436* 437* Uses - c_geodesic common block 438* 439 440 subroutine c_geodesic_get0(nb,t,Yold_tag,Ynew_tag) 441 implicit none 442 integer nb 443 real*8 t 444 integer Yold_tag 445 integer Ynew_tag 446 447#include "bafdecls.fh" 448#include "errquit.fh" 449#include "c_geodesic_common.fh" 450 451* **** local variables **** 452 complex*16 zero,one 453 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 454 455 logical value 456 integer npack1,nemax,nbrillq 457 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 458 integer yoldshift,ynewshift,ushift,sshift,vtshift 459 460 461* **** external functions **** 462 logical Pneb_w_push_get,Pneb_w_pop_stack 463 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 464 external Pneb_w_push_get,Pneb_w_pop_stack 465 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 466 467 call nwpw_timing_start(10) 468 call Cram_max_npack(npack1) 469 nemax = cpsi_ne(1)+cpsi_ne(2) 470 nbrillq = cpsi_nbrillq() 471 472* **** allocate tmp space **** 473 value = Pneb_w_push_get(0,1,tmp1) 474 value = value.and.Pneb_w_push_get(0,1,tmp2) 475 value = value.and.Pneb_w_push_get(0,1,tmp3) 476 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 477 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 478 if (.not. value) 479 > call errquit('c_geodesic_get0: out of stack memory',0,MA_ERR) 480 481 482 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 483 ynewshift = cpsi_data_get_chnk(Ynew_tag,nb) 484 ushift = cpsi_data_get_chnk(U_tag,nb) 485 sshift = cpsi_data_get_chnk(S_tag,nb) 486 vtshift = cpsi_data_get_chnk(Vt_tag,nb) 487 call Pneb_SCVtrans1(0,nb,t, 488 > dbl_mb(sshift), 489 > dbl_mb(vtshift), 490 > dcpl_mb(tmp1(1)), 491 > dcpl_mb(tmp3(1)), 492 > dbl_mb(tmpC(1)), 493 > dbl_mb(tmpS(1))) 494 495 call Pneb_www_Multiply2(0,nb, 496 > one, 497 > dbl_mb(vtshift), 498 > dcpl_mb(tmp1(1)), 499 > zero, 500 > dcpl_mb(tmp2(1))) 501 502 call Pneb_fwf_Multiply(0,nb, 503 > one, 504 > dbl_mb(yoldshift),npack1, 505 > dcpl_mb(tmp2(1)), 506 > zero, 507 > dbl_mb(ynewshift)) 508 509 call Pneb_fwf_Multiply(0,nb, 510 > one, 511 > dbl_mb(ushift),npack1, 512 > dcpl_mb(tmp3(1)), 513 > one, 514 > dbl_mb(ynewshift)) 515 516* **** Orthonormality Check **** 517 call Pneb_orthoCheckMake(.true.,0,nb,npack1,dbl_mb(ynewshift)) 518 519 520* **** deallocate tmp space **** 521 value = BA_pop_stack(tmpS(2)) 522 value = value.and.BA_pop_stack(tmpC(2)) 523 value = value.and.Pneb_w_pop_stack(tmp3) 524 value = value.and.Pneb_w_pop_stack(tmp2) 525 value = value.and.Pneb_w_pop_stack(tmp1) 526 if (.not. value) 527 > call errquit('error popping stack memory',0, MA_ERR) 528 529 call nwpw_timing_end(10) 530 531 return 532 end 533 534 535 536 537 538 539 540 541 542* *********************************** 543* * * 544* * c_geodesic_transport * 545* * * 546* *********************************** 547* 548* Uses - geodesic common block 549* 550 551 subroutine c_geodesic_transport(t,Yold_tag,Ynew_tag) 552 implicit none 553 real*8 t 554 integer Yold_tag 555 integer Ynew_tag 556 557#include "bafdecls.fh" 558#include "errquit.fh" 559#include "c_geodesic_common.fh" 560 561* **** local variables **** 562 complex*16 zero,one,mone 563 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 564 parameter (mone=(-1.0d0,0.0d0)) 565 566 logical value 567 integer nb,npack1,nemax,nbrillq 568 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 569 integer yoldshift,ynewshift,ushift,sshift,vtshift 570 571* **** external functions **** 572 logical Pneb_w_push_get,Pneb_w_pop_stack 573 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 574 external Pneb_w_push_get,Pneb_w_pop_stack 575 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 576 577 call nwpw_timing_start(10) 578 call Cram_max_npack(npack1) 579 nemax = cpsi_ne(1)+cpsi_ne(2) 580 nbrillq = cpsi_nbrillq() 581 582* **** allocate tmp space **** 583 value = Pneb_w_push_get(0,1,tmp1) 584 value = value.and.Pneb_w_push_get(0,1,tmp2) 585 value = value.and.Pneb_w_push_get(0,1,tmp3) 586 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 587 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 588 if (.not. value) 589 > call errquit('c_geodesic_transport:out of stack memory',0,MA_ERR) 590 591 do nb=1,nbrillq 592 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 593 ynewshift = cpsi_data_get_chnk(Ynew_tag,nb) 594 ushift = cpsi_data_get_chnk( U_tag,nb) 595 sshift = cpsi_data_get_chnk( S_tag,nb) 596 vtshift = cpsi_data_get_chnk( Vt_tag,nb) 597 598 call Pneb_SCVtrans2(0,nb,t, 599 > dbl_mb(sshift), 600 > dbl_mb(vtshift), 601 > dcpl_mb(tmp1(1)), 602 > dcpl_mb(tmp3(1)), 603 > dbl_mb(tmpC(1)), 604 > dbl_mb(tmpS(1))) 605 call Pneb_www_Multiply2(0,nb, 606 > one, 607 > dbl_mb(vtshift), 608 > dcpl_mb(tmp1(1)), 609 > zero, 610 > dcpl_mb(tmp2(1))) 611 612 call Pneb_fwf_Multiply(0,nb, 613 > mone, 614 > dbl_mb(yoldshift),npack1, 615 > dcpl_mb(tmp2(1)), 616 > zero, 617 > dbl_mb(ynewshift)) 618 619 call Pneb_fwf_Multiply(0,nb, 620 > one, 621 > dbl_mb(ushift),npack1, 622 > dcpl_mb(tmp3(1)), 623 > one, 624 > dbl_mb(ynewshift)) 625 end do 626* **** deallocate tmp space **** 627 value = BA_pop_stack(tmpS(2)) 628 value = value.and.BA_pop_stack(tmpC(2)) 629 value = value.and.Pneb_w_pop_stack(tmp3) 630 value = value.and.Pneb_w_pop_stack(tmp2) 631 value = value.and.Pneb_w_pop_stack(tmp1) 632 if (.not. value) 633 > call errquit('c_geodesic_transport:error popping stack',0,MA_ERR) 634 635 call nwpw_timing_end(10) 636 637 return 638 end 639 640* *********************************** 641* * * 642* * c_geodesic_transport0 * 643* * * 644* *********************************** 645* 646* Uses - geodesic common block 647* 648 649 subroutine c_geodesic_transport0(nb,t,Yold_tag,Ynew_tag) 650 implicit none 651 integer nb 652 real*8 t 653 integer Yold_tag 654 integer Ynew_tag 655 656#include "bafdecls.fh" 657#include "errquit.fh" 658#include "c_geodesic_common.fh" 659 660* **** local variables **** 661 complex*16 zero,one,mone 662 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 663 parameter (mone=(-1.0d0,0.0d0)) 664 665 logical value 666 integer npack1,nemax,nbrillq 667 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 668 integer yoldshift,ynewshift,ushift,sshift,vtshift 669 670* **** external functions **** 671 logical Pneb_w_push_get,Pneb_w_pop_stack 672 external Pneb_w_push_get,Pneb_w_pop_stack 673 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 674 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 675 676 call nwpw_timing_start(10) 677 call Cram_max_npack(npack1) 678 nemax = cpsi_ne(1)+cpsi_ne(2) 679 !nbrillq = cpsi_nbrillq() 680 681* **** allocate tmp space **** 682 value = Pneb_w_push_get(0,1,tmp1) 683 value = value.and.Pneb_w_push_get(0,1,tmp2) 684 value = value.and.Pneb_w_push_get(0,1,tmp3) 685 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 686 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 687 if (.not. value) 688 > call errquit('c_geodesic_transport:out of stack memory',0,MA_ERR) 689 690 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 691 ynewshift = cpsi_data_get_chnk(Ynew_tag,nb) 692 ushift = cpsi_data_get_chnk( U_tag,nb) 693 sshift = cpsi_data_get_chnk( S_tag,nb) 694 vtshift = cpsi_data_get_chnk( Vt_tag,nb) 695 696 call Pneb_SCVtrans2(0,nb,t, 697 > dbl_mb(sshift), 698 > dbl_mb(vtshift), 699 > dcpl_mb(tmp1(1)), 700 > dcpl_mb(tmp3(1)), 701 > dbl_mb(tmpC(1)), 702 > dbl_mb(tmpS(1))) 703 call Pneb_www_Multiply2(0,nb, 704 > one, 705 > dbl_mb(vtshift), 706 > dcpl_mb(tmp1(1)), 707 > zero, 708 > dcpl_mb(tmp2(1))) 709 710 call Pneb_fwf_Multiply(0,nb, 711 > mone, 712 > dbl_mb(yoldshift),npack1, 713 > dcpl_mb(tmp2(1)), 714 > zero, 715 > dbl_mb(ynewshift)) 716 717 call Pneb_fwf_Multiply(0,nb, 718 > one, 719 > dbl_mb(ushift),npack1, 720 > dcpl_mb(tmp3(1)), 721 > one, 722 > dbl_mb(ynewshift)) 723* **** deallocate tmp space **** 724 value = BA_pop_stack(tmpS(2)) 725 value = value.and.BA_pop_stack(tmpC(2)) 726 value = value.and.Pneb_w_pop_stack(tmp3) 727 value = value.and.Pneb_w_pop_stack(tmp2) 728 value = value.and.Pneb_w_pop_stack(tmp1) 729 if (.not. value) 730 >call errquit('c_geodesic_transport0:error popping stack',0,MA_ERR) 731 732 call nwpw_timing_end(10) 733 734 return 735 end 736 737 738 739 740 741 742 743 744 745* *********************************** 746* * * 747* * c_geodesic_Gtransport * 748* * * 749* *********************************** 750* 751* Uses - geodesic common block 752* 753 754 subroutine c_geodesic_Gtransport(t,Yold_tag,tG_tag) 755 implicit none 756 real*8 t 757 integer Yold_tag 758 integer tG_tag 759 760#include "bafdecls.fh" 761#include "errquit.fh" 762#include "c_geodesic_common.fh" 763 764* **** local variables **** 765 complex*16 zero,one,mone 766 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 767 parameter (mone=(-1.0d0,0.0d0)) 768 769 logical value 770 integer nb,npack1,nemax,nbrillq 771 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 772 integer yoldshift,tGshift,ushift,sshift,vtshift 773 774* **** external functions **** 775 logical Pneb_w_push_get,Pneb_w_pop_stack 776 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 777 external Pneb_w_push_get,Pneb_w_pop_stack 778 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 779 780 call nwpw_timing_start(10) 781 call Cram_max_npack(npack1) 782 nemax = cpsi_ne(1)+cpsi_ne(2) 783 nbrillq = cpsi_nbrillq() 784 785 786* **** allocate tmp space **** 787 value = Pneb_w_push_get(0,1,tmp1) 788 value = value.and.Pneb_w_push_get(0,1,tmp2) 789 value = value.and.Pneb_w_push_get(0,1,tmp3) 790 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 791 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 792 if (.not. value) 793 > call errquit('c_geodesic_transport:out of stack memory',0,MA_ERR) 794 795 796 do nb=1,nbrillq 797 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 798 tGshift = cpsi_data_get_chnk( tG_tag,nb) 799 ushift = cpsi_data_get_chnk( U_tag,nb) 800 sshift = cpsi_data_get_chnk( S_tag,nb) 801 vtshift = cpsi_data_get_chnk( Vt_tag,nb) 802 803 call Pneb_ffw_Multiply(0,nb, 804 > dbl_mb(ushift), 805 > dbl_mb(tGshift),npack1, 806 > dcpl_mb(tmp2(1))) 807 call Pneb_SCVtrans3(0,nb,t, 808 > dbl_mb(sshift), 809 > dcpl_mb(tmp2(1)), 810 > dcpl_mb(tmp1(1)), 811 > dcpl_mb(tmp3(1)), 812 > dbl_mb(tmpC(1)), 813 > dbl_mb(tmpS(1))) 814 call Pneb_www_Multiply2(0,nb, 815 > one, 816 > dbl_mb(vtshift), 817 > dcpl_mb(tmp1(1)), 818 > zero, 819 > dcpl_mb(tmp2(1))) 820 call Pneb_fwf_Multiply(0,nb, 821 > mone, 822 > dbl_mb(yoldshift),npack1, 823 > dcpl_mb(tmp2(1)), 824 > one, 825 > dbl_mb(tGshift)) 826 call Pneb_fwf_Multiply(0,nb, 827 > mone, 828 > dbl_mb(ushift),npack1, 829 > dcpl_mb(tmp3(1)), 830 > one, 831 > dbl_mb(tGshift)) 832 end do 833 834* **** deallocate tmp space **** 835 value = BA_pop_stack(tmpS(2)) 836 value = value.and.BA_pop_stack(tmpC(2)) 837 value = value.and.Pneb_w_pop_stack(tmp3) 838 value = value.and.Pneb_w_pop_stack(tmp2) 839 value = value.and.Pneb_w_pop_stack(tmp1) 840 if (.not. value) 841 > call errquit('c_geodesic_transport:error popping stack',0,MA_ERR) 842 843 call nwpw_timing_end(10) 844 845 return 846 end 847 848 849* ******************************************* 850* * * 851* * c_geodesic_transport_junk * 852* * * 853* ******************************************* 854* 855* Temporary code until BGrsm_list fixed 856* Uses - geodesic common block 857* 858 859 subroutine c_geodesic_transport_junk(t,Yold_tag,Ynew) 860 implicit none 861 real*8 t 862 integer Yold_tag 863 complex*16 Ynew(*) 864 865#include "bafdecls.fh" 866#include "errquit.fh" 867#include "c_geodesic_common.fh" 868 869* **** local variables **** 870 complex*16 zero,one,mone 871 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 872 parameter (mone=(-1.0d0,0.0d0)) 873 874 logical value 875 integer nb,npack1,nemax,nbrillq 876 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 877c integer yoldshift,ynewshift,ushift,sshift,vtshift 878 integer yoldshift,ushift,sshift,vtshift 879 integer nbshift 880 881* **** external functions **** 882 logical Pneb_w_push_get,Pneb_w_pop_stack 883 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 884 external Pneb_w_push_get,Pneb_w_pop_stack 885 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 886 887 call nwpw_timing_start(10) 888 call Cram_max_npack(npack1) 889 nemax = cpsi_ne(1)+cpsi_ne(2) 890 nbrillq = cpsi_nbrillq() 891 nbshift = nemax*npack1 892 893* **** allocate tmp space **** 894 value = Pneb_w_push_get(0,1,tmp1) 895 value = value.and.Pneb_w_push_get(0,1,tmp2) 896 value = value.and.Pneb_w_push_get(0,1,tmp3) 897 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 898 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 899 if (.not. value) 900 > call errquit('c_geodesic_transport:out of stack memory',0,MA_ERR) 901 902 do nb=1,nbrillq 903 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 904c ynewshift = cpsi_data_get_chnk(Ynew_tag,nb) 905 ushift = cpsi_data_get_chnk( U_tag,nb) 906 sshift = cpsi_data_get_chnk( S_tag,nb) 907 vtshift = cpsi_data_get_chnk( Vt_tag,nb) 908 909 call Pneb_SCVtrans2(0,nb,t, 910 > dbl_mb(sshift), 911 > dbl_mb(vtshift), 912 > dcpl_mb(tmp1(1)), 913 > dcpl_mb(tmp3(1)), 914 > dbl_mb(tmpC(1)), 915 > dbl_mb(tmpS(1))) 916 call Pneb_www_Multiply2(0,nb, 917 > one, 918 > dbl_mb(vtshift), 919 > dcpl_mb(tmp1(1)), 920 > zero, 921 > dcpl_mb(tmp2(1))) 922 923 call Pneb_fwf_Multiply(0,nb, 924 > mone, 925 > dbl_mb(yoldshift),npack1, 926 > dcpl_mb(tmp2(1)), 927 > zero, 928 > Ynew(1+(nb-1)*nbshift)) 929 930 call Pneb_fwf_Multiply(0,nb, 931 > one, 932 > dbl_mb(ushift),npack1, 933 > dcpl_mb(tmp3(1)), 934 > one, 935 > Ynew(1+(nb-1)*nbshift)) 936 end do 937* **** deallocate tmp space **** 938 value = BA_pop_stack(tmpS(2)) 939 value = value.and.BA_pop_stack(tmpC(2)) 940 value = value.and.Pneb_w_pop_stack(tmp3) 941 value = value.and.Pneb_w_pop_stack(tmp2) 942 value = value.and.Pneb_w_pop_stack(tmp1) 943 if (.not. value) 944 > call errquit('c_geodesic_transport:error popping stack',0,MA_ERR) 945 946 call nwpw_timing_end(10) 947 948 return 949 end 950 951 952* ******************************************* 953* * * 954* * c_geodesic_Gtransport_junk * 955* * * 956* ******************************************* 957* 958* Temporary code until BGrsm_list fixed 959 960* Uses - geodesic common block 961* 962 963 subroutine c_geodesic_Gtransport_junk(t,Yold_tag,tG) 964 implicit none 965 real*8 t 966 integer Yold_tag 967 complex*16 tG(*) 968c integer tG_tag 969 970#include "bafdecls.fh" 971#include "errquit.fh" 972#include "c_geodesic_common.fh" 973 974* **** local variables **** 975 complex*16 zero,one,mone 976 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 977 parameter (mone=(-1.0d0,0.0d0)) 978 979 logical value 980 integer nb,npack1,nemax,nbrillq 981 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 982c integer yoldshift,tGshift,ushift,sshift,vtshift 983 integer yoldshift,ushift,sshift,vtshift 984 integer nbshift 985 986* **** external functions **** 987 logical Pneb_w_push_get,Pneb_w_pop_stack 988 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 989 external Pneb_w_push_get,Pneb_w_pop_stack 990 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 991 992 call nwpw_timing_start(10) 993 call Cram_max_npack(npack1) 994 nemax = cpsi_ne(1)+cpsi_ne(2) 995 nbrillq = cpsi_nbrillq() 996 nbshift = nemax*npack1 997 998 999* **** allocate tmp space **** 1000 value = Pneb_w_push_get(0,1,tmp1) 1001 value = value.and.Pneb_w_push_get(0,1,tmp2) 1002 value = value.and.Pneb_w_push_get(0,1,tmp3) 1003 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 1004 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 1005 if (.not. value) 1006 > call errquit('c_geodesic_transport:out of stack memory',0,MA_ERR) 1007 1008 1009 do nb=1,nbrillq 1010 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 1011c tGshift = cpsi_data_get_chnk( tG_tag,nb) 1012 ushift = cpsi_data_get_chnk( U_tag,nb) 1013 sshift = cpsi_data_get_chnk( S_tag,nb) 1014 vtshift = cpsi_data_get_chnk( Vt_tag,nb) 1015 1016 call Pneb_ffw_Multiply(0,nb, 1017 > dbl_mb(ushift), 1018 > tG(1+(nb-1)*nbshift),npack1, 1019 > dcpl_mb(tmp2(1))) 1020 call Pneb_SCVtrans3(0,nb,t, 1021 > dbl_mb(sshift), 1022 > dcpl_mb(tmp2(1)), 1023 > dcpl_mb(tmp1(1)), 1024 > dcpl_mb(tmp3(1)), 1025 > dbl_mb(tmpC(1)), 1026 > dbl_mb(tmpS(1))) 1027 call Pneb_www_Multiply2(0,nb, 1028 > one, 1029 > dbl_mb(vtshift), 1030 > dcpl_mb(tmp1(1)), 1031 > zero, 1032 > dcpl_mb(tmp2(1))) 1033 call Pneb_fwf_Multiply(0,nb, 1034 > mone, 1035 > dbl_mb(yoldshift),npack1, 1036 > dcpl_mb(tmp2(1)), 1037 > one, 1038 > tG(1+(nb-1)*nbshift)) 1039 call Pneb_fwf_Multiply(0,nb, 1040 > mone, 1041 > dbl_mb(ushift),npack1, 1042 > dcpl_mb(tmp3(1)), 1043 > one, 1044 > tG(1+(nb-1)*nbshift)) 1045 end do 1046 1047* **** deallocate tmp space **** 1048 value = BA_pop_stack(tmpS(2)) 1049 value = value.and.BA_pop_stack(tmpC(2)) 1050 value = value.and.Pneb_w_pop_stack(tmp3) 1051 value = value.and.Pneb_w_pop_stack(tmp2) 1052 value = value.and.Pneb_w_pop_stack(tmp1) 1053 if (.not. value) 1054 > call errquit('c_geodesic_transport:error popping stack',0,MA_ERR) 1055 1056 call nwpw_timing_end(10) 1057 1058 return 1059 end 1060 1061 1062 1063* ******************************************* 1064* * * 1065* * c_geodesic_transport_junk0 * 1066* * * 1067* ******************************************* 1068* 1069* Temporary code until BGrsm_list fixed 1070* Uses - geodesic common block 1071* 1072 1073 subroutine c_geodesic_transport_junk0(t,Yold_tag,Ynew) 1074 implicit none 1075 real*8 t(*) 1076 integer Yold_tag 1077 complex*16 Ynew(*) 1078 1079#include "bafdecls.fh" 1080#include "errquit.fh" 1081#include "c_geodesic_common.fh" 1082 1083* **** local variables **** 1084 complex*16 zero,one,mone 1085 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 1086 parameter (mone=(-1.0d0,0.0d0)) 1087 1088 logical value 1089 integer nb,npack1,nemax,nbrillq 1090 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 1091c integer yoldshift,ynewshift,ushift,sshift,vtshift 1092 integer yoldshift,ushift,sshift,vtshift 1093 integer nbshift 1094 1095* **** external functions **** 1096 logical Pneb_w_push_get,Pneb_w_pop_stack 1097 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 1098 external Pneb_w_push_get,Pneb_w_pop_stack 1099 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 1100 1101 1102 call nwpw_timing_start(10) 1103 call Cram_max_npack(npack1) 1104 nemax = cpsi_ne(1)+cpsi_ne(2) 1105 nbrillq = cpsi_nbrillq() 1106 nbshift = nemax*npack1 1107 1108* **** allocate tmp space **** 1109 value = Pneb_w_push_get(0,1,tmp1) 1110 value = value.and.Pneb_w_push_get(0,1,tmp2) 1111 value = value.and.Pneb_w_push_get(0,1,tmp3) 1112 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 1113 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 1114 if (.not. value) 1115 > call errquit('c_geodesic_transport:out of stack memory',0,MA_ERR) 1116 1117 do nb=1,nbrillq 1118 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 1119c ynewshift = cpsi_data_get_chnk(Ynew_tag,nb) 1120 ushift = cpsi_data_get_chnk( U_tag,nb) 1121 sshift = cpsi_data_get_chnk( S_tag,nb) 1122 vtshift = cpsi_data_get_chnk( Vt_tag,nb) 1123 1124 call Pneb_SCVtrans2(0,nb,t(nb), 1125 > dbl_mb(sshift), 1126 > dbl_mb(vtshift), 1127 > dcpl_mb(tmp1(1)), 1128 > dcpl_mb(tmp3(1)), 1129 > dbl_mb(tmpC(1)), 1130 > dbl_mb(tmpS(1))) 1131 call Pneb_www_Multiply2(0,nb, 1132 > one, 1133 > dbl_mb(vtshift), 1134 > dcpl_mb(tmp1(1)), 1135 > zero, 1136 > dcpl_mb(tmp2(1))) 1137 1138 call Pneb_fwf_Multiply(0,nb, 1139 > mone, 1140 > dbl_mb(yoldshift),npack1, 1141 > dcpl_mb(tmp2(1)), 1142 > zero, 1143 > Ynew(1+(nb-1)*nbshift)) 1144 1145 call Pneb_fwf_Multiply(0,nb, 1146 > one, 1147 > dbl_mb(ushift),npack1, 1148 > dcpl_mb(tmp3(1)), 1149 > one, 1150 > Ynew(1+(nb-1)*nbshift)) 1151 end do 1152* **** deallocate tmp space **** 1153 value = BA_pop_stack(tmpS(2)) 1154 value = value.and.BA_pop_stack(tmpC(2)) 1155 value = value.and.Pneb_w_pop_stack(tmp3) 1156 value = value.and.Pneb_w_pop_stack(tmp2) 1157 value = value.and.Pneb_w_pop_stack(tmp1) 1158 if (.not.value) 1159 >call errquit('c_geodesic_transport0:error popping stack',0,MA_ERR) 1160 1161 call nwpw_timing_end(10) 1162 1163 return 1164 end 1165 1166 1167 1168 1169* ******************************************* 1170* * * 1171* * c_geodesic_Gtransport_junk0 * 1172* * * 1173* ******************************************* 1174* 1175* Temporary code until BGrsm_list fixed 1176 1177* Uses - geodesic common block 1178* 1179 subroutine c_geodesic_Gtransport_junk0(t,Yold_tag,tG) 1180 implicit none 1181 real*8 t(*) 1182 integer Yold_tag 1183 complex*16 tG(*) 1184c integer tG_tag 1185 1186#include "bafdecls.fh" 1187#include "errquit.fh" 1188#include "c_geodesic_common.fh" 1189 1190* **** local variables **** 1191 complex*16 zero,one,mone 1192 parameter (zero=(0.0d0,0.0d0), one=(1.0d0,0.0d0)) 1193 parameter (mone=(-1.0d0,0.0d0)) 1194 1195 logical value 1196 integer nb,npack1,nemax,nbrillq 1197 integer tmp1(2),tmp2(2),tmp3(2),tmpC(2),tmpS(2) 1198c integer yoldshift,tGshift,ushift,sshift,vtshift 1199 integer yoldshift,ushift,sshift,vtshift 1200 integer nbshift 1201 1202* **** external functions **** 1203 logical Pneb_w_push_get,Pneb_w_pop_stack 1204 integer cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 1205 external Pneb_w_push_get,Pneb_w_pop_stack 1206 external cpsi_ne,cpsi_nbrillq,cpsi_data_get_chnk 1207 1208 call nwpw_timing_start(10) 1209 call Cram_max_npack(npack1) 1210 nemax = cpsi_ne(1)+cpsi_ne(2) 1211 nbrillq = cpsi_nbrillq() 1212 nbshift = nemax*npack1 1213 1214 1215* **** allocate tmp space **** 1216 value = Pneb_w_push_get(0,1,tmp1) 1217 value = value.and.Pneb_w_push_get(0,1,tmp2) 1218 value = value.and.Pneb_w_push_get(0,1,tmp3) 1219 value = value.and.BA_push_get(mt_dbl,nemax,'tmpC',tmpC(2),tmpC(1)) 1220 value = value.and.BA_push_get(mt_dbl,nemax,'tmpS',tmpS(2),tmpS(1)) 1221 if (.not.value) 1222 >call errquit('c_geodesic_transport0:out of stack memory',0,MA_ERR) 1223 1224 do nb=1,nbrillq 1225 yoldshift = cpsi_data_get_chnk(Yold_tag,nb) 1226c tGshift = cpsi_data_get_chnk( tG_tag,nb) 1227 ushift = cpsi_data_get_chnk( U_tag,nb) 1228 sshift = cpsi_data_get_chnk( S_tag,nb) 1229 vtshift = cpsi_data_get_chnk( Vt_tag,nb) 1230 1231 call Pneb_ffw_Multiply(0,nb, 1232 > dbl_mb(ushift), 1233 > tG(1+(nb-1)*nbshift),npack1, 1234 > dcpl_mb(tmp2(1))) 1235 call Pneb_SCVtrans3(0,nb,t(nb), 1236 > dbl_mb(sshift), 1237 > dcpl_mb(tmp2(1)), 1238 > dcpl_mb(tmp1(1)), 1239 > dcpl_mb(tmp3(1)), 1240 > dbl_mb(tmpC(1)), 1241 > dbl_mb(tmpS(1))) 1242 call Pneb_www_Multiply2(0,nb, 1243 > one, 1244 > dbl_mb(vtshift), 1245 > dcpl_mb(tmp1(1)), 1246 > zero, 1247 > dcpl_mb(tmp2(1))) 1248 call Pneb_fwf_Multiply(0,nb, 1249 > mone, 1250 > dbl_mb(yoldshift),npack1, 1251 > dcpl_mb(tmp2(1)), 1252 > one, 1253 > tG(1+(nb-1)*nbshift)) 1254 call Pneb_fwf_Multiply(0,nb, 1255 > mone, 1256 > dbl_mb(ushift),npack1, 1257 > dcpl_mb(tmp3(1)), 1258 > one, 1259 > tG(1+(nb-1)*nbshift)) 1260 end do 1261 1262* **** deallocate tmp space **** 1263 value = BA_pop_stack(tmpS(2)) 1264 value = value.and.BA_pop_stack(tmpC(2)) 1265 value = value.and.Pneb_w_pop_stack(tmp3) 1266 value = value.and.Pneb_w_pop_stack(tmp2) 1267 value = value.and.Pneb_w_pop_stack(tmp1) 1268 if (.not.value) 1269 >call errquit('c_geodesic_transport0:error popping stack',0,MA_ERR) 1270 1271 call nwpw_timing_end(10) 1272 1273 return 1274 end 1275