1 subroutine ga_lkain_2cpl3_ext(rtdb, 2 & g_x, g_b, 3 & g_x_im, g_b_im, 4 & product, precond, 5 $ tol, mmaxsub, maxiter, 6 & odiff, oprint, omega, limag, 7 & lifetime, gamwidth, ncomp) 8 9c $Id$ 10c Written by J. Autschbach, SUNY Buffalo 11c Improvements made 12c by F. Aquino, Northwestern University 13c 03-15-12 14c Note.- Modifying/Improving ga_lkain_2cpl3() 15 16 implicit none 17#include "errquit.fh" 18#include "mafdecls.fh" 19#include "global.fh" 20#include "util.fh" 21#include "inp.fh" 22#include "stdio.fh" 23#include "rtdb.fh" 24 integer ncomp ! [input] no. of components to treat 25 integer rtdb ! [input] database handle 26 integer g_x(ncomp) ! [input/output] Initial guess/solution 27 integer g_x_im(ncomp) ! not used 28 integer g_b(ncomp) ! [input] Right-hand side vectors 29 integer g_b_im(ncomp) ! not used 30 double precision omega ! [input] coupling parameter 31 logical limag ! [input] imaginary perturbation? 32 logical lifetime ! [input] consider damping or not? 33 double precision gamwidth ! [input] damping parameter 34 35 external product ! [input] product routine 36 external precond ! [input] preconditioner routine 37 double precision tol ! [input] convergence threshold 38 integer mmaxsub ! [input] maximum subspace dimension 39 integer maxiter ! [input] maximum no. of iterations 40 logical odiff ! [input] use differences in product 41 logical oprint ! [input] print flag 42 43 integer ipm 44c 45c Solves the linear equations A(X)=0 for multiple vectors. 46c 47c ... jochen: 48c This is a modified version of ga_lkain from file ga_it2.F 49c This version allows to solve a coupled set of equations, i.e. 50c there are two right-hand vectors and two initial guesses and two 51c solutions which are coupled. The coupling is mediated by a 52c parameter omega in the call to the preconditioner 53c (elsewhere, omega is simply called "frequency") 54c 55c note: when called from cphf_solve3, odiff = .false. on input 56c 57c call product(acc,g_x, g_Ax) 58c . acc is the accuracy trequired for each element of the product 59c . g_x contains the vectors and g_Ax should be filled 60c . with the product vectors. The no. of vectors (columns) in 61c . g_x might differ from the no. of vectors input to ga_lkain(). 62c 63c call precond(g_x,shift) 64c . apply preconditioning directly to the vectors in g_x with the 65c . coupling parameter omega 66c 67c On input g_x should contain an initial guess. It returns the 68c solution. 69c 70c maxsub should be at least 3*nvec and can be beneficially increased 71c to about 10*nvec. 72c 73c Needs to be extended to store the sub-space vectors out-of-core 74c at least while the product() routine is being executed. 75 76 integer iter, n, n2, nvec, nsub, isub, type, maxsub, 77 & ntmp1, ntmp2 78 79c ... jochen: for convenience, now most arrays have two components. 80c that might be changed later if memory becomes an issue 81 integer g_y,g_Ay,g_r2, 82 & g_Ax(ncomp),g_r(ncomp), 83 & g_xold(ncomp),g_Axold(ncomp),g_Ax_im(ncomp) 84 double precision rmax,acc 85 logical converged 86 logical odebug,debug,converge_precond 87 logical debug1 88 89 character*255 filestub,filesoln 90 character*4 digit4 91 logical file_write_ga, file_read_ga 92 external file_write_ga, file_read_ga 93c 94 logical solver_restart 95 external solver_restart 96c 97 logical do_restart 98c 99c ================================================================= 100 101 debug = (.false. .and. ga_nodeid().eq.0) ! for code development 102 debug1=.false. 103 104c check input key if we should check for convergence 105c after the preconditioner has been applied to the residual 106 if (.not. rtdb_get(rtdb, 'aoresponse:precond', mt_log, 1, 107 & converge_precond)) 108 & converge_precond = .false. 109 110 if (debug) write (6,*) 'ga_lkain_2cpl3 omega =',omega 111 if (debug) write (6,*) 'ga_lkain_2cpl3 limag =',limag 112 if (debug) write (6,*) 'ga_lkain_2cpl3 lifetime,gamwidth', 113 & lifetime,gamwidth 114 if (debug) write (6,*) 'ga_lkain_2cpl3 converge_precond', 115 & converge_precond 116 117 if (lifetime) call errquit('ga_lkain_2cpl3 called with damping', 118 & 0,UNKNOWN_ERR) 119c 120 odebug = util_print('debug lsolve', print_never) .and. 121 $ ga_nodeid().eq.0 122 if (.not. rtdb_get(rtdb, 'cphf:acc', mt_dbl, 1, 123 & acc)) acc = 1d-4*tol 124c 125 call ga_inquire(g_x(1), type, n, nvec) 126 127 if (ncomp.gt.1) then 128 call ga_inquire(g_x(2), type, ntmp1, ntmp2) 129c ... jochen: do a sanity check on the array dimensions 130 if (ntmp1.ne.n .or. ntmp2.ne.nvec) call errquit 131 & ('ga_lkain_2cpl:inconsistent dimensions of g_x components', 132 & nvec,CALC_ERR) 133 endif 134 135c later we combine the two components to vectors of double 136c length if we have two components, otherwise not: 137 n2 = n 138 if (ncomp.gt.1) n2 = n+n 139 140 maxsub = mmaxsub ! So don't modify input scalar arg 141 if (maxsub .lt. 3*nvec) maxsub = 3*nvec 142 maxsub = (maxsub/nvec)*nvec 143c 144 if (oprint .and. ga_nodeid().eq.0) then 145 write(6,1) n2, nvec, maxsub, tol, util_wallsec() 146 1 format(//,'Iterative solution of linear equations',/, 147 $ ' No. of variables', i9,/, 148 $ ' No. of equations', i9,/, 149 $ ' Maximum subspace', i9,/, 150 $ ' Convergence', 1p,d9.1,/, 151 $ ' Start time', 0p,f9.1,/) 152 call util_flush(6) 153 end if 154c 155 do ipm = 1,ncomp 156 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: Ax', 157 $ 0, 0, g_Ax(ipm))) 158 $ call errquit('lkain: failed allocating Ax', nvec, 159 & GA_ERR) 160 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: r', 161 $ 0, 0, g_r(ipm))) 162 $ call errquit('lkain_2cpl: failed allocating r', nvec, 163 & GA_ERR) 164 if (odiff) then 165 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: xold', 166 $ 0, 0, g_xold(ipm))) 167 $ call errquit('lkain: failed allocating xold', nvec, 168 & GA_ERR) 169 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: xold', 170 $ 0, 0, g_Axold(ipm))) 171 $ call errquit('lkain: failed allocating Axold', nvec, 172 & GA_ERR) 173 call ga_zero(g_xold(ipm)) 174 call ga_zero(g_Axold(ipm)) 175 end if ! odiff 176 call ga_zero(g_Ax(ipm)) 177 call ga_zero(g_r(ipm)) 178c 179 enddo ! ipm = 1,ncomp 180 181c allocate g_y, g_Ay, and g_r2 with dimension n2 to hold 182c the number of components 183 if (.not. ga_create(MT_DBL, n2, maxsub, 'lkain_2cpl: Y', 184 $ 0, 0, g_y)) 185 $ call errquit('lkain: failed allocating subspace', maxsub, 186 & GA_ERR) 187 if (.not. ga_create(MT_DBL, n2, maxsub, 'lkain_2cpl: Ay', 188 $ 0, 0, g_Ay)) 189 $ call errquit('lkain: failed allocating subspace2', maxsub, 190 & GA_ERR) 191 if (.not. ga_create(MT_DBL, n2, nvec, 'lkain_2cpl: r2', 192 $ 0, 0, g_r2)) 193 $ call errquit('lkain_2cpl: failed allocating r2', nvec, 194 & GA_ERR) 195 196 call ga_zero(g_y) 197 call ga_zero(g_Ay) 198 call ga_zero(g_r2) 199 call ga_sync() 200c 201c Solution file 202c 203 if (.not. rtdb_cget(rtdb, 'solver:filestub', 1, filestub)) 204 & filestub = 'lkain_soln' 205 if (.not. rtdb_cget(rtdb, 'solver:filesoln', 1, filesoln)) 206 & filesoln = 'lkain_soln' 207#if 0 208 call util_file_name(filestub,.false.,.false.,filesoln) 209#else 210 call cphf_fname(filestub,filesoln) 211#endif 212 if (ga_nodeid().eq.0) write(luout,*) "ga_lkain filestub:",filestub 213 if (ga_nodeid().eq.0) write(luout,*) "ga_lkain filesoln:",filesoln 214c 215c Check if this is a restart 216c 217 if (solver_restart(rtdb)) then 218 do_restart = .true. 219c write(6,*) ' attempt reading restart ' 220 do ipm = 1,ncomp 221 write(digit4,'(".",i3.3)') ipm 222 if(.not.file_read_ga( 223 P filesoln(1:inp_strlen(filesoln))//digit4,g_x(ipm) 224 C )) call errquit 225 $ ('ga_lkain:could not read solution',1, DISK_ERR) 226 enddo 227 if (do_restart) then 228 if (ga_nodeid().eq.0) 229 & write(luout,*) "Restarting solution from: ", 230 P filesoln(1:inp_strlen(filesoln))//digit4 231 else 232 if (ga_nodeid().eq.0) 233 & write(luout,*) "Error in restart solution: ", filesoln 234 end if ! do_restart 235 end if ! solver_restart 236c 237 if (oprint .and. ga_nodeid().eq.0) then 238 write(6,2) 239 call util_flush(6) 240 2 format(/ 241 $ ' iter nsub residual time ',/, 242 $ ' ---- ------ -------- --------- ') 243 end if 244c 245 nsub = 0 246 converged = .false. 247c 248c --------------------- 249c start interation loop 250c --------------------- 251c 252 do iter = 1, maxiter 253c 254c ... jochen: here in the iteration loops we keep track 255c of two components of the solution vector, ipm = 1 and 2 256c (ipm stands for + (plus) and - (minus) components) 257c 258 if (odiff) then 259 do ipm = 1,ncomp 260 call ga_add(1.0d0,g_x(ipm), 261 & -1.0d0,g_xold(ipm), 262 & g_x(ipm)) 263 call ga_sync() 264 enddo ! end-loop-ncomp 265 endif 266c 267c ... jochen: call product routine with initial or intermediate 268c solution vector: g_x and g_Ax MUST have two components here 269 270 if (debug) write (6,*) 'calling product from ga_lkain_2cpl' 271 272 call product(acc, 273 & g_x , g_Ax, 274 & g_x_im, g_Ax_im, 275 & omega, limag, 276 & lifetime, gamwidth, ncomp) 277 278 if (debug) write (6,*) 'returning product from ga_lkain_2cpl' 279 280c g_r is zeroed below so we should make sure to do the same 281c with g_r2 here 282 call ga_zero(g_r2) 283 284 do ipm = 1,ncomp 285 if (odiff) then 286 call ga_add(1.0d0, g_Ax(ipm), 287 & 1.0d0, g_Axold(ipm), 288 & g_Ax(ipm)) 289 call ga_add(1.0d0, g_x(ipm), 290 & 1.0d0, g_xold(ipm), 291 & g_x(ipm)) 292 call ga_sync() 293 call ga_copy(g_x(ipm), g_xold(ipm)) 294 call ga_copy(g_Ax(ipm), g_Axold(ipm)) 295 end if 296 call ga_zero(g_r(ipm)) 297c 298c g_Ax = g_b if the system is solved. During the first cycle, 299c g_Ax is calculated from the initial guess 300 call ga_add(1.0d0, g_b(ipm), 301 & -1.0d0, g_Ax(ipm), 302 & g_r(ipm)) ! The residual 303 enddo ! ipm = 1,ncomp 304 305c if (ga_nodeid().eq.0) 306c & write(*,*) 'FA BEF get_precond_rmax' 307 308 call get_precond_rmax_re( 309 & rmax, ! out: max(g_r,g_r_im) 310 & g_r, ! in : real part of g_zr 311 & g_Ax, ! in : real part of g_Az 312 & precond, ! in : name of preconditioner routine 313 & converge_precond, ! in : =.true. prec->max 314 & omega, ! in : omega 315 & ncomp, ! in : nr. components 316 & iter, ! in : nr. iteration 317 & debug1) ! in : =.true. -> allow debug printouts 318 319c if (ga_nodeid().eq.0) 320c & write(*,*) 'FA AFT get_precond_rmax' 321 322c JEM: Putting rmax into rtdb 323 if (.not. rtdb_put(rtdb, 'lkain:rmax', mt_dbl, 1, rmax)) 324 $ call errquit('ga_lkain_2cpl3_ext: rmax put failed', 1, 325 $ RTDB_ERR) 326 327 if (oprint .and. ga_nodeid().eq.0) then 328 write(6,3) iter, nsub+nvec, rmax, util_wallsec() 329 call util_flush(6) 330 3 format(' ', i5, i7, 3x,1p,d9.2,0p,f10.1,5x,i3) 331 end if 332 333c stop iterations if residual is smaller than criterion 334 do ipm = 1,ncomp 335 write(digit4,'(".",i3.3)') ipm 336 if(.not.file_write_ga( 337 P filesoln(1:inp_strlen(filesoln))//digit4,g_x(ipm) 338 C )) call errquit 339 $ ('ga_lkain:could not write solution',1, DISK_ERR) 340 enddo 341 if (rmax .lt. tol) then 342 converged = .true. 343 goto 100 344 end if 345 346c Copy the vectors to the subspace work area 347 call updating_Az1_z1_zr1( 348 & g_Ay, ! in/ou: 349 & g_y, ! in/ou: 350 & g_r2, ! in/ou: 351 & g_Ax, ! in : 352 & g_x, ! in : 353 & g_r, ! in : 354 & nvec, ! in : 355 & ncomp, ! in : 356 & nsub, ! in : 357 & n) ! in : 358 359 nsub = nsub + nvec 360 361 call solve_xlineq( 362 & g_x, ! in/out: updated solution 363 & g_Ay, ! in : history of g_Az 364 & g_y, ! in : history of g_z 365 & g_r2, ! in : history of g_zr 366 & nsub, ! in : subspace length 367 & nvec, ! in : increment of subspace 368 & ncomp, ! in : nr. components 369 & n, ! in : nr. elements per comp. 370 & iter, ! in : iteration nr. 371 & debug1)! in : =.true. show debug printouts 372 373 if (nsub .eq. maxsub) then 374c 375c Reduce the subspace as necessary 376c 377c ====== FA: left-shifting patch ==== START 378c Note.- matrices Ay,y shift to left nvec positions 379c removing leftmost patch of dimension: n4 x nvec 380c if (ga_nodeid().eq.0) 381c & write(*,*) 'FA-matrix-nvec-left-shifting:' 382 do isub = nvec+1, maxsub, nvec 383 call ga_copy_patch('n',g_Ay,1,n2,isub,isub+nvec-1, 384 $ g_Ay,1,n2,isub-nvec,isub-1) 385 call ga_copy_patch('n',g_y ,1,n2,isub,isub+nvec-1, 386 $ g_y ,1,n2,isub-nvec,isub-1) 387 enddo ! end-loop-isub 388c ====== FA: left-shifting patch ==== END 389 nsub = nsub - nvec 390 end if ! (nsub .eq. maxsub) 391 end do ! iter = 1,maxiter 392 100 continue ! jump here if converged 393c deallocate workspace: 394c 395c Save intermediate solution 396c 397 do ipm = 1,ncomp 398 write(digit4,'(".",i3.3)') ipm 399 if(.not.file_write_ga( 400 P filesoln(1:inp_strlen(filesoln))//digit4,g_x(ipm) 401 C )) call errquit 402 $ ('ga_lkain:could not write solution',1, DISK_ERR) 403 enddo 404 do ipm = 1,ncomp 405 if (odiff) then 406 if (.not. ga_destroy(g_xold(ipm))) call errquit 407 & ('lkain_2cpl: destroy',1, GA_ERR) 408 if (.not. ga_destroy(g_Axold(ipm))) call errquit 409 & ('lkain_2cpl: destroy',2,GA_ERR) 410 end if 411 if (.not. ga_destroy(g_Ax(ipm))) call errquit 412 & ('lkain_2cpl: destroy',20, GA_ERR) 413 if (.not. ga_destroy(g_r(ipm))) call errquit 414 & ('lkain_2cpl: destroy',5, GA_ERR) 415c 416 enddo ! ipm = 1,2 417 418 if (.not. ga_destroy(g_Ay)) call errquit 419 & ('lkain_2cpl: destroy Ay',3, GA_ERR) 420 if (.not. ga_destroy(g_y)) call errquit 421 & ('lkain_2cpl: destroy r',4, GA_ERR) 422 if (.not. ga_destroy(g_r2)) call errquit 423 & ('lkain_2cpl: destroy r2',6, GA_ERR) 424 425 if (.not. converged) then 426 if (ga_nodeid().eq.0) then 427 write (luout,*) 'WARNING: CPKS procedure is NOT converged' 428 write (luout,*) ' I will proceed, but check your results!' 429 endif 430 endif 431 end 432 433 subroutine copy_r2tor(g_r2, 434 & g_r, 435 & g_r_im, 436 & ncomp, 437 & nvec, 438 & n, 439 & lifetime) 440c 441c Author: Fredy W. Aquino, Northwestern University 442c Date : 03-15-12 443 444 implicit none 445#include "errquit.fh" 446#include "mafdecls.fh" 447#include "global.fh" 448#include "util.fh" 449#include "rtdb.fh" 450 integer ncomp 451 integer g_r2,g_r(ncomp),g_r_im(ncomp) 452 integer nvec,n,m1,m2,ipm 453 logical lifetime 454 m1=1 455 m2=n 456 do ipm=1,ncomp 457 call ga_copy_patch('n',g_r2 ,m1,m2,1,nvec, 458 $ g_r(ipm),1 ,n ,1,nvec) 459 m1=m1+n 460 m2=m2+n 461 enddo !end-loop-ipm 462 if (lifetime) then 463 do ipm=1,ncomp 464 call ga_copy_patch('n',g_r2 ,m1,m2,1,nvec, 465 $ g_r_im(ipm),1 ,n ,1,nvec) 466 m1=m1+n 467 m2=m2+n 468 enddo !end-loop-ipm 469 endif ! end-if-lifetime 470 return 471 end 472 473 subroutine copy_rtor2(g_r2, 474 & g_r, 475 & g_r_im, 476 & ncomp, 477 & nvec, 478 & n, 479 & lifetime) 480c 481c Author: Fredy W. Aquino, Northwestern University 482c Date : 03-15-12 483 484 implicit none 485#include "errquit.fh" 486#include "mafdecls.fh" 487#include "global.fh" 488#include "util.fh" 489#include "rtdb.fh" 490 integer ncomp 491 integer g_r2,g_r(ncomp),g_r_im(ncomp) 492 integer nvec,n,m1,m2,ipm 493 logical lifetime 494 m1=1 495 m2=n 496 do ipm=1,ncomp 497 call ga_copy_patch('n',g_r(ipm),1 ,n ,1,nvec, 498 & g_r2 ,m1,m2,1,nvec) 499 m1=m1+n 500 m2=m2+n 501 enddo !end-loop-ipm 502 if (lifetime) then 503 do ipm=1,ncomp 504 call ga_copy_patch('n',g_r_im(ipm),1 ,n ,1,nvec, 505 & g_r2 ,m1,m2,1,nvec) 506 m1=m1+n 507 m2=m2+n 508 enddo !end-loop-ipm 509 endif ! end-if-lifetime 510 return 511 end 512 513 subroutine copy_AxxtoAyy(g_Ax,g_Ax_im, 514 & g_x,g_x_im, 515 & g_Ay,g_y, 516 & nvec, 517 & ncomp, 518 & nsub, 519 & n, 520 & lifetime) 521c 522c Author: Fredy W. Aquino, Northwestern University 523c Date : 03-15-12 524 525 implicit none 526#include "errquit.fh" 527#include "mafdecls.fh" 528#include "global.fh" 529#include "util.fh" 530#include "rtdb.fh" 531 integer ncomp 532 integer g_Ax(ncomp),g_Ax_im(ncomp), 533 & g_x(ncomp),g_x_im(ncomp), 534 & g_Ay,g_y 535 integer nvec,n,p1,p2,m1,m2,nsub,ipm 536 logical lifetime 537 p1=nsub+1 538 p2=nsub+nvec 539 m1=1 540 m2=n 541 do ipm=1,ncomp 542 call ga_copy_patch('n',g_Ax(ipm),1 ,n ,1 ,nvec, 543 $ g_Ay ,m1,m2,p1,p2) 544 call ga_copy_patch('n',g_x(ipm) ,1 ,n ,1 ,nvec, 545 $ g_y ,m1,m2,p1,p2) 546 m1=m1+n 547 m2=m2+n 548 enddo ! end-loop-ipm 549 if (lifetime) then 550 do ipm=1,ncomp 551 call ga_copy_patch('n',g_Ax_im(ipm),1 ,n ,1 ,nvec, 552 $ g_Ay ,m1,m2,p1,p2) 553 call ga_copy_patch('n',g_x_im(ipm) ,1 ,n ,1 ,nvec, 554 $ g_y ,m1,m2,p1,p2) 555 m1=m1+n 556 m2=m2+n 557 enddo ! end-loop-ipm 558 endif ! end-if-lifetime 559 return 560 end 561 562 subroutine update_g_x1(g_r2, 563 & g_x, 564 & g_x_im, 565 & ncomp, 566 & nvec, 567 & n, 568 & lifetime) 569c 570c Author: Fredy W. Aquino, Northwestern University 571c Date : 03-15-12 572 573 implicit none 574#include "errquit.fh" 575#include "mafdecls.fh" 576#include "global.fh" 577#include "util.fh" 578#include "rtdb.fh" 579 integer ipm,ncomp,nvec,n,m1,m2 580 integer g_x(ncomp),g_x_im(ncomp), 581 & g_r2 582 logical lifetime 583 m1=1 584 m2=n 585 do ipm=1,ncomp 586 call ga_add_patch(1.0d0,g_r2 ,m1,m2,1,nvec, 587 $ 1.0d0,g_x(ipm),1 ,n ,1,nvec, 588 $ g_x(ipm),1 ,n ,1,nvec) 589 m1=m1+n 590 m2=m2+n 591 enddo !end-loop-ipm 592 if (lifetime) then 593 do ipm=1,ncomp 594 call ga_add_patch(1.0d0,g_r2 ,m1,m2,1,nvec, 595 $ 1.0d0,g_x_im(ipm),1 ,n ,1,nvec, 596 $ g_x_im(ipm),1 ,n ,1,nvec) 597 m1=m1+n 598 m2=m2+n 599 enddo !end-loop-ipm 600 endif ! end-if-lifetime 601 return 602 end 603 604 subroutine ga_lkain_2cpl3_damp_cmplx( 605 & rtdb, 606 & g_x, 607 & g_b, 608 & g_x_im, 609 & g_b_im, 610 & product,precond, ! in: routines 611 $ tol, 612 & mmaxsub, 613 & maxiter, 614 & odiff,oprint, 615 & omega, 616 & limag, 617 & lifetime, ! damp means complex, it is redundant 618 & gamwidth, 619 & ncomp) ! ncomp=2 (+/-) 620c 621c Purpose: Getting (g_x,g_x_im) by solving recursively a complex linear equation 622c and reducing more memory cost. 623c --> Modified from ga_lkain_2cpl3() 624c Author : Fredy W. Aquino, Northwestern University 625c Date : 03-15-12 626 627 implicit none 628#include "errquit.fh" 629#include "mafdecls.fh" 630#include "global.fh" 631#include "util.fh" 632#include "stdio.fh" 633#include "rtdb.fh" 634 integer ncomp ! [input] no. of components to treat 635 integer rtdb ! [input] database handle 636 integer g_x(ncomp) ! [input/output] Initial guess/solution Re 637 integer g_x_im(ncomp) ! [input/output] Initial guess/solution Im 638 integer g_b(ncomp) ! [input] Right-hand side vectors Re 639 integer g_b_im(ncomp) ! [input] Right-hand side vectors Im 640 double precision omega ! [input] coupling parameter 641 logical limag ! [input] imaginary perturbation? 642 logical lifetime ! [input] consider damping or not? 643 double precision gamwidth ! [input] damping parameter 644 external product ! [input] product routine 645 external precond ! [input] preconditioner routine 646 double precision tol ! [input] convergence threshold 647 integer mmaxsub ! [input] maximum subspace dimension 648 integer maxiter ! [input] maximum no. of iterations 649 logical odiff ! [input] use differences in product 650 logical oprint ! [input] print flag 651c 652c Solves the linear equations A(X)=0 for multiple vectors. 653c 654c ... jochen: 655c This is a modified version of ga_lkain from file ga_it2.F 656c This version allows to solve a coupled set of equations, i.e. 657c there are two right-hand vectors and two initial guesses and two 658c solutions which are coupled. The coupling is mediated by a 659c parameter omega in the call to the preconditioner 660c (elsewhere, omega is simply called "frequency") 661c 662c ... jochen: the above comment is from ga_lkain_2cpl3. This here is 663c a modified version of that routine and takes care of a real and an 664c imaginary part for each frequency component. I.e. now arrays 665c have four components ... 666c 667c note: when called from cphf_solve3, odiff = .false. on input 668c 669c call product(acc,g_x, g_Ax) 670c . acc is the accuracy trequired for each element of the product 671c . g_x contains the vectors and g_Ax should be filled 672c . with the product vectors. The no. of vectors (columns) in 673c . g_x might differ from the no. of vectors input to ga_lkain(). 674c 675c call precond(g_x,shift) 676c . apply preconditioning directly to the vectors in g_x with the 677c . coupling parameter omega 678c 679c On input g_x should contain an initial guess. It returns the 680c solution. 681c 682c maxsub should be at least 3*nvec and can be beneficially increased 683c to about 10*nvec. 684c 685c Needs to be extended to store the sub-space vectors out-of-core 686c at least while the product() routine is being executed. 687c 688c ... jochen: here in the iteration loops we keep track 689c of two components of the solution vector, ipm = 1 and 2 690c (ipm stands for + (plus) and - (minus) components) 691 integer iter,n,n1, 692 & nvec, nsub, isub, type, maxsub, ipm, 693 & ntmp1, ntmp2 694 695c ... jochen: for convenience, now most arrays have two components. 696c that might be changed later if memory becomes an issue 697 integer g_xold(ncomp), g_Axold(ncomp) 698 integer g_r(ncomp) ,g_r_im(ncomp), 699 & g_Ax(ncomp),g_Ax_im(ncomp) 700 double precision rmax, rmax1, rmax2, acc 701 logical converged 702 logical odebug, debug, converge_precond 703 double complex val_cmplx 704 logical debug1 705 integer p1,p2,m1,m2,stat_solve 706 707 integer g_z(ncomp),g_Az(ncomp),g_zr(ncomp), 708 & g_z1,g_Az1,g_zr1 709 double precision omg(2) 710 external conv2complex, 711 & updating_Az1_z1_zr1, 712 & solve_zlineq, 713 & solve_zlineq_sep, 714 & get_precond_rmax, 715 & conv2reim 716 717c later we combine the two components to vecors of double 718c length and combine again Re and Im, i.e. 719c the dimension is up to 4*n 720 721 call ga_inquire(g_x(1), type, n, nvec) ! get (n,nvec) 722 723 if (ga_nodeid().eq.0) then 724 write(*,14) n,ncomp,maxiter,mmaxsub,lifetime 725 14 format('(n,ncomp,maxiter,mmaxsub,lifetime)=(', 726 & i3,',',i3,',',i5,',',i5,',',L1,')') 727 endif 728 n1=ncomp*n 729 730 maxsub = mmaxsub ! So don't modify input scalar arg 731 if (maxsub .lt. 3*nvec) maxsub = 3*nvec 732 maxsub = (maxsub/nvec)*nvec 733 734 if (ga_nodeid().eq.0) then 735 write(*,1023) n1,mmaxsub,maxsub,n 736 1023 format('(n1,mmaxsub,maxsub,n)=(', 737 & i15,',',i5,',',i5,',',i15,')') 738 endif 739 740 debug1 = .false. ! no printouts 741c debug1 = .true. ! allow debugging printouts 742c 743c ================================================================= 744 745 debug = (.false. .and. ga_nodeid().eq.0) ! for code development 746 747c check input key if we should check for convergence 748c after the preconditioner has been applied to the residual 749 if (.not. rtdb_get(rtdb, 'aoresponse:precond', mt_log, 1, 750 & converge_precond)) 751 & converge_precond = .false. 752 753 if (debug) write (6,*) 'ga_lkain_2cpl_damp omega =',omega 754 if (debug) write (6,*) 'ga_lkain_2cpl_damp limag =',limag 755 if (debug) write (6,*) 'ga_lkain_2cpl_damp lifetime =',lifetime 756 if (debug) write (6,*) 'ga_lkain_2cpl_damp gamwidth =',gamwidth 757 if (debug) write (6,*) 'ga_lkain_2cpl_damp ncomp =', ncomp 758 if (debug) write (6,*) 'ga_lkain_2cpl3 converge_precond', 759 & converge_precond 760c 761c exit if this is the wrong routine to call (lifetime switch 762c must be set) 763 if (.not.lifetime) call errquit 764 & ('ga_lkain_2cpl_damp but lifetime=.F.',0,UNKNOWN_ERR) 765 766c make sure odiff is false (never tested for odiff = .true.) 767 if (odiff) call errquit 768 & ('ga_lkain_2cpl_damp odiff=.T.',0,UNKNOWN_ERR) 769c 770 odebug = util_print('debug lsolve', print_never) .and. 771 $ ga_nodeid().eq.0 772c 773 if (.not. rtdb_get(rtdb, 'cphf:acc', mt_dbl, 1, 774 & acc)) acc = 0.01d0*tol 775c ------- create (zre,zim) ---------- START 776 do ipm=1,ncomp 777 if (.not. ga_create(MT_DCPL,n,nvec, 'lkain_2cpl: z', 778 $ 0, 0, g_z(ipm))) 779 $ call errquit('lkain: failed allocating z', nvec, 780 & GA_ERR) 781 call ga_zero(g_z(ipm)) 782 if (.not. ga_create(MT_DCPL,n,nvec, 'lkain_2cpl: Az', 783 $ 0, 0, g_Az(ipm))) 784 $ call errquit('lkain: failed allocating Az', nvec, 785 & GA_ERR) 786 call ga_zero(g_Az(ipm)) 787 if (.not. ga_create(MT_DCPL,n,nvec, 'lkain_2cpl: zr', 788 $ 0, 0, g_zr(ipm))) 789 $ call errquit('lkain: failed allocating zr', nvec, 790 & GA_ERR) 791 call ga_zero(g_zr(ipm)) 792 enddo ! end-loop-ipm 793 if (debug1) then 794 do ipm=1,ncomp 795 if (ga_nodeid().eq.0) 796 & write(*,*) '--------g_b-re(',ipm,') -------- START' 797 call ga_print(g_b(ipm)) 798 if (ga_nodeid().eq.0) 799 & write(*,*) '--------g_b-re(',ipm,') -------- END' 800 enddo ! end-loop-ipm 801 do ipm=1,ncomp 802 if (ga_nodeid().eq.0) 803 & write(*,*) '--------g_b-im(',ipm,') -------- START' 804 call ga_print(g_b_im(ipm)) 805 if (ga_nodeid().eq.0) 806 & write(*,*) '--------g_b-im(',ipm,') -------- END' 807 enddo ! end-loop-ipm 808 endif ! end-if-debug1 809 810 if (.not. ga_create(MT_DCPL,n1,maxsub, 'lkain_2cpl: z1', 811 $ 0, 0, g_z1)) 812 $ call errquit('lkain: failed alloc subspace-z1',maxsub, 813 & GA_ERR) 814 if (.not. ga_create(MT_DCPL,n1,maxsub, 'lkain_2cpl: Az1', 815 $ 0, 0, g_Az1)) 816 $ call errquit('lkain: failed alloc subspace Az1',maxsub, 817 & GA_ERR) 818 if (.not. ga_create(MT_DCPL,n1,nvec, 'lkain_2cpl: zr2', 819 $ 0, 0, g_zr1)) 820 $ call errquit('lkain_2cpl: failed allocating zr1', nvec, 821 & GA_ERR) 822 call ga_zero(g_z1) 823 call ga_zero(g_Az1) 824 call ga_zero(g_zr1) 825c ------- create (zre,zim) ---------- END 826 if (ncomp.gt.1) then 827 call ga_inquire(g_x(2), type, ntmp1, ntmp2) 828c ... jochen: do a sanity check on the array dimensions 829 if (ntmp1.ne.n .or. ntmp2.ne.nvec) call errquit 830 & ('ga_lkain_2cpl:inconsistent dimensions of g_x components', 831 & nvec,CALC_ERR) 832 endif 833 834 if (oprint .and. ga_nodeid().eq.0) then 835 write(6,1) n1, nvec, maxsub, tol, util_wallsec() 836 1 format(//,'Iterative solution of linear equations',/, 837 $ ' No. of variables', i9,/, 838 $ ' No. of equations', i9,/, 839 $ ' Maximum subspace', i9,/, 840 $ ' Convergence', 1p,d9.1,/, 841 $ ' Start time', 0p,f9.1,/) 842 call util_flush(6) 843 end if 844c 845 do ipm = 1,ncomp 846 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: Ax', 847 $ 0, 0, g_Ax(ipm))) 848 $ call errquit('lkain: failed allocating Ax', nvec, 849 & GA_ERR) 850 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: r', 851 $ 0, 0, g_r(ipm))) 852 $ call errquit('lkain_2cpl: failed allocating r', nvec, 853 & GA_ERR) 854 if (lifetime) then 855 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: Ax_im', 856 $ 0, 0, g_Ax_im(ipm))) 857 $ call errquit('lkain: failed allocating Ax_im', nvec, 858 & GA_ERR) 859 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: r_im', 860 $ 0, 0, g_r_im(ipm))) 861 $ call errquit('lkain_2cpl: failed allocating r_im', nvec, 862 & GA_ERR) 863 endif ! lifetime 864 865 if (odiff) then 866c jochen: this part and all subsequent "odiff" parts were 867c never adapted for the imaginary components 868 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: xold', 869 $ 0, 0, g_xold(ipm))) 870 $ call errquit('lkain: failed allocating xold', nvec, 871 & GA_ERR) 872 if (.not. ga_create(MT_DBL, n, nvec, 'lkain_2cpl: xold', 873 $ 0, 0, g_Axold(ipm))) 874 $ call errquit('lkain: failed allocating Axold', nvec, 875 & GA_ERR) 876 call ga_zero(g_xold(ipm)) 877 call ga_zero(g_Axold(ipm)) 878 end if ! odiff 879 880 call ga_zero(g_Ax(ipm)) 881 call ga_zero(g_r(ipm)) 882 if (lifetime) then 883 call ga_zero(g_Ax_im(ipm)) 884 call ga_zero(g_r_im(ipm)) 885 endif 886c 887 enddo ! ipm = 1,ncomp 888 889 if (oprint .and. ga_nodeid().eq.0) then 890 write(6,2) 891 call util_flush(6) 892 2 format(/ 893 $ ' iter nsub residual time ',/, 894 $ ' ---- ------ -------- --------- ') 895 end if 896c 897 nsub = 0 898 converged = .false. 899c 900c --------------------- 901c start interation loop 902c --------------------- 903c 904 do iter = 1, maxiter 905 if (odiff) then 906 do ipm = 1,ncomp 907 call ga_add( 1.0d0,g_x(ipm), 908 & -1.0d0,g_xold(ipm), 909 & g_x(ipm)) 910 call ga_sync() 911 enddo 912 endif 913c 914c ... jochen: call product routine with initial or intermediate 915c solution vector: g_x and g_Ax MUST have dimension two here 916c even if only one of them is used 917 if (debug) then 918 do ipm=1,ncomp 919 if (ga_nodeid().eq.0) then 920 write(*,112) iter,ipm 921 112 format('------ prod-g_x-1(',i3,',',i3,')------ START') 922 endif 923 call ga_print(g_x(ipm)) 924 if (ga_nodeid().eq.0) then 925 write(*,113) iter,ipm 926 113 format('------ prod-g_x-1(',i3,',',i3,')------ END') 927 endif 928 enddo ! end-loop-ipm 929 endif ! end-if-debug 930 931 if (debug) write (6,*) 932 & 'calling product from ga_lkain_2cpl_damp' 933 call product(acc, 934 & g_x, ! in : x 935 & g_Ax, ! out : product A x 936 & g_x_im, ! in : x_im 937 & g_Ax_im, ! out : product A x_im 938 & omega, ! in : 939 & limag, ! in : 940 & lifetime, ! in : =.true. -> x is complex 941 & gamwidth, ! in : 942 & ncomp) ! in : nr. components 943 if (debug) then 944 do ipm=1,ncomp 945 if (ga_nodeid().eq.0) then 946 write(*,116) iter,ipm 947 116 format('------ prod-g_x-2(',i3,',',i3,')------ START') 948 endif 949 call ga_print(g_x(ipm)) 950 if (ga_nodeid().eq.0) then 951 write(*,117) iter,ipm 952 117 format('------ prod-g_x-2(',i3,',',i3,')------ END') 953 endif 954 if (ga_nodeid().eq.0) then 955 write(*,118) iter,ipm 956 118 format('------ prod-g_Ax-2(',i3,',',i3,')------ START') 957 endif 958 call ga_print(g_Ax(ipm)) 959 if (ga_nodeid().eq.0) then 960 write(*,119) iter,ipm 961 119 format('------ prod-g_Ax-2(',i3,',',i3,')------ END') 962 endif 963 enddo ! end-loop-ipm 964 endif ! end-if-debug 965 966 if (debug) write (6,*) 967 & 'returning product from ga_lkain_2cpl_damp' 968 969 do ipm = 1,ncomp 970 971 if (odiff) then 972c jochen: odiff stuff presently ignored 973 call ga_add(1.0d0,g_Ax(ipm), 974 & 1.0d0,g_Axold(ipm), 975 & g_Ax(ipm)) 976 call ga_add(1.0d0,g_x(ipm), 977 & 1.0d0,g_xold(ipm), 978 & g_x(ipm)) 979 call ga_copy(g_x(ipm), g_xold(ipm)) 980 call ga_copy(g_Ax(ipm), g_Axold(ipm)) 981 end if ! odiff 982 983 call ga_zero(g_r(ipm)) 984 if (lifetime) call ga_zero(g_r_im(ipm)) 985 986c g_r will be the quantity -Ax + b, i.e. if the equation system 987c Ax = b is solved then this vector will be zero 988c 989c During the first cycle, 990c g_Ax is calculated from the initial guess for which the 991c preconditioner has already been applied (to be more clear: 992c we have divided the perturbation matrix elements by orbital 993c energy denominators, including the frequency term, 994c and assigned real and imaginary parts accordingly) 995 call ga_add( 1.0d0,g_b(ipm), 996 & -1.0d0,g_Ax(ipm), 997 & g_r(ipm)) ! The residual, Real part 998 call ga_add( 1.0d0,g_b_im(ipm), 999 & -1.0d0,g_Ax_im(ipm), 1000 & g_r_im(ipm)) ! The residual, Im part 1001 1002 if (debug) then 1003 if (ga_nodeid().eq.0) then 1004 write(*,120) iter,ipm 1005 120 format('------ prod-g_b(',i3,',',i3,')------ START') 1006 endif 1007 call ga_print(g_b(ipm)) 1008 if (ga_nodeid().eq.0) then 1009 write(*,121) iter,ipm 1010 121 format('------ prod-g_b(',i3,',',i3,')------ END') 1011 endif 1012 if (ga_nodeid().eq.0) then 1013 write(*,122) iter,ipm 1014 122 format('------ prod-g_r(',i3,',',i3,')------ START') 1015 endif 1016 call ga_print(g_r(ipm)) 1017 if (ga_nodeid().eq.0) then 1018 write(*,123) iter,ipm 1019 123 format('------ prod-g_r(',i3,',',i3,')------ END') 1020 endif 1021 endif ! end-if-debug 1022 enddo ! ipm = 1,ncomp 1023 1024c if (ga_nodeid().eq.0) 1025c & write(*,*) 'FA BEF get_precond_rmax' 1026 1027 call get_precond_rmax( 1028 & rmax, ! out: max(g_r,g_r_im) 1029 & g_r, ! in : real part of g_zr 1030 & g_r_im, ! in : imag part of g_zr 1031 & g_Ax, ! in : real part of g_Az 1032 & g_Ax_im, ! in : imag part of g_Az 1033 & precond, ! in : name of preconditioner routine 1034 & converge_precond, ! in : =.true. prec->max 1035 & omega, ! in : omega 1036 & gamwidth,! in : gamwidth 1037 & ncomp, ! in : nr. components 1038 & iter, ! in : nr. iteration 1039 & debug1) ! in : =.true. -> allow debug printouts 1040 1041c if (ga_nodeid().eq.0) 1042c & write(*,*) 'FA AFT get_precond_rmax' 1043 1044c -------- printout per iteration -------------- START 1045 if (oprint .and. ga_nodeid().eq.0) then 1046 write(6,3) iter, nsub+nvec, rmax, util_wallsec() 1047 call util_flush(6) 1048 3 format(' ', i5, i7, 3x,1p,d9.2,0p,f10.1,5x,i3) 1049 end if 1050c -------- printout per iteration -------------- END 1051c if (ga_nodeid().eq.0) then 1052c write(*,10) iter,nsub+nvec,rmax 1053c 10 format('(iter,nsub+nvec,rmax)=(',i5,',',i7,',',f15.8,')') 1054c endif 1055c stop iterations if residual is smaller than criterion 1056 if (rmax .lt. tol) then 1057 converged = .true. 1058 goto 100 1059 end if 1060 1061c ======== get complex: g_z,g_Az,g_zr ====== START 1062c Do: (x,x_im) -> z 1063c (x,x_im) -> (k_zre,k_zim) -> z 1064 call conv2complex(g_z, ! out: = complx(g_x,g_x_im) 1065 & g_x, ! in : real arr 1066 & g_x_im, ! in : imaginary arr 1067 & n, ! in : n rows 1068 & nvec, ! in : nvec columns 1069 & ncomp) ! in : nr. components 1070 call conv2complex(g_Az, ! out: = complx(g_Ax,g_Ax_im) 1071 & g_Ax, ! in : real arr 1072 & g_Ax_im,! in : imaginary arr 1073 & n, ! in : n rows 1074 & nvec, ! in : nvec columns 1075 & ncomp) ! in : nr. components 1076 call conv2complex(g_zr, ! out: = complx(g_Ax,g_Ax_im) 1077 & g_r, ! in : real arr 1078 & g_r_im, ! in : imaginary arr 1079 & n, ! in : n rows 1080 & nvec, ! in : nvec columns 1081 & ncomp) ! in : nr. components 1082c ======== get complex: g_z,g_Az,g_zr ====== END 1083 1084 if (debug1) then 1085 do ipm=1,ncomp 1086 if (ga_nodeid().eq.0) then 1087 write(*,3001) ipm,iter 1088 3001 format('---------g_z-0(',i3,',',i3,')-----START') 1089 endif 1090 call ga_print(g_z(ipm)) 1091 if (ga_nodeid().eq.0) then 1092 write(*,3002) ipm,iter 1093 3002 format('---------g_z-0(',i3,',',i3,')-----END') 1094 endif 1095 if (ga_nodeid().eq.0) then 1096 write(*,3003) ipm,iter 1097 3003 format('---------g_Az-0(',i3,',',i3,')-----START') 1098 endif 1099 call ga_print(g_Az(ipm)) 1100 if (ga_nodeid().eq.0) then 1101 write(*,3004) ipm,iter 1102 3004 format('---------g_Az-0(',i3,',',i3,')-----END') 1103 endif 1104 if (ga_nodeid().eq.0) then 1105 write(*,2800) ipm,iter 1106 2800 format('---------g_zr-0(',i3,',',i3,')-----START') 1107 endif 1108 call ga_print(g_zr(ipm)) 1109 if (ga_nodeid().eq.0) then 1110 write(*,2801) ipm,iter 1111 2801 format('---------g_zr-0(',i3,',',i3,')-----END') 1112 endif 1113 enddo ! end-loop-ipm 1114 endif ! end-if-debug1 1115 call updating_Az1_z1_zr1( 1116 & g_Az1, ! in/ou: 1117 & g_z1, ! in/ou: 1118 & g_zr1, ! in/ou: 1119 & g_Az, ! in : 1120 & g_z, ! in : 1121 & g_zr, ! in : 1122 & nvec, ! in : 1123 & ncomp, ! in : 1124 & nsub, ! in : 1125 & n) ! in : 1126 if (debug1) then 1127 if (ga_nodeid().eq.0) then 1128 write(*,2700) iter 1129 2700 format('---------g_z1-0(',i3,')-----START') 1130 endif 1131 call ga_print(g_z1) 1132 if (ga_nodeid().eq.0) then 1133 write(*,2701) iter 1134 2701 format('---------g_z1-0(',i3,')-----END') 1135 endif 1136 if (ga_nodeid().eq.0) then 1137 write(*,2702) iter 1138 2702 format('---------g_Az1-0(',i3,')-----START') 1139 endif 1140 call ga_print(g_Az1) 1141 if (ga_nodeid().eq.0) then 1142 write(*,2703) iter 1143 2703 format('---------g_Az1-0(',i3,')-----END') 1144 endif 1145 if (ga_nodeid().eq.0) then 1146 write(*,2704) iter 1147 2704 format('---------g_zr1-0(',i3,')-----START') 1148 endif 1149 call ga_print(g_zr1) 1150 if (ga_nodeid().eq.0) then 1151 write(*,2705) iter 1152 2705 format('---------g_zr1-0(',i3,')-----END') 1153 endif 1154 endif ! end-if-debug1 1155 1156 nsub = nsub + nvec 1157c ============ doing complex-linear solving ======= START 1158c if (ga_nodeid().eq.0) 1159c & write(*,*) 'BEFORE solve_zlineq ...' 1160 call solve_zlineq( 1161 & g_z, ! in/out: updated solution 1162 & g_Az1, ! in : history of g_Az 1163 & g_z1, ! in : history of g_z 1164 & g_zr1, ! in : history of g_zr 1165 & nsub, ! in : subspace length 1166 & nvec, ! in : increment of subspace 1167 & ncomp, ! in : nr. components 1168 & n, ! in : nr. elements per comp. 1169 & iter, ! in : iteration nr. 1170 & debug1)! in : =.true. show debug printouts 1171c if (ga_nodeid().eq.0) 1172c & write(*,*) 'AFTER solve_zlineq ...' 1173c ============ doing complex-linear solving ======= END 1174c ======= g_z --> (g_x,g_x_im) ========= START 1175c if (ga_nodeid().eq.0) 1176c & write(*,*) 'BEF conv2reim-x' 1177 call conv2reim(g_x, ! out : real arr 1178 & g_x_im,! out : imaginary arr 1179 & g_z, ! in : = complx(g_xre,g_xim) 1180 & n, ! in : n rows 1181 & nvec, ! in : nvec columns 1182 & ncomp) ! in : nr. components 1183c if (ga_nodeid().eq.0) 1184c & write(*,*) 'AFT conv2reim-x' 1185c ======= g_z --> (g_x,g_x_im) ========= END 1186 if (debug1) then 1187 do ipm=1,ncomp 1188 if (ga_nodeid().eq.0) then 1189 write(*,4000) ipm,iter 1190 4000 format('---------g_xre-AFT-0(',i3,',',i3,')-----START') 1191 endif 1192 call ga_print(g_x(ipm)) 1193 if (ga_nodeid().eq.0) then 1194 write(*,4001) ipm,iter 1195 4001 format('---------g_xre-AFT-0(',i3,',',i3,')-----END') 1196 endif 1197 if (ga_nodeid().eq.0) then 1198 write(*,4002) ipm,iter 1199 4002 format('---------g_xim-AFT-0(',i3,',',i3,')-----START') 1200 endif 1201 call ga_print(g_x_im(ipm)) 1202 if (ga_nodeid().eq.0) then 1203 write(*,4003) ipm,iter 1204 4003 format('---------g_xim-AFT-0(',i3,',',i3,')-----END') 1205 endif 1206 enddo ! end-loop-ipm 1207 endif ! end-if-debug1 1208 1209c if (iter.eq.2) then 1210c if (ga_nodeid().eq.0) 1211c & write(*,*) 'FA-check-zlinear-solver' 1212c stop 1213c endif 1214 1215 if (nsub .eq. maxsub) then 1216c 1217c Reduce the subspace as necessary 1218c 1219c ====== FA: left-shifting patch ==== START 1220c Note.- matrices Ay,y shift to left nvec positions 1221c removing leftmost patch of dimension: n4 x nvec 1222 if (ga_nodeid().eq.0) 1223 & write(*,*) 'FA-matrix-nvec-left-shifting:' 1224 do isub = nvec+1, maxsub, nvec 1225 call ga_copy_patch('n',g_Az1,1,n1,isub,isub+nvec-1, 1226 $ g_Az1,1,n1,isub-nvec,isub-1) 1227 call ga_copy_patch('n',g_z1 ,1,n1,isub,isub+nvec-1, 1228 $ g_z1 ,1,n1,isub-nvec,isub-1) 1229 enddo ! end-loop-isub 1230c ====== FA: left-shifting patch ==== END 1231 nsub = nsub - nvec 1232 end if ! (nsub .eq. maxsub) 1233 enddo ! iter = 1,maxiter 1234 100 continue ! jump here if converged 1235c deallocate workspace: 1236c 1237 do ipm = 1,ncomp 1238 if (odiff) then 1239 if (.not. ga_destroy(g_xold(ipm))) call errquit 1240 & ('lkain_2cpl: destroy',1, GA_ERR) 1241 if (.not. ga_destroy(g_Axold(ipm))) call errquit 1242 & ('lkain_2cpl: destroy',2,GA_ERR) 1243 end if 1244 if (.not. ga_destroy(g_Ax(ipm))) call errquit 1245 & ('lkain_2cpl: destroy',20, GA_ERR) 1246 if (.not. ga_destroy(g_r(ipm))) call errquit 1247 & ('lkain_2cpl: destroy',5, GA_ERR) 1248 if (lifetime) then 1249 if (.not. ga_destroy(g_Ax_im(ipm))) call errquit 1250 & ('lkain_2cpl: destroy',201, GA_ERR) 1251 if (.not. ga_destroy(g_r_im(ipm))) call errquit 1252 & ('lkain_2cpl: destroy',51, GA_ERR) 1253 endif 1254 enddo ! ipm = 1,2 1255 1256 do ipm=1,ncomp 1257 if (.not. ga_destroy(g_Az(ipm))) call errquit 1258 & ('lkain_2cpl3-cmplx: destroy Az',3, GA_ERR) 1259 if (.not. ga_destroy(g_z(ipm))) call errquit 1260 & ('lkain_2cpl3-cmplx: destroy z',3, GA_ERR) 1261 if (.not. ga_destroy(g_zr(ipm))) call errquit 1262 & ('lkain_2cpl3-cmplx: destroy zr',3, GA_ERR) 1263 enddo ! end-loop-ipm 1264 if (.not. ga_destroy(g_Az1)) call errquit 1265 & ('lkain_2cpl3-cmplx: destroy Az1',3, GA_ERR) 1266 if (.not. ga_destroy(g_z1)) call errquit 1267 & ('lkain_2cpl3-cmplx: destroy z1',4, GA_ERR) 1268 if (.not. ga_destroy(g_zr1)) call errquit 1269 & ('lkain_2cpl3-cmplx: destroy zr1',6, GA_ERR) 1270 1271 if (.not. converged) then 1272 if (ga_nodeid().eq.0) then 1273 write (luout,*) 'WARNING: CPKS procedure is NOT converged' 1274 write (luout,*) ' I will proceed, but check your results!' 1275 endif 1276 endif 1277c 1278 end 1279 1280c ======================================================== 1281c ========= Reduce memory consumption ============== START 1282 subroutine ga_lkain_2cpl3_damp_cmplx_redmem( 1283 & rtdb, 1284 & g_z, ! in/out: solution 1285 & g_zb,! in : b (of Ax=b) 1286 & product, ! in: routine to compute Az 1287 & precond, ! in: routine to do energy scaling Az,r 1288 $ tol, 1289 & mmaxsub, 1290 & maxiter, 1291 & odiff,oprint, 1292 & omega, 1293 & limag, 1294 & lifetime, ! damp means complex, it is redundant 1295 & gamwidth, 1296 & ncomp, ! ncomp=2 (+/-) 1297 & npol, 1298 & nvir, 1299 & nocc) 1300c 1301c Author : Fredy W. Aquino, Northwestern University 1302c Purpose: Getting g_z by solving recursively a complex linear equation 1303c and reducing memory cost. 1304c --> Modified from ga_lkain_2cpl3() 1305c Date : 03-15-12 1306 1307 implicit none 1308#include "errquit.fh" 1309#include "tcgmsg.fh" 1310#include "msgtypesf.h" 1311#include "mafdecls.fh" 1312#include "msgids.fh" 1313#include "global.fh" 1314#include "util.fh" 1315#include "stdio.fh" 1316#include "inp.fh" 1317#include "rtdb.fh" 1318 integer ncomp ! [input] no. of components to treat 1319 integer g_z(ncomp) ! [input/output] Initial guess/solution (Re,Im) 1320 integer g_zb(ncomp),! [input] b of Ax=b 1321 & g_z1, ! Scratch GA contains history of z in (n1,mmaxsub) 1322 & g_Az1, ! Scratch GA contains history of Az in (n1,mmaxsub) 1323 & g_zr1 ! Scratch GA (r= b-Ax) error of size (n1,nvec) 1324 integer g_zb1 1325 integer npol, 1326 & nvir(npol),nocc(npol) 1327c Note.- In g_z1,g_Az1 a (n1,nvec) block is added per iteration. 1328 integer rtdb ! [input] database handle 1329 double precision omega ! [input] coupling parameter 1330 logical limag ! [input] imaginary perturbation? 1331 logical lifetime ! [input] consider damping or not? 1332 double precision gamwidth ! [input] damping parameter 1333 external product ! [input] product routine 1334 external precond ! [input] preconditioner routine 1335 double precision tol ! [input] convergence threshold 1336 integer mmaxsub ! [input] maximum subspace dimension 1337 integer maxiter ! [input] maximum no. of iterations 1338 logical odiff ! [input] use differences in product 1339 logical oprint ! [input] print flag 1340c 1341c Solves the linear equations A(X)=0 for multiple vectors. 1342c 1343c ... jochen: 1344c This is a modified version of ga_lkain from file ga_it2.F 1345c This version allows to solve a coupled set of equations, i.e. 1346c there are two right-hand vectors and two initial guesses and two 1347c solutions which are coupled. The coupling is mediated by a 1348c parameter omega in the call to the preconditioner 1349c (elsewhere, omega is simply called "frequency") 1350c 1351c ... jochen: the above comment is from ga_lkain_2cpl3. This here is 1352c a modified version of that routine and takes care of a real and an 1353c imaginary part for each frequency component. I.e. now arrays 1354c have four components ... 1355c 1356c note: when called from cphf_solve3, odiff = .false. on input 1357c 1358c call product(acc,g_x, g_Ax) 1359c . acc is the accuracy trequired for each element of the product 1360c . g_x contains the vectors and g_Ax should be filled 1361c . with the product vectors. The no. of vectors (columns) in 1362c . g_x might differ from the no. of vectors input to ga_lkain(). 1363c 1364c call precond(g_x,shift) 1365c . apply preconditioning directly to the vectors in g_x with the 1366c . coupling parameter omega 1367c 1368c On input g_x should contain an initial guess. It returns the 1369c solution. 1370c 1371c maxsub should be at least 3*nvec and can be beneficially increased 1372c to about 10*nvec. 1373c 1374c Needs to be extended to store the sub-space vectors out-of-core 1375c at least while the product() routine is being executed. 1376c 1377c ... jochen: here in the iteration loops we keep track 1378c of two components of the solution vector, ipm = 1 and 2 1379c (ipm stands for + (plus) and - (minus) components) 1380 integer iter,n,n1, 1381 & nvec, nsub, isub, 1382 & type, maxsub, ipm, 1383 & nsub_file 1384 1385c ... jochen: for convenience, now most arrays have two components. 1386c that might be changed later if memory becomes an issue 1387 double precision rmax, acc 1388 logical converged, odebug, debug, 1389 & converge_precond, debug1 1390 double complex val_cmplx 1391 integer p1,p2,m1,m2,dim1,dim2,nblock 1392 double complex one_cmplx,mone_cmplx,zero_cmplx 1393 logical dft_CPHF2_read, 1394 & dft_CPHF2_write, 1395 & dft_CPHF2_read2fix 1396 real ran1 1397 integer status_gasvd,idum 1398 double precision factor_x 1399 external solve_zlineq1, 1400 & get_precond_rmax_zin, 1401 & dft_CPHF2_read, 1402 & dft_CPHF2_write 1403 external copy_complx2real_4redmem, 1404 & solve_xlineq_4redmem, 1405 & solve_zlineq_KAIN1, 1406 & solve_zlineq_KAIN3 1407 integer g_Ax1,g_x1,g_xr1,slcKAIN 1408 1409 logical status,flag2readfile 1410 integer index4cphf,checkorth,cphf3write 1411 character*255 aorespfilename 1412 character*(*) lbl_cphfaoresp 1413 character*255 lbl_cphfaoresp1 1414 integer iimoderaman,iiistepraman 1415 logical ramanspc 1416 parameter(lbl_cphfaoresp='aoresp_fiao_f') 1417 1418 slcKAIN=2 ! Choose KAIN linear solver (1,2,3) 1419 1420 one_cmplx =dcmplx( 1.0d0,0.0d0) 1421 mone_cmplx=dcmplx(-1.0d0,0.0d0) 1422 zero_cmplx=dcmplx( 0.0d0,0.0d0) 1423 if (.not. rtdb_get(rtdb, 'cphf:cphf3write', mt_int, 1, 1424 & cphf3write)) 1425 & cphf3write = 0 ! assigns 0 if unsuccessfull read from rtdb 1426 if (.not. rtdb_get(rtdb, 'cphf:checkorth', mt_int, 1, 1427 & checkorth)) 1428 & checkorth = 0 ! assigns 0 if unsuccessfull read from rtdb 1429 call ga_inquire(g_z(1),type,n,nvec) ! get (n,nvec) n=sum(nocc*nvirt(i) i=1,npol) 1430 n1=ncomp*n 1431 maxsub = mmaxsub ! So don't modify input scalar arg 1432 if (maxsub .lt. 3*nvec) maxsub = 3*nvec 1433 maxsub = (maxsub/nvec)*nvec 1434 debug1 = .false. ! no printouts 1435c 1436c ================================================================= 1437 1438 debug = (.false. .and. ga_nodeid().eq.0) ! for code development 1439 1440c check input key if we should check for convergence 1441c after the preconditioner has been applied to the residual 1442 if (.not. rtdb_get(rtdb, 'aoresponse:precond', mt_log, 1, 1443 & converge_precond)) 1444 & converge_precond = .false. 1445 1446 if (debug) write (6,*) 'ga_lkain_2cpl_damp omega =',omega 1447 if (debug) write (6,*) 'ga_lkain_2cpl_damp limag =',limag 1448 if (debug) write (6,*) 'ga_lkain_2cpl_damp lifetime =',lifetime 1449 if (debug) write (6,*) 'ga_lkain_2cpl_damp gamwidth =',gamwidth 1450 if (debug) write (6,*) 'ga_lkain_2cpl_damp ncomp =', ncomp 1451 if (debug) write (6,*) 'ga_lkain_2cpl3 converge_precond', 1452 & converge_precond 1453c 1454c exit if this is the wrong routine to call (lifetime switch 1455c must be set) 1456 if (.not.lifetime) call errquit 1457 & ('ga_lkain_2cpl_damp but lifetime=.F.',0,UNKNOWN_ERR) 1458 1459c make sure odiff is false (never tested for odiff = .true.) 1460 if (odiff) call errquit 1461 & ('ga_lkain_2cpl_damp odiff=.T.',0,UNKNOWN_ERR) 1462c 1463 odebug = util_print('debug lsolve', print_never) .and. 1464 $ ga_nodeid().eq.0 1465c 1466 if (.not. rtdb_get(rtdb, 'cphf:acc', mt_dbl, 1, 1467 & acc)) acc = 0.0001d0*tol 1468c ------- create (zre,zim) ---------- START 1469 1470c ++++++ added for solve_zlineq_KAIN1 +++ START 1471 if (slcKAIN.eq.2) then 1472 if (.not. ga_create(MT_DBL,2*n1,maxsub, 'lkain_dbl: x1', 1473 $ 0, 0, g_x1)) 1474 $ call errquit('lkain: failed alloc subspace-x1',maxsub, 1475 & GA_ERR) 1476 if (.not. ga_create(MT_DBL,2*n1,maxsub, 'lkain_dbl: Ax1', 1477 $ 0, 0, g_Ax1)) 1478 $ call errquit('lkain: failed alloc subspace Az1',maxsub, 1479 & GA_ERR) 1480 if (.not. ga_create(MT_DBL,2*n1,nvec, 'lkain_dbl: xr1', 1481 $ 0, 0, g_xr1)) 1482 $ call errquit('lkain_2cpl: failed allocating zr1', nvec, 1483 & GA_ERR) 1484 endif 1485c ++++++ added for solve_zlineq_KAIN1 +++ END 1486 1487 if (.not. ga_create(MT_DCPL,n1,maxsub, 'lkain_2cpl: z1', 1488 $ 0, 0, g_z1)) 1489 $ call errquit('lkain: failed alloc subspace-z1',maxsub, 1490 & GA_ERR) 1491 if (.not. ga_create(MT_DCPL,n1,maxsub, 'lkain_2cpl: Az1', 1492 $ 0, 0, g_Az1)) 1493 $ call errquit('lkain: failed alloc subspace Az1',maxsub, 1494 & GA_ERR) 1495 if (.not. ga_create(MT_DCPL,n1,nvec, 'lkain_2cpl: zr2', 1496 $ 0, 0, g_zr1)) 1497 $ call errquit('lkain_2cpl: failed allocating zr1', nvec, 1498 & GA_ERR) 1499 if (.not. ga_create(MT_DCPL,n1,nvec, 'lkain_2cpl: zr2', 1500 $ 0, 0, g_zb1)) 1501 $ call errquit('lkain_2cpl: failed allocating zb1', nvec, 1502 & GA_ERR) 1503 call ga_zero(g_zb1) 1504 m1=1 1505 m2=n 1506 do ipm=1,ncomp 1507 call ga_copy_patch('n',g_zb(ipm),1 ,n ,1,nvec, 1508 & g_zb1 ,m1,m2,1,nvec) 1509 m1=m1+n 1510 m2=m2+n 1511 enddo ! end-loop-ipm 1512 call ga_zero(g_z1) 1513 call ga_zero(g_Az1) 1514 call ga_zero(g_zr1) 1515 call ga_sync() 1516c ------- create (zre,zim) ---------- END 1517 1518 if (oprint .and. ga_nodeid().eq.0) then 1519 write(6,1) n1, nvec, maxsub, tol, util_wallsec() 1520 1 format(//,'Iterative solution of linear equations',/, 1521 $ ' No. of variables', i9,/, 1522 $ ' No. of equations', i9,/, 1523 $ ' Maximum subspace', i9,/, 1524 $ ' Convergence', 1p,d9.1,/, 1525 $ ' Start time', 0p,f9.1,/) 1526 call util_flush(6) 1527 end if 1528 1529 if (oprint .and. ga_nodeid().eq.0) then 1530 write(6,2) 1531 call util_flush(6) 1532 2 format(/ 1533 $ ' iter nsub residual time ',/, 1534 $ ' ---- ------ -------- --------- ') 1535 end if 1536c 1537 nsub = 0 1538 converged = .false. 1539c 1540c --------------------- 1541c start interation loop 1542c --------------------- 1543c 1544c 000000000000000 getting cphf filename to store 00000000 START 1545 if (.not. rtdb_get(rtdb,'cphf3-aores:guess1', 1546 & mt_int,1,index4cphf)) index4cphf = 0 1547 1548 ramanspc=.false. 1549 status=rtdb_get(rtdb,'raman:aores0',mt_log,1,ramanspc) 1550 if (ramanspc) then 1551 if (.not. rtdb_get(rtdb,'raman:aores1', 1552 & mt_int, 1,iimoderaman)) call 1553 $ errquit('ga_lkain_2cpl3_redmem1: failed to read iimoderaman', 1554 & 0, RTDB_ERR) 1555 if (.not. rtdb_get(rtdb,'raman:aores2', 1556 & mt_int, 1,iiistepraman)) call 1557 $ errquit('ga_lkain_2cpl3_redmem1: failed to read iiistepraman', 1558 & 0, RTDB_ERR) 1559 write(lbl_cphfaoresp1,'(a13,i1,"_",i4.4,"-",i1)') 1560 & lbl_cphfaoresp,index4cphf, 1561 & iimoderaman,iiistepraman 1562 else 1563 write(lbl_cphfaoresp1,'(a13,i1)') lbl_cphfaoresp,index4cphf 1564 endif 1565 call util_file_name(lbl_cphfaoresp1, 1566 & .false.,.false.,aorespfilename) 1567 1568 nsub_file=0 ! reset value in all nodes 1569 nsub=0 ! reset value in all nodes 1570 flag2readfile=.false. 1571 if (.not. dft_CPHF2_read( 1572 & aorespfilename, ! in: filename 1573 & n, ! in: sum_{i=1,npol} nocc(i)*nvirt(i) 1574 & ncomp, ! in: nr. components 1575 & nvec, ! in: nr. of directions = 3 1576 & n1, ! in: =n*ncomp 1577 & nsub, ! ou: last subspace index (nsub+1)= nr of subspaces stored 1578 & nsub_file,! ou: last subspace read from file 1579 & maxsub, ! in: maximum subspace 1580 & g_z1, ! ou: history matrix z 1581 & g_Az1)) ! ou: history matrix Az 1582 & then 1583c if (ga_nodeid().eq.0) 1584c & write(*,1999) aorespfilename(1:inp_strlen(aorespfilename)) 1585c 1999 format('File ',a, 1586c & ' does not exist, proceed to generate (z1,Az1)') 1587c ------ g_z0 --> g_z1 ----- START 1588c Copying initial guess 1589 nsub_file=0 1590 nsub=0 1591 m1=1 1592 m2=n 1593 p1=nsub+1 1594 p2=nsub+nvec 1595 do ipm=1,ncomp 1596 1597 if (debug1) then 1598 if (ga_nodeid().eq.0) then 1599 write(*,2770) ipm 1600 2770 format('---------g_z-guess(',i3,')-----START') 1601 endif 1602 call ga_print(g_z(ipm)) 1603 if (ga_nodeid().eq.0) then 1604 write(*,2701) ipm 1605 2771 format('---------g_z-guess(',i3,')-----END') 1606 endif 1607 endif ! end-if-debug1 1608 1609 call ga_copy_patch('n',g_z(ipm),1 ,n ,1 ,nvec, 1610 $ g_z1 ,m1,m2,p1,p2) 1611 m1=m1+n 1612 m2=m2+n 1613 enddo ! end-loop-ipm 1614c ------ g_z0 --> g_z1 ----- END 1615 else 1616 call ga_sync() 1617c Note.- I need to propagate nsub 1618 call ga_igop(6,nsub_file,1,'+') ! node0 nsub ne 0, eq 0 every other node 1619 call ga_igop(6,nsub,1,'+') ! node0 nsub ne 0, eq 0 every other node 1620 flag2readfile=.true. 1621 nblock=nsub/3+1 1622 m1=1 1623 m2=n 1624 p1=nsub+1 1625 p2=nsub+nvec 1626 do ipm=1,ncomp 1627 call ga_copy_patch('n',g_z1 ,m1,m2,p1,p2, 1628 & g_z(ipm),1 ,n ,1 ,nvec) 1629 1630 if (debug1) then 1631 if (ga_nodeid().eq.0) then 1632 write(*,2790) ipm 1633 2790 format('---------g_z-guess(',i3,')-----START') 1634 endif 1635 call ga_print(g_z(ipm)) 1636 if (ga_nodeid().eq.0) then 1637 write(*,2791) ipm 1638 2791 format('---------g_z-guess(',i3,')-----END') 1639 endif 1640 endif ! end-if-debug1 1641 1642 m1=m1+n 1643 m2=m2+n 1644 enddo ! end-loop-ipm 1645 if (debug1) then 1646 if (ga_nodeid().eq.0) 1647 & write(*,*) '---------g_z1-read-from-file-----START' 1648 call ga_print(g_z1) 1649 if (ga_nodeid().eq.0) 1650 & write(*,*) '---------g_z1-read-from-file-----END' 1651 if (ga_nodeid().eq.0) 1652 & write(*,*) '---------g_Az1-read-from-file-----START' 1653 call ga_print(g_Az1) 1654 if (ga_nodeid().eq.0) 1655 & write(*,*) '---------g_Az1-read-from-file-----END' 1656 endif ! end-if-debug1 1657 endif 1658c 000000000000000 getting cphf filename to store 00000000 END 1659c +++++++++++++++++++++++++++++++++++++++++++++++++ START 1660c ========== complex linear solver iteration ========= 1661c +++++++++++++++++++++++++++++++++++++++++++++++++ START 1662 do iter = 1, maxiter 1663 if (debug) write (6,*) 1664 & 'calling product from ga_lkain_2cpl_damp' 1665c Note.- product=rohf_hessv3_cmplx,uhf_hessv3_cmplx 1666 if (debug1) then 1667 do ipm=1,ncomp 1668 if (ga_nodeid().eq.0) then 1669 write(*,2775) ipm,iter 1670 2775 format('----g_z-toprod(',i3,',',i3,')-----START') 1671 endif 1672 call ga_print(g_z(ipm)) 1673 if (ga_nodeid().eq.0) then 1674 write(*,2776) ipm,iter 1675 2776 format('----g_z-toprod(',i3,',',i3,')-----END') 1676 endif 1677 enddo ! end-loop-ipm 1678 endif ! end-if-debug1 1679 1680 call product(acc, 1681 & g_z, ! in : x 1682 & g_Az1, ! out : product A x 1683 & nsub, 1684 & omega, ! in : 1685 & limag, ! in : 1686 & lifetime, ! in : =.true. -> x is complex 1687 & gamwidth, ! in : 1688 & ncomp, ! in : nr. components 1689 & iter) 1690 1691 if (debug) write (6,*) 1692 & 'returning product from ga_lkain_2cpl_damp' 1693 1694 p1=nsub+1 1695 p2=nsub+nvec 1696 m1=1 1697 m2=n 1698 do ipm = 1,ncomp 1699c g_r will be the quantity -Ax + b, i.e. if the equation system 1700c Ax = b is solved then this vector will be zero 1701c 1702c During the first cycle, 1703c g_Ax is calculated from the initial guess for which the 1704c preconditioner has already been applied (to be more clear: 1705c we have divided the perturbation matrix elements by orbital 1706c energy denominators, including the frequency term, 1707c and assigned real and imaginary parts accordingly) 1708c ========= get new (r,r_im) ======== START 1709 call ga_add_patch( one_cmplx,g_zb(ipm),1 ,n ,1 ,nvec, 1710 $ mone_cmplx,g_Az1 ,m1,m2,p1,p2, 1711 $ g_zr1 ,m1,m2,1 ,nvec) 1712 m1=m1+n 1713 m2=m2+n 1714c ========= get new (r,r_im) ======== END 1715 enddo ! ipm = 1,ncomp 1716 1717 if (debug1) then 1718 if (ga_nodeid().eq.0) then 1719 write(*,2773) iter 1720 2773 format('---------g_Az1-aft-prod(',i3,')-----START') 1721 endif 1722 call ga_print(g_Az1) 1723 if (ga_nodeid().eq.0) then 1724 write(*,2778) iter 1725 2778 format('---------g_Az1-aft-prod(',i3,')-----END') 1726 endif 1727 do ipm=1,ncomp 1728 if (ga_nodeid().eq.0) then 1729 write(*,2779) ipm,iter 1730 2779 format('----g_zb(',i3,',',i3,')-----START') 1731 endif 1732 call ga_print(g_zb(ipm)) 1733 if (ga_nodeid().eq.0) then 1734 write(*,2880) ipm,iter 1735 2880 format('----g_zb(',i3,',',i3,')-----END') 1736 endif 1737 enddo ! end-loop-ipm 1738 if (ga_nodeid().eq.0) then 1739 write(*,2782) iter 1740 2782 format('----g_zr1-chk(',i3,')-----START') 1741 endif 1742 call ga_print(g_zr1) 1743 if (ga_nodeid().eq.0) then 1744 write(*,2783) iter 1745 2783 format('----g_zr1-chk(',i3,')-----END') 1746 endif 1747 endif ! end-if-debug1 1748 1749 call get_precond_rmax_zin( 1750 & rmax, ! out: max(g_r,g_r_im) 1751 & g_zr1, ! in : complex+accumulated g_zr 1752 & g_Az1, ! in : complex+accumulated g_Az 1753 & nsub, ! in : pointer to current (g_zr,g_Az) 1754 & precond, ! in : name of preconditioner routine 1755 & converge_precond, ! in : =.true. prec->max 1756 & omega, ! in : omega 1757 & gamwidth,! in : gamwidth 1758 & ncomp, ! in : nr. components 1759 & npol, ! in : nr. polarizations (1 or 2) 1760 & nvir, ! in : nr. virtual MOs 1761 & nocc, ! in : nr. occupied MOs 1762 & n, ! in : =sum_i (nocc * nvir)(i) i=1,npol 1763 & nvec, ! in : =3 (x,y,z) 1764 & iter, ! in : nr. iteration 1765 & debug) ! in : =.true. -> allow debug printouts 1766 1767 if (debug1) then 1768 if (ga_nodeid().eq.0) then 1769 write(*,1775) iter 1770 1775 format('---------g_z1-to-file(',i3,')-----START') 1771 endif 1772 call ga_print(g_z1) 1773 if (ga_nodeid().eq.0) then 1774 write(*,1776) iter 1775 1776 format('---------g_z1-to-file(',i3,')-----END') 1776 endif 1777 if (ga_nodeid().eq.0) then 1778 write(*,1773) iter 1779 1773 format('---------g_Az1-to-file(',i3,')-----START') 1780 endif 1781 call ga_print(g_Az1) 1782 if (ga_nodeid().eq.0) then 1783 write(*,1774) iter 1784 1774 format('---------g_Az1-to-file(',i3,')-----END') 1785 endif 1786 endif ! end-if-debug1 1787 1788 if ((.not.(flag2readfile .and. iter.eq.1).and. 1789 & cphf3write.eq.1) .or. 1790 & (cphf3write.eq.2 .and. rmax.lt.tol)) ! store only last (g_z1,g_Az1) block 1791 & then 1792 status=dft_CPHF2_write( 1793 & aorespfilename, ! in: filename 1794 & n, ! in: sum_{i=1,npol} nocc(i)*nvirt(i) 1795 & ncomp, ! in: nr. components 1796 & nvec, ! in: nr. of directions = 3 1797 & n1, ! in: =n*ncomp 1798 & nsub, ! in: nsub 1799 & nsub_file,! in: last subspace index (nsub+1)= nr of subspaces stored 1800 & g_z1, ! in: history matrix z 1801 & g_Az1) ! in: history matrix Az 1802 nsub_file=nsub_file+nvec 1803 endif ! end-if-write-block 1804 1805c JEM: Putting rmax into rtdb 1806 if (.not. rtdb_put(rtdb, 'lkain:rmax', mt_dbl, 1, rmax)) 1807 $ call errquit( 1808 $ 'ga_lkain_2cpl3_damp_cmplx_redmem: rmax put failed', 1809 $ 1, RTDB_ERR) 1810 1811 1812c -------- printout per iteration -------------- START 1813 if (oprint .and. ga_nodeid().eq.0) then 1814 1815 if (debug1) then 1816 write(6,4) iter, nsub+nvec, rmax, util_wallsec() 1817 call util_flush(6) 1818 4 format('FA-chk: ', i5, i7, 3x,1p,d9.2,0p,f10.1,5x,i3) 1819 endif 1820 1821 write(6,3) iter, nsub+nvec, rmax, util_wallsec() 1822 call util_flush(6) 1823 3 format(' ', i5, i7, 3x,1p,d9.2,0p,f10.1,5x,i3) 1824 end if 1825c -------- printout per iteration -------------- END 1826 1827c stop iterations if residual is smaller than criterion 1828 if (rmax .lt. tol) then 1829 converged = .true. 1830c ========== g_z1 --> g_z ======== START 1831c Note.- Extract last (n1,nvec) block from g_z1 and 1832c put it in g_z (this is the solution to Ax=b) 1833 m1=1 1834 m2=n 1835 p1=nsub+1 1836 p2=nsub+nvec 1837 do ipm=1,ncomp 1838 call ga_copy_patch('n',g_z1 ,m1,m2,p1,p2, 1839 $ g_z(ipm),1 ,n ,1,nvec) 1840 m1=m1+n 1841 m2=m2+n 1842 enddo ! end-loop-ipm 1843 if (debug1) then 1844 do ipm=1,ncomp 1845 if (ga_nodeid().eq.0) then 1846 write(*,2785) ipm,iter 1847 2785 format('----g_z-SOLUTION(',i3,',',i3,')-----START') 1848 endif 1849 call ga_print(g_z(ipm)) 1850 if (ga_nodeid().eq.0) then 1851 write(*,2786) ipm,iter 1852 2786 format('----g_z-SOLUTION(',i3,',',i3,')-----END') 1853 endif 1854 enddo ! end-loop-ipm 1855 endif ! end-if-debug1 1856c ========== g_z1 --> g_z ======== END 1857 goto 100 1858 end if 1859 1860 if (debug1) then 1861 if (ga_nodeid().eq.0) then 1862 write(*,2700) iter 1863 2700 format('---------g_z1-0(',i3,')-----START') 1864 endif 1865 call ga_print(g_z1) 1866 if (ga_nodeid().eq.0) then 1867 write(*,2701) iter 1868 2701 format('---------g_z1-0(',i3,')-----END') 1869 endif 1870 if (ga_nodeid().eq.0) then 1871 write(*,2702) iter 1872 2702 format('---------g_Az1-0(',i3,')-----START') 1873 endif 1874 call ga_print(g_Az1) 1875 if (ga_nodeid().eq.0) then 1876 write(*,2703) iter 1877 2703 format('---------g_Az1-0(',i3,')-----END') 1878 endif 1879 if (ga_nodeid().eq.0) then 1880 write(*,2704) iter 1881 2704 format('---------g_zr1-0(',i3,')-----START') 1882 endif 1883 call ga_print(g_zr1) 1884 if (ga_nodeid().eq.0) then 1885 write(*,2705) iter 1886 2705 format('---------g_zr1-0(',i3,')-----END') 1887 endif 1888 endif ! end-if-debug1 1889 1890 nsub = nsub + nvec 1891 select case(slcKAIN) 1892 case(1) ! Real solver 1893 call solve_zlineq_KAIN1( 1894 & g_Ax1, ! in/out: history of Ax1 (real) 1895 & g_x1, ! in/out: history of x1 (real) 1896 & g_xr1, ! in/out: history of xr1 (real) residual 1897 & g_Az1, ! in : history of g_Az 1898 & g_z1, ! in/out: history of g_z adding a block g_z1 1899 & g_zr1, ! in : g_zr 1900 & nsub, ! in : subspace length 1901 & nvec, ! in : increment of subspace 1902 & ncomp, ! in : nr. components 1903 & n, ! in : nr. elements per comp. 1904 & iter, ! in : iteration nr. 1905 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 1906 & debug1) ! in : =.true. show debug printouts 1907 case(2) ! complex-solver 1908 call solve_zlineq1( 1909 & g_Az1, ! in : history of g_Az 1910 & g_z1, ! in/out: history of g_z adding a block g_z1 1911 & g_zr1, ! in : g_zr 1912 & nsub, ! in : subspace length 1913 & nvec, ! in : increment of subspace 1914 & ncomp, ! in : nr. components 1915 & n, ! in : nr. elements per comp. 1916 & iter, ! in : iteration nr. 1917 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 1918 & debug1) ! in : =.true. show debug printouts 1919 case(3) ! complex-solver-fixed (fixed KAIN with differences) 1920 call solve_zlineq_KAIN3( 1921 & g_Az1, ! in : history of g_Az 1922 & g_z1, ! in/out: history of g_z adding a block g_z1 1923 & g_zr1, ! in : g_zr 1924 & nsub, ! in : subspace length 1925 & nvec, ! in : increment of subspace 1926 & ncomp, ! in : nr. components 1927 & n, ! in : nr. elements per comp. 1928 & iter, ! in : iteration nr. 1929 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 1930 & debug1) ! in : =.true. show debug printouts 1931 case (:0) ! All other values 1932 case (4:) 1933 call errquit( 1934 & 'ga_lkain_2cpl3_damp_cmplx_redmem: slcKAIN not 1,2 or 3', 1935 & 555, RTDB_ERR) 1936 end select 1937 1938c -------- get g_z from g_z1 --- START 1939 m1=1 1940 m2=n 1941 p1=nsub+1 1942 p2=nsub+nvec 1943 call ga_inquire(g_z1,type,dim1,dim2) 1944 do ipm=1,ncomp 1945 call ga_copy_patch('n',g_z1 ,m1,m2,p1,p2, 1946 & g_z(ipm),1 ,n ,1 ,nvec) 1947 m1=m1+n 1948 m2=m2+n 1949 enddo ! end-loop-ipm 1950c -------- get g_z from g_z1 --- START 1951 1952 if (nsub .eq. maxsub-nvec) then 1953c 1954c Reduce the subspace as necessary 1955c 1956c ====== left-shifting patch ==== START 1957c Note.- matrices Ay,y shift to left nvec positions 1958c removing leftmost patch of dimension: n4 x nvec 1959 do isub = nvec+1, maxsub, nvec 1960 call ga_copy_patch('n',g_Az1,1,n1,isub,isub+nvec-1, 1961 $ g_Az1,1,n1,isub-nvec,isub-1) 1962 call ga_copy_patch('n',g_z1 ,1,n1,isub,isub+nvec-1, 1963 $ g_z1 ,1,n1,isub-nvec,isub-1) 1964 enddo ! end-loop-isub 1965c ====== left-shifting patch ==== END 1966 nsub = nsub - nvec 1967 end if ! (nsub .eq. maxsub) 1968 1969 enddo ! iter = 1,maxiter 1970c +++++++++++++++++++++++++++++++++++++++++++++++++ END 1971c ========== complex linear solver iteration ========= 1972c +++++++++++++++++++++++++++++++++++++++++++++++++ END 1973 1974 100 continue ! jump here if converged 1975 1976 if (.not. converged) then 1977 if (ga_nodeid().eq.0) then 1978 write (luout,*) 'WARNING: CPKS procedure is NOT converged' 1979 write (luout,*) ' I will proceed, but check your results!' 1980 endif 1981c ======= Still write non-converge (g_z1,g_Az1) ==== START 1982 if (cphf3write.eq.2) then 1983 nsub=nsub-nvec ! point to previous sub-space 1984 status=dft_CPHF2_write( 1985 & aorespfilename, ! in: filename 1986 & n, ! in: sum_{i=1,npol} nocc(i)*nvirt(i) 1987 & ncomp, ! in: nr. components 1988 & nvec, ! in: nr. of directions = 3 1989 & n1, ! in: =n*ncomp 1990 & nsub, ! in: nsub 1991 & nsub_file, ! in: last subspace index (nsub+1)= nr of subspaces stored 1992 & g_z1, ! in: history matrix z 1993 & g_Az1) ! in: history matrix Az 1994 endif 1995c ======= Still write non-converge (g_z1,g_Az1) ==== END 1996 endif 1997 if (.not. ga_destroy(g_zb1)) call errquit 1998 & ('lkain_2cpl3-cmplx: destroy zb1',3, GA_ERR) 1999 if (.not. ga_destroy(g_Az1)) call errquit 2000 & ('lkain_2cpl3-cmplx: destroy Az1',3, GA_ERR) 2001 if (.not. ga_destroy(g_z1)) call errquit 2002 & ('lkain_2cpl3-cmplx: destroy z1',4, GA_ERR) 2003 if (.not. ga_destroy(g_zr1)) call errquit 2004 & ('lkain_2cpl3-cmplx: destroy zr1',6, GA_ERR) 2005c ++++++ added for solve_zlineq_KAIN1 +++ START 2006 if (slcKAIN.eq.2) then 2007 if (.not. ga_destroy(g_Ax1)) call errquit 2008 & ('lkain_2cpl3-real: destroy Ax1',3, GA_ERR) 2009 if (.not. ga_destroy(g_x1)) call errquit 2010 & ('lkain_2cpl3-real: destroy x1',4, GA_ERR) 2011 if (.not. ga_destroy(g_xr1)) call errquit 2012 & ('lkain_2cpl3-real: destroy xr1',6, GA_ERR) 2013 endif 2014c ++++++ added for solve_zlineq_KAIN1 +++ END 2015 end 2016c Auxiliar routine for redmem() 2017 subroutine solve_zlineq_KAIN1( 2018 & g_Ax1, ! in/out: history of Ax1 (real) 2019 & g_x1, ! in/out: history of x1 (real) 2020 & g_xr1, ! in/out: history of xr1 (real) residual 2021 & g_Az1, ! in : history of g_Az 2022 & g_z1, ! in/out: history of g_z adding a block g_z1 2023 & g_zr1, ! in : g_zr 2024 & nsub, ! in : subspace length 2025 & nvec, ! in : increment of subspace 2026 & ncomp, ! in : nr. components 2027 & n, ! in : nr. elements per comp. 2028 & iter, ! in : iteration nr. 2029 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 2030 & debug1) ! in : =.true. show debug printouts 2031 implicit none 2032#include "errquit.fh" 2033#include "mafdecls.fh" 2034#include "global.fh" 2035#include "util.fh" 2036#include "rtdb.fh" 2037 integer g_Az1,g_z1,g_zr1, 2038 & g_Ax1,g_x1,g_xr1 2039 integer nsub,nvec,ncomp,n, 2040 & iter,checkorth 2041 logical debug1 2042 external solve_xlineq_4redmem, 2043 & copy_complx2real_4redmem 2044 2045 call copy_complx2real_4redmem( 2046 & g_Ax1, ! ou : history of Az1 (real) 2047 & g_x1, ! ou : history of z1 (real) 2048 & g_xr1, ! ou : history of zr1 (real) residual 2049 & g_Az1, ! in : history of Az1 (complex) 2050 & g_z1, ! in : history of z1 (complex) 2051 & g_zr1, ! in : history of zr1 (complex) residual 2052 & nsub, 2053 & nvec, 2054 & ncomp, 2055 & n) 2056 2057 if (debug1) then 2058 if (ga_nodeid().eq.0) then 2059 write(*,2706) iter 2060 2706 format('---------g_x1-0(',i3,')-----START') 2061 endif 2062 call ga_print(g_x1) 2063 if (ga_nodeid().eq.0) then 2064 write(*,2707) iter 2065 2707 format('---------g_x1-0(',i3,')-----END') 2066 endif 2067 if (ga_nodeid().eq.0) then 2068 write(*,2708) iter 2069 2708 format('---------g_Ax1-0(',i3,')-----START') 2070 endif 2071 call ga_print(g_Ax1) 2072 if (ga_nodeid().eq.0) then 2073 write(*,2709) iter 2074 2709 format('---------g_Ax1-0(',i3,')-----END') 2075 endif 2076 if (ga_nodeid().eq.0) then 2077 write(*,2710) iter 2078 2710 format('---------g_xr1-0(',i3,')-----START') 2079 endif 2080 call ga_print(g_xr1) 2081 if (ga_nodeid().eq.0) then 2082 write(*,2711) iter 2083 2711 format('---------g_xr1-0(',i3,')-----END') 2084 endif 2085 endif ! end-if-debug1 2086 2087c ++++++++++++++++++++++++++++++++++++++ 2088c ++++ Solve real linear system +++START 2089c ++++++++++++++++++++++++++++++++++++++ 2090 call solve_xlineq_4redmem( 2091 & g_Ax1, ! in : history of products Ax 2092 & g_x1, ! in : history of solution x 2093 & g_xr1, ! in : current residual r=Ax-b 2094 & g_z1, ! in/out: history of g_z adding a block g_z1 2095 & nsub, ! in : subspace length 2096 & nvec, ! in : increment of subspace 2097 & ncomp, ! in : nr. components 2098 & n, ! in : nr. elements per comp. 2099 & iter, ! in : iteration nr. 2100 & debug1) ! in : =.true. show debug printouts 2101c ++++++++++++++++++++++++++++++++++++++ 2102c ++++ Solve real linear system +++END 2103c ++++++++++++++++++++++++++++++++++++++ 2104 return 2105 end 2106 subroutine solve_zlineq_KAIN3( 2107 & g_Az1, ! in : history of g_Az 2108 & g_z1, ! in/out: history of g_z adding a block g_z1 2109 & g_zr1, ! in : g_zr 2110 & nsub, ! in : subspace length 2111 & nvec, ! in : increment of subspace 2112 & ncomp, ! in : nr. components 2113 & n, ! in : nr. elements per comp. 2114 & iter, ! in : iteration nr. 2115 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 2116 & debug1) ! in : =.true. show debug printouts 2117 2118 implicit none 2119#include "errquit.fh" 2120#include "mafdecls.fh" 2121#include "global.fh" 2122#include "util.fh" 2123#include "rtdb.fh" 2124 integer g_Az1,g_z1,g_zr1 2125 integer nsub,nvec,ncomp,n, 2126 & iter,checkorth 2127 logical debug1 2128 external solve_zlineq1, 2129 & solve_zlineq1_fixed 2130 2131 if (iter.eq.1) then 2132 call solve_zlineq1( 2133 & g_Az1, ! in : history of g_Az 2134 & g_z1, ! in/out: history of g_z adding a block g_z1 2135 & g_zr1, ! in : g_zr 2136 & nsub, ! in : subspace length 2137 & nvec, ! in : increment of subspace 2138 & ncomp, ! in : nr. components 2139 & n, ! in : nr. elements per comp. 2140 & iter, ! in : iteration nr. 2141 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 2142 & debug1) ! in : =.true. show debug printouts 2143 else ! else-if-iter 2144 call solve_zlineq1_fixed( 2145 & g_Az1, ! in : history of g_Az 2146 & g_z1, ! in/out: history of g_z adding a block g_z1 2147 & g_zr1, ! in : g_zr 2148 & nsub, ! in : subspace length 2149 & nvec, ! in : increment of subspace 2150 & ncomp, ! in : nr. components 2151 & n, ! in : nr. elements per comp. 2152 & iter, ! in : iteration nr. 2153 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 2154 & debug1) ! in : =.true. show debug printouts 2155 endif ! end-if-iter 2156 2157 return 2158 end 2159c ++++++++++++++++++++++++++++++++++++++++++++++++++ 2160c ------- copy_complx2real_4redmem ----------- START 2161c ++++++++++++++++++++++++++++++++++++++++++++++++++ 2162 subroutine solve_xlineq_4redmem( 2163 & g_Ax1, ! in : history of products Ax 2164 & g_x1, ! in : history of solution x 2165 & g_xr1, ! in : current residual r=Ax-b 2166 & g_z1, ! in/out: history of g_z adding a block g_z1 2167 & nsub, ! in : subspace length 2168 & nvec, ! in : increment of subspace 2169 & ncomp, ! in : nr. components 2170 & n, ! in : nr. elements per comp. 2171 & iter, ! in : iteration nr. 2172 & debug1) ! in : =.true. show debug printouts 2173 implicit none 2174#include "errquit.fh" 2175#include "mafdecls.fh" 2176#include "global.fh" 2177#include "util.fh" 2178#include "rtdb.fh" 2179 external update_g_z1_4redmem1, 2180 & update_g_z1_4redmem2, 2181 & ga_svd_solve_seq 2182 integer iter,nsub,nvec,ncomp,n,n1,n4 2183 integer g_Ax1,g_x1,g_xr1,g_z1, 2184 & g_aa,g_bb,g_cc 2185 logical debug1 2186 2187 n1=n*ncomp 2188 n4=2*n1 ! for re+im with two components 2189 if (.not. ga_create(MT_DBL, nsub, nsub, 2190 & 'lkain_2cpl3_damp: A', 0, 0, g_aa)) 2191 $ call errquit('lkain: allocating g_a?', nsub, GA_ERR) 2192 if (.not. ga_create(MT_DBL, nsub, nvec, 2193 & 'lkain_2cpl3_damp: B', 0, 0,g_bb)) 2194 $ call errquit('lkain: allocating g_bb?', nsub, GA_ERR) 2195 if (.not. ga_create(MT_DBL, nsub, nvec, 2196 & 'lkain_2cpl3_damp: C', 0, 0, g_cc)) 2197 $ call errquit('lkain: allocating g_c?', nsub, GA_ERR) 2198 call ga_zero(g_aa) 2199 call ga_zero(g_bb) 2200 call ga_zero(g_cc) 2201 call ga_dgemm('t','n',nsub,nsub,n4,1.0d0, 2202 & g_x1,g_Ax1,0.0d0,g_aa) 2203 call ga_dgemm('t','n',nsub,nvec,n4,1.0d0, 2204 & g_x1,g_xr1,0.0d0,g_bb) 2205 2206 if (debug1) then 2207 if (ga_nodeid().eq.0) 2208 & write(*,*) '---------g_a(',iter,')-----START' 2209 call ga_print(g_aa) 2210 if (ga_nodeid().eq.0) 2211 & write(*,*) '---------g_a(',iter,')-----END' 2212 if (ga_nodeid().eq.0) 2213 & write(*,*) '---------g_b(',iter,')-----START' 2214 call ga_print(g_bb) 2215 if (ga_nodeid().eq.0) 2216 & write(*,*) '---------g_b(',iter,')-----END' 2217 endif ! end-if-debug1 2218 2219 call ga_svd_solve_seq(g_aa,g_bb,g_cc,1d-14) 2220 2221 if (debug1) then 2222 if (ga_nodeid().eq.0) 2223 & write(*,*) '---------g_c-old(',iter,')-----START' 2224 call ga_print(g_cc) 2225 if (ga_nodeid().eq.0) 2226 & write(*,*) '---------g_c-old(',iter,')-----END' 2227 endif ! end-if-debug1 2228c 2229c Form and add the correction, in parts, onto the solution 2230c FA: Step 5: 2231 if (debug1) then 2232 if (ga_nodeid().eq.0) 2233 & write(*,*) '---------g_r2-BEF(',iter,')-----START' 2234 call ga_print(g_xr1) 2235 if (ga_nodeid().eq.0) 2236 & write(*,*) '---------g_r2-BEF(',iter,')-----END' 2237 endif ! end-if-debug1 2238 2239 call ga_dgemm('n','n',n4,nvec,nsub,-1.0d0, 2240 & g_Ax1,g_cc,1.0d0,g_xr1) 2241 2242 if (debug1) then 2243 if (ga_nodeid().eq.0) 2244 & write(*,*) '---------g_r2-AFT(',iter,')-----START' 2245 call ga_print(g_xr1) 2246 if (ga_nodeid().eq.0) 2247 & write(*,*) '---------g_r2-AFT(',iter,')-----END' 2248 endif ! end-if-debug1 2249c 2250c copy components of g_r2 into g_r before adding g_r to g_x 2251 call update_g_z1_4redmem1( 2252 & g_z1, ! ou : old solution to update 2253 & g_xr1, ! in : update 2254 & nsub, 2255 & nvec, 2256 & ncomp, 2257 & n) 2258 if (debug1) then 2259 if (ga_nodeid().eq.0) then 2260 write(*,4700) iter 2261 4700 format('---------g_z1-1(',i3,')-----START') 2262 endif 2263 call ga_print(g_z1) 2264 if (ga_nodeid().eq.0) then 2265 write(*,4701) iter 2266 4701 format('---------g_z1-1(',i3,')-----END') 2267 endif 2268 endif ! end-if-debug1 2269c FA: Step 8: 2270 call ga_dgemm('n','n',n4,nvec,nsub,1.0d0, 2271 & g_x1,g_cc,0.0d0,g_xr1) 2272 2273 if (debug1) then 2274 if (ga_nodeid().eq.0) 2275 & write(*,*) '---------g_y c(',iter,')-----START' 2276 call ga_print(g_xr1) 2277 if (ga_nodeid().eq.0) 2278 & write(*,*) '---------g_y c(',iter,')-----END' 2279 endif ! end-if-debug1 2280 2281c copy components of g_r2 into g_r before adding g_r to g_x 2282 call update_g_z1_4redmem2( 2283 & g_z1, ! ou : old solution to update 2284 & g_xr1, ! in : update 2285 & nsub, 2286 & nvec, 2287 & ncomp, 2288 & n) 2289 2290 if (debug1) then 2291 if (ga_nodeid().eq.0) then 2292 write(*,4702) iter 2293 4702 format('---------g_z1-2(',i3,')-----START') 2294 endif 2295 call ga_print(g_z1) 2296 if (ga_nodeid().eq.0) then 2297 write(*,4703) iter 2298 4703 format('---------g_z1-2(',i3,')-----END') 2299 endif 2300 endif ! end-if-debug1 2301 2302 if (.not. ga_destroy(g_aa)) call errquit 2303 & ('lkain_2cpl: a',0, GA_ERR) 2304 if (.not. ga_destroy(g_bb)) call errquit 2305 & ('lkain_2cpl: b',0, GA_ERR) 2306 if (.not. ga_destroy(g_cc)) call errquit 2307 & ('lkain_2cpl: c',0, GA_ERR) 2308 return 2309 end 2310 subroutine copy_complx2real_4redmem( 2311 & g_Ax1, ! ou : history of Az1 (real) 2312 & g_x1, ! ou : history of z1 (real) 2313 & g_xr1, ! ou : history of zr1 (real) residual 2314 & g_Az1, ! in : history of Az1 (complex) 2315 & g_z1, ! in : history of z1 (complex) 2316 & g_zr1, ! in : history of zr1 (complex) residual 2317 & nsub, 2318 & nvec, 2319 & ncomp, 2320 & n) 2321c 2322c Author : Fredy W. Aquino, Northwestern University 2323c Purpose: Translate history matrices from complex to real 2324c so that I can test old solver for c-KAIN coefficients 2325c using real variables 2326c g_Az1 --> g_Ax1 (history of products Az) 2327c g_z1 --> g_x1 (history of solutions z ) 2328c g_zr1 --> g_xr1 (residual for current iteration) 2329c dimension(g_Ax1) = 2 dimension(g_Az1) 2330c because structure of g_Ax1 = [ re im ...] 2331c similarly for g_x1,g_xr1 2332c Date : 03-10-14 2333 2334 implicit none 2335#include "errquit.fh" 2336#include "mafdecls.fh" 2337#include "global.fh" 2338#include "util.fh" 2339#include "rtdb.fh" 2340 integer n1,n,ncomp,nvec,nsub, 2341 & idat,idat1, 2342 & ivec,ivec1,shift 2343 integer l_z,k_z 2344 integer g_Az1,g_z1,g_zr1, 2345 & g_Ax1,g_x1,g_xr1 2346 double precision val_re,val_im 2347 2348 shift=nsub-nvec 2349 n1=n*ncomp 2350 2351 if (.not.MA_Push_Get(mt_dcpl,n1,'copy_complx2real_4redmem: l_z', 2352 & l_z,k_z)) 2353 & call errquit('copy_complx2real_4redmem: cannot allocate l_z', 2354 & n1, MA_ERR) 2355 2356 do ivec=1,nvec 2357 ivec1=shift+ivec 2358 call ga_get(g_Az1,1,n1,ivec1,ivec1,dcpl_mb(k_z),1) 2359 do idat=1,n1 2360 idat1=n1+idat 2361 val_re=dreal(dcpl_mb(k_z+idat-1)) 2362 val_im=dimag(dcpl_mb(k_z+idat-1)) 2363 call ga_put(g_Ax1,idat ,idat ,ivec1,ivec1,val_re,1) 2364 call ga_put(g_Ax1,idat1,idat1,ivec1,ivec1,val_im,1) 2365 enddo ! end-loop-idat 2366 enddo ! end-loop-ivec 2367 do ivec=1,nvec 2368 ivec1=shift+ivec 2369 call ga_get(g_z1,1,n1,ivec1,ivec1,dcpl_mb(k_z),1) 2370 do idat=1,n1 2371 idat1=n1+idat 2372 val_re=dreal(dcpl_mb(k_z+idat-1)) 2373 val_im=dimag(dcpl_mb(k_z+idat-1)) 2374 call ga_put(g_x1,idat ,idat ,ivec1,ivec1,val_re,1) 2375 call ga_put(g_x1,idat1,idat1,ivec1,ivec1,val_im,1) 2376 enddo ! end-loop-idat 2377 enddo ! end-loop-ivec 2378 call ga_zero(g_xr1) 2379 do ivec=1,nvec 2380 call ga_get(g_zr1,1,n1,ivec,ivec,dcpl_mb(k_z),1) 2381 do idat=1,n1 2382 idat1=n1+idat 2383 val_re=dreal(dcpl_mb(k_z+idat-1)) 2384 val_im=dimag(dcpl_mb(k_z+idat-1)) 2385 call ga_put(g_xr1,idat ,idat ,ivec,ivec,val_re,1) 2386 call ga_put(g_xr1,idat1,idat1,ivec,ivec,val_im,1) 2387 enddo ! end-loop-idat 2388 enddo ! end-loop-ivec 2389 if (.not.ma_pop_stack(l_z)) 2390 $ call errquit('copy_complx2real_4redmem: pop problem with l_z', 2391 & 555,MA_ERR) 2392 return 2393 end 2394 subroutine update_g_z1_4redmem1( 2395 & g_z1, ! ou : old solution to update 2396 & g_xr1, ! in : update 2397 & nsub, 2398 & nvec, 2399 & ncomp, 2400 & n) 2401c 2402c Author : Fredy W. Aquino, Northwestern University 2403c Purpose: Update g_z1 (history vector of solutions by adding a 2404c complex block n1 x nvec 2405c Date : 03-10-14 2406 2407 implicit none 2408#include "errquit.fh" 2409#include "mafdecls.fh" 2410#include "global.fh" 2411#include "util.fh" 2412#include "rtdb.fh" 2413 integer n2,n1,n,ncomp,nvec,nsub, 2414 & idat, 2415 & ivec,shift 2416 integer l_x,k_x,p1,p2,q1,q2 2417 integer g_z1,g_xr1,g_z2 2418 double complex val_cmplx,one_cmplx 2419 2420 one_cmplx =dcmplx( 1.0d0,0.0d0) 2421 shift=nsub-nvec 2422 n2=2*n*ncomp 2423 n1=n*ncomp 2424 if (.not. ga_create(MT_DCPL,n1,nvec, 'update_g_z1_4redmem1: z2', 2425 $ 0, 0, g_z2)) 2426 $ call errquit('update_g_z1_4redmem1: failed alloc subspace-z1', 2427 & nvec,GA_ERR) 2428 if (.not.MA_Push_Get(mt_dbl,n2,'update_g_z1_4redmem1: l_x', 2429 & l_x,k_x)) 2430 & call errquit('update_g_z1_4redmem1: cannot allocate l_x', 2431 & n2, MA_ERR) 2432 call ga_zero(g_z2) 2433 do ivec=1,nvec 2434 call ga_get(g_xr1,1,n2,ivec,ivec,dbl_mb(k_x),1) 2435 do idat=1,n1 2436 val_cmplx=dcmplx(dbl_mb(k_x+idat-1), 2437 & dbl_mb(k_x+idat-1+n1)) 2438 call ga_put(g_z2,idat ,idat ,ivec,ivec,val_cmplx,1) 2439 enddo ! end-loop-idat 2440 enddo ! end-loop-ivec 2441 p1=nsub-nvec+1 2442 p2=nsub-nvec+nvec 2443 q1=p1+nvec 2444 q2=p2+nvec 2445 call ga_add_patch(one_cmplx,g_z2,1,n1,1,nvec, 2446 $ one_cmplx,g_z1,1,n1,p1,p2, 2447 $ g_z1,1,n1,q1,q2) 2448 if (.not.ma_pop_stack(l_x)) 2449 $ call errquit('update_g_z1_4redmem1: pop problem with l_x', 2450 & 555,MA_ERR) 2451 if (.not. ga_destroy(g_z2)) call errquit 2452 & ('update_g_z1_4redmem1: destroy z2',3, GA_ERR) 2453 return 2454 end 2455 subroutine update_g_z1_4redmem2( 2456 & g_z1, ! ou : old solution to update 2457 & g_xr1, ! in : update 2458 & nsub, 2459 & nvec, 2460 & ncomp, 2461 & n) 2462c 2463c Author : Fredy W. Aquino, Northwestern University 2464c Purpose: Update g_z1 (history vector of solutions by adding a 2465c complex block n1 x nvec 2466c Date : 03-10-14 2467 2468 implicit none 2469#include "errquit.fh" 2470#include "mafdecls.fh" 2471#include "global.fh" 2472#include "util.fh" 2473#include "rtdb.fh" 2474 integer n2,n1,n,ncomp,nvec,nsub, 2475 & idat, 2476 & ivec,shift 2477 integer l_x,k_x,p1,p2,q1,q2 2478 integer g_z1,g_xr1,g_z2 2479 double complex val_cmplx,one_cmplx 2480 2481 one_cmplx =dcmplx( 1.0d0,0.0d0) 2482 shift=nsub-nvec 2483 n2=2*n*ncomp 2484 n1=n*ncomp 2485 if (.not. ga_create(MT_DCPL,n1,nvec, 'update_g_z1_4redmem2: z2', 2486 $ 0, 0, g_z2)) 2487 $ call errquit('update_g_z1_4redmem2: failed alloc subspace-z1', 2488 & nvec,GA_ERR) 2489 if (.not.MA_Push_Get(mt_dbl,n2,'update_g_z1_4redmem2: l_x', 2490 & l_x,k_x)) 2491 & call errquit('update_g_z1_4redmem2: cannot allocate l_x', 2492 & n2, MA_ERR) 2493 call ga_zero(g_z2) 2494 do ivec=1,nvec 2495 call ga_get(g_xr1,1,n2,ivec,ivec,dbl_mb(k_x),1) 2496 do idat=1,n1 2497 val_cmplx=dcmplx(dbl_mb(k_x+idat-1), 2498 & dbl_mb(k_x+idat-1+n1)) 2499 call ga_put(g_z2,idat ,idat ,ivec,ivec,val_cmplx,1) 2500 enddo ! end-loop-idat 2501 enddo ! end-loop-ivec 2502 p1=nsub-nvec+1 2503 p2=nsub-nvec+nvec 2504 q1=p1+nvec 2505 q2=p2+nvec 2506 call ga_add_patch(one_cmplx,g_z2,1,n1,1,nvec, 2507 $ one_cmplx,g_z1,1,n1,q1,q2, 2508 $ g_z1,1,n1,q1,q2) 2509 if (.not.ma_pop_stack(l_x)) 2510 $ call errquit('update_g_z1_4redmem2: pop problem with l_x', 2511 & 555,MA_ERR) 2512 if (.not. ga_destroy(g_z2)) call errquit 2513 & ('update_g_z1_4redmem2: destroy z2',3, GA_ERR) 2514 return 2515 end 2516c ++++++++++++++++++++++++++++++++++++++++++++++++++ 2517c ------- copy_complx2real_4redmem ----------- START 2518c ++++++++++++++++++++++++++++++++++++++++++++++++++ 2519c Note.- Differences bet XXredmem and XXredmem1 routines: 2520c In ga_lkain_2cpl3_damp_cmplx_redmem 2521c the product routine is: uhf_hessv3_cmplx 2522c which uses as output g_Az1 (history matrix of Az products) 2523c In ga_lkain_2cpl3_damp_cmplx_redmem1 2524c the product routine is: uhf_hessv3_cmplx1 2525c which uses as output g_Az (Az product from ith iteration) 2526 2527 subroutine ga_lkain_2cpl3_damp_cmplx_redmem1( 2528 & rtdb, 2529 & g_z, ! in/out: solution 2530 & g_zb, ! in : b (of Ax=b) 2531 & product, ! in : routine to compute Az 2532 & precond, ! in : routine to do energy scaling Az,r 2533 $ tol, 2534 & mmaxsub, 2535 & maxiter, 2536 & odiff,oprint, 2537 & omega, 2538 & limag, 2539 & lifetime, ! damp means complex, it is redundant 2540 & gamwidth, 2541 & ncomp, ! ncomp=2 (+/-) 2542 & npol, 2543 & nvir, 2544 & nocc) 2545c 2546c Purpose: Getting g_z by solving recursively a complex linear equation 2547c and reducing more memory cost. 2548c --> Modified from ga_lkain_2cpl3() 2549c Author : Fredy W. Aquino, Northwestern University 2550c Date : 03-15-12 2551 2552 implicit none 2553#include "errquit.fh" 2554#include "tcgmsg.fh" 2555#include "msgtypesf.h" 2556#include "mafdecls.fh" 2557#include "msgids.fh" 2558#include "global.fh" 2559#include "util.fh" 2560#include "stdio.fh" 2561#include "inp.fh" 2562#include "rtdb.fh" 2563 integer ncomp ! [input] no. of components to treat 2564 integer g_z(ncomp) ! [input/output] Initial guess/solution (Re,Im) 2565 integer g_zb(ncomp),! [input] b of Ax=b 2566 & g_z1, ! Scratch GA contains history of z in (n1,mmaxsub) 2567 & g_Az1, ! Scratch GA contains history of Az in (n1,mmaxsub) 2568 & g_zr1, ! Scratch GA (r= b-Ax) error of size (n1,nvec) 2569 & g_Az ! Scratch GA (store Az-ith product) 2570 integer g_zb1 2571 integer npol, 2572 & nvir(npol),nocc(npol) 2573c Note.- In g_z1,g_Az1 a (n1,nvec) block is added per iteration. 2574 integer rtdb ! [input] database handle 2575 double precision omega ! [input] coupling parameter 2576 logical limag ! [input] imaginary perturbation? 2577 logical lifetime ! [input] consider damping or not? 2578 double precision gamwidth ! [input] damping parameter 2579 external product ! [input] product routine 2580 external precond ! [input] preconditioner routine 2581 double precision tol ! [input] convergence threshold 2582 integer mmaxsub ! [input] maximum subspace dimension 2583 integer maxiter ! [input] maximum no. of iterations 2584 logical odiff ! [input] use differences in product 2585 logical oprint ! [input] print flag 2586c 2587c Solves the linear equations A(X)=0 for multiple vectors. 2588c 2589c ... jochen: 2590c This is a modified version of ga_lkain from file ga_it2.F 2591c This version allows to solve a coupled set of equations, i.e. 2592c there are two right-hand vectors and two initial guesses and two 2593c solutions which are coupled. The coupling is mediated by a 2594c parameter omega in the call to the preconditioner 2595c (elsewhere, omega is simply called "frequency") 2596c 2597c ... jochen: the above comment is from ga_lkain_2cpl3. This here is 2598c a modified version of that routine and takes care of a real and an 2599c imaginary part for each frequency component. I.e. now arrays 2600c have four components ... 2601c 2602c note: when called from cphf_solve3, odiff = .false. on input 2603c 2604c call product(acc,g_x, g_Ax) 2605c . acc is the accuracy trequired for each element of the product 2606c . g_x contains the vectors and g_Ax should be filled 2607c . with the product vectors. The no. of vectors (columns) in 2608c . g_x might differ from the no. of vectors input to ga_lkain(). 2609c 2610c call precond(g_x,shift) 2611c . apply preconditioning directly to the vectors in g_x with the 2612c . coupling parameter omega 2613c 2614c On input g_x should contain an initial guess. It returns the 2615c solution. 2616c 2617c maxsub should be at least 3*nvec and can be beneficially increased 2618c to about 10*nvec. 2619c 2620c Needs to be extended to store the sub-space vectors out-of-core 2621c at least while the product() routine is being executed. 2622c 2623c ... jochen: here in the iteration loops we keep track 2624c of two components of the solution vector, ipm = 1 and 2 2625c (ipm stands for + (plus) and - (minus) components) 2626 integer iter,n,n1, 2627 & nvec, nsub, isub, 2628 & type, maxsub, ipm, 2629 & nsub_file 2630 2631c ... jochen: for convenience, now most arrays have two components. 2632c that might be changed later if memory becomes an issue 2633 double precision rmax, acc 2634 logical converged, odebug, debug, 2635 & converge_precond, debug1 2636 double complex val_cmplx,num 2637 double precision ac 2638 integer p1,p2,m1,m2,dim1,dim2,nblock 2639 double complex one_cmplx,mone_cmplx,zero_cmplx 2640 logical dft_CPHF2_read, 2641 & dft_CPHF2_write, 2642 & dft_CPHF2_read2fix 2643 real ran1 2644 integer status_gasvd,idum 2645 double precision factor_x 2646 external solve_zlineq1,conv2reim_rhs, 2647 & get_precond_rmax_zin, 2648 & dft_CPHF2_read, 2649 & dft_CPHF2_write, 2650 & dft_CPHF2_read2fix 2651 logical status,flag2readfile 2652 integer index4cphf,checkorth,cphf3write, 2653 & csub 2654 character*255 aorespfilename 2655 character*(*) lbl_cphfaoresp 2656 character*255 lbl_cphfaoresp1 2657 integer iimoderaman,iiistepraman 2658 logical ramanspc 2659 parameter(lbl_cphfaoresp='aoresp_fiao_f') 2660 one_cmplx =dcmplx( 1.0d0,0.0d0) 2661 mone_cmplx=dcmplx(-1.0d0,0.0d0) 2662 zero_cmplx=dcmplx( 0.0d0,0.0d0) 2663 if (.not. rtdb_get(rtdb, 'cphf:cphf3write',mt_int,1, 2664 & cphf3write)) 2665 & cphf3write = 0 ! assigns 0 if unsuccessfull read from rtdb 2666 if (.not. rtdb_get(rtdb, 'cphf:checkorth',mt_int,1, 2667 & checkorth)) 2668 & checkorth = 0 ! assigns 0 if unsuccessfull read from rtdb 2669 call ga_inquire(g_z(1),type,n,nvec) ! get (n,nvec) n=sum(nocc*nvirt(i) i=1,npol) 2670 n1=ncomp*n 2671 maxsub = mmaxsub ! So don't modify input scalar arg 2672 if (maxsub .lt. 3*nvec) maxsub = 3*nvec 2673 maxsub = (maxsub/nvec)*nvec 2674 debug1=.false. 2675 debug = (.false. .and. ga_nodeid().eq.0) ! for code development 2676 2677c check input key if we should check for convergence 2678c after the preconditioner has been applied to the residual 2679 if (.not. rtdb_get(rtdb, 'aoresponse:precond', mt_log, 1, 2680 & converge_precond)) 2681 & converge_precond = .false. 2682 2683 if (debug) write (6,*) 'ga_lkain_2cpl_damp omega =',omega 2684 if (debug) write (6,*) 'ga_lkain_2cpl_damp limag =',limag 2685 if (debug) write (6,*) 'ga_lkain_2cpl_damp lifetime =',lifetime 2686 if (debug) write (6,*) 'ga_lkain_2cpl_damp gamwidth =',gamwidth 2687 if (debug) write (6,*) 'ga_lkain_2cpl_damp ncomp =', ncomp 2688 if (debug) write (6,*) 'ga_lkain_2cpl3 converge_precond', 2689 & converge_precond 2690c 2691c exit if this is the wrong routine to call (lifetime switch 2692c must be set) 2693 if (.not.lifetime) call errquit 2694 & ('ga_lkain_2cpl_damp but lifetime=.F.',0,UNKNOWN_ERR) 2695 2696c make sure odiff is false (never tested for odiff = .true.) 2697 if (odiff) call errquit 2698 & ('ga_lkain_2cpl_damp odiff=.T.',0,UNKNOWN_ERR) 2699c 2700 odebug = util_print('debug lsolve', print_never) .and. 2701 $ ga_nodeid().eq.0 2702c 2703 if (.not. rtdb_get(rtdb, 'cphf:acc', mt_dbl, 1, 2704 & acc)) acc = 0.0001d0*tol 2705c ------- create (zre,zim) ---------- START 2706 if (.not. ga_create(MT_DCPL,n1,nvec, 'lkain_2cpl: Az', 2707 $ 0, 0, g_Az)) 2708 $ call errquit('lkain: failed alloc subspace Az',nvec, 2709 & GA_ERR) 2710 if (.not. ga_create(MT_DCPL,n1,maxsub, 'lkain_2cpl: z1', 2711 $ 0, 0, g_z1)) 2712 $ call errquit('lkain: failed alloc subspace-z1',maxsub, 2713 & GA_ERR) 2714 if (.not. ga_create(MT_DCPL,n1,maxsub, 'lkain_2cpl: Az1', 2715 $ 0, 0, g_Az1)) 2716 $ call errquit('lkain: failed alloc subspace Az1',maxsub, 2717 & GA_ERR) 2718 if (.not. ga_create(MT_DCPL,n1,nvec, 'lkain_2cpl: zr2', 2719 $ 0, 0, g_zr1)) 2720 $ call errquit('lkain_2cpl: failed allocating zr1', nvec, 2721 & GA_ERR) 2722 if (.not. ga_create(MT_DCPL,n1,nvec, 'lkain_2cpl: zr2', 2723 $ 0, 0, g_zb1)) 2724 $ call errquit('lkain_2cpl: failed allocating zb1', nvec, 2725 & GA_ERR) 2726 call ga_zero(g_zb1) 2727 m1=1 2728 m2=n 2729 do ipm=1,ncomp 2730 call ga_copy_patch('n',g_zb(ipm),1 ,n ,1,nvec, 2731 & g_zb1 ,m1,m2,1,nvec) 2732 m1=m1+n 2733 m2=m2+n 2734 enddo ! end-loop-ipm 2735 call ga_zero(g_z1) 2736 call ga_zero(g_Az1) 2737 call ga_zero(g_zr1) 2738 call ga_sync() 2739c ------- create (zre,zim) ---------- END 2740 2741 if (oprint .and. ga_nodeid().eq.0) then 2742 write(6,1) n1, nvec, maxsub, tol, util_wallsec() 2743 1 format(//,'Iterative solution of linear equations',/, 2744 $ ' No. of variables', i9,/, 2745 $ ' No. of equations', i9,/, 2746 $ ' Maximum subspace', i9,/, 2747 $ ' Convergence', 1p,d9.1,/, 2748 $ ' Start time', 0p,f9.1,/) 2749 call util_flush(6) 2750 end if 2751 2752 if (oprint .and. ga_nodeid().eq.0) then 2753 write(6,2) 2754 call util_flush(6) 2755 2 format(/ 2756 $ ' iter nsub residual time ',/, 2757 $ ' ---- ------ -------- --------- ') 2758 end if 2759c 2760 nsub = 0 2761 converged = .false. 2762c 2763c --------------------- 2764c start interation loop 2765c --------------------- 2766c 2767c 000000000000000 getting cphf filename to store 00000000 START 2768 if (.not. rtdb_get(rtdb,'cphf3-aores:guess1', 2769 & mt_int,1,index4cphf)) index4cphf = 0 2770 2771 ramanspc=.false. 2772 status=rtdb_get(rtdb,'raman:aores0',mt_log,1,ramanspc) 2773 if (ramanspc) then 2774 if (.not. rtdb_get(rtdb,'raman:aores1', 2775 & mt_int, 1,iimoderaman)) call 2776 $ errquit('ga_lkain_2cpl3_redmem1: failed to read iimoderaman', 2777 & 0, RTDB_ERR) 2778 if (.not. rtdb_get(rtdb,'raman:aores2', 2779 & mt_int, 1,iiistepraman)) call 2780 $ errquit('ga_lkain_2cpl3_redmem1: failed to read iiistepraman', 2781 & 0, RTDB_ERR) 2782 write(lbl_cphfaoresp1,'(a13,i1,"_",i4.4,"-",i1)') 2783 & lbl_cphfaoresp,index4cphf, 2784 & iimoderaman,iiistepraman 2785 else 2786 write(lbl_cphfaoresp1,'(a13,i1)') lbl_cphfaoresp,index4cphf 2787 endif 2788 call util_file_name(lbl_cphfaoresp1, 2789 & .false.,.false.,aorespfilename) 2790 nsub_file=0 ! reset value in all nodes 2791 nsub=0 ! reset value in all nodes 2792 flag2readfile=.false. 2793 if (.not. dft_CPHF2_read( 2794 & aorespfilename, ! in: filename 2795 & n, ! in: sum_{i=1,npol} nocc(i)*nvirt(i) 2796 & ncomp, ! in: nr. components 2797 & nvec, ! in: nr. of directions = 3 2798 & n1, ! in: =n*ncomp 2799 & nsub, ! ou: last subspace index (nsub+1)= nr of subspaces stored 2800 & nsub_file,! ou: last subspace read from file 2801 & maxsub, ! in: maximum subspace 2802 & g_z1, ! ou: history matrix z 2803 & g_Az1)) ! ou: history matrix Az 2804 & then 2805c if (ga_nodeid().eq.0) 2806c & write(*,1999) aorespfilename(1:inp_strlen(aorespfilename)) 2807c 1999 format('File ',a, 2808c & ' does not exist, proceed to generate (z1,Az1)') 2809c ------ g_z0 --> g_z1 ----- START 2810c Copying initial guess 2811 nsub_file=0 2812 nsub=0 2813 m1=1 2814 m2=n 2815 p1=nsub+1 2816 p2=nsub+nvec 2817 do ipm=1,ncomp 2818 2819 if (debug1) then 2820 if (ga_nodeid().eq.0) then 2821 write(*,2770) ipm 2822 2770 format('---------g_z-guess(',i3,')-----START') 2823 endif 2824 call ga_print(g_z(ipm)) 2825 if (ga_nodeid().eq.0) then 2826 write(*,2771) ipm 2827 2771 format('---------g_z-guess(',i3,')-----END') 2828 endif 2829 endif ! end-if-debug1 2830 2831 call ga_copy_patch('n',g_z(ipm),1 ,n ,1 ,nvec, 2832 $ g_z1 ,m1,m2,p1,p2) 2833 m1=m1+n 2834 m2=m2+n 2835 enddo ! end-loop-ipm 2836c ------ g_z0 --> g_z1 ----- END 2837 else 2838c Note.- After reading (g_z1,g_Az1) I need to use precond routine 2839c which will do energy scaling. 2840 call ga_sync() 2841c Note.- I need to propagate nsub 2842 call ga_igop(6,nsub_file,1,'+') ! node0 nsub ne 0, eq 0 every other node 2843 call ga_igop(6,nsub,1,'+') ! node0 nsub ne 0, eq 0 every other node 2844 flag2readfile=.true. 2845 nblock=nsub/3+1 2846 m1=1 2847 m2=n 2848 p1=nsub+1 2849 p2=nsub+nvec 2850 do ipm=1,ncomp 2851 call ga_copy_patch('n',g_z1 ,m1,m2,p1,p2, 2852 & g_z(ipm),1 ,n ,1 ,nvec) 2853 2854 if (debug1) then 2855 if (ga_nodeid().eq.0) then 2856 write(*,2790) ipm 2857 2790 format('---------g_z-guess(',i3,')-----START') 2858 endif 2859 call ga_print(g_z(ipm)) 2860 if (ga_nodeid().eq.0) then 2861 write(*,2791) ipm 2862 2791 format('---------g_z-guess(',i3,')-----END') 2863 endif 2864 endif ! end-if-debug1 2865 m1=m1+n 2866 m2=m2+n 2867 enddo ! end-loop-ipm 2868 if (debug1) then 2869 if (ga_nodeid().eq.0) 2870 & write(*,*) '---------g_z1-read-from-file-----START' 2871 call ga_print(g_z1) 2872 if (ga_nodeid().eq.0) 2873 & write(*,*) '---------g_z1-read-from-file-----END' 2874 if (ga_nodeid().eq.0) 2875 & write(*,*) '---------g_Az1-read-from-file-----START' 2876 call ga_print(g_Az1) 2877 if (ga_nodeid().eq.0) 2878 & write(*,*) '---------g_Az1-read-from-file-----END' 2879 endif ! end-if-debug1 2880 endif 2881c 000000000000000 getting cphf filename to store 00000000 END 2882c +++++++++++++++++++++++++++++++++++++++++++++++++ START 2883c ========== complex linear solver iteration ========= 2884c +++++++++++++++++++++++++++++++++++++++++++++++++ START 2885 2886 do iter = 1, maxiter 2887 if (debug) write (6,*) 2888 & 'calling product from ga_lkain_2cpl_damp' 2889c Note.- product=rohf_hessv3_cmplx,uhf_hessv3_cmplx 2890 2891 if (debug1) then 2892 do ipm=1,ncomp 2893 if (ga_nodeid().eq.0) then 2894 write(*,2775) ipm,iter 2895 2775 format('----g_z-toprod(',i3,',',i3,')-----START') 2896 endif 2897 call ga_print(g_z(ipm)) 2898 if (ga_nodeid().eq.0) then 2899 write(*,2776) ipm,iter 2900 2776 format('----g_z-toprod(',i3,',',i3,')-----END') 2901 endif 2902 enddo ! end-loop-ipm 2903 endif ! end-if-debug1 2904 2905 call ga_zero(g_Az) ! reset g_Az 2906 2907 call product(acc, 2908 & g_z, ! in : x 2909 & g_Az, ! out : product A x 2910 & omega, ! in : 2911 & limag, ! in : 2912 & lifetime, ! in : =.true. -> x is complex 2913 & gamwidth, ! in : 2914 & ncomp) ! in : nr. components 2915 2916 if (debug) write (6,*) 2917 & 'returning product from ga_lkain_2cpl_damp' 2918 2919 p1=nsub+1 2920 p2=nsub+nvec 2921 m1=1 2922 m2=n 2923c --------- copy g_Az --> g_Az1 ------- START 2924 call ga_copy_patch('n',g_Az ,1,n1,1,nvec, 2925 & g_Az1,1,n1,p1,p2) 2926c --------- copy g_Az --> g_Az1 ------- END 2927 do ipm = 1,ncomp 2928c g_r will be the quantity -Ax + b, i.e. if the equation system 2929c Ax = b is solved then this vector will be zero 2930c 2931c During the first cycle, 2932c g_Ax is calculated from the initial guess for which the 2933c preconditioner has already been applied (to be more clear: 2934c we have divided the perturbation matrix elements by orbital 2935c energy denominators, including the frequency term, 2936c and assigned real and imaginary parts accordingly) 2937c ========= get new (r,r_im) ======== START 2938 call ga_add_patch( one_cmplx,g_zb(ipm),1 ,n ,1 ,nvec, 2939 $ mone_cmplx,g_Az1 ,m1,m2,p1,p2, 2940 $ g_zr1 ,m1,m2,1 ,nvec) 2941 m1=m1+n 2942 m2=m2+n 2943c ========= get new (r,r_im) ======== END 2944 enddo ! ipm = 1,ncomp 2945 2946 if (debug1) then 2947 if (ga_nodeid().eq.0) then 2948 write(*,2773) iter 2949 2773 format('---------g_Az1-aft-prod(',i3,')-----START') 2950 endif 2951 call ga_print(g_Az1) 2952 if (ga_nodeid().eq.0) then 2953 write(*,2778) iter 2954 2778 format('---------g_Az1-aft-prod(',i3,')-----END') 2955 endif 2956 do ipm=1,ncomp 2957 if (ga_nodeid().eq.0) then 2958 write(*,2779) ipm,iter 2959 2779 format('----g_zb(',i3,',',i3,')-----START') 2960 endif 2961 call ga_print(g_zb(ipm)) 2962 if (ga_nodeid().eq.0) then 2963 write(*,2880) ipm,iter 2964 2880 format('----g_zb(',i3,',',i3,')-----END') 2965 endif 2966 enddo ! end-loop-ipm 2967 if (ga_nodeid().eq.0) then 2968 write(*,2782) iter 2969 2782 format('----g_zr1-chk(',i3,')-----START') 2970 endif 2971 call ga_print(g_zr1) 2972 if (ga_nodeid().eq.0) then 2973 write(*,2783) iter 2974 2783 format('----g_zr1-chk(',i3,')-----END') 2975 endif 2976 endif ! end-if-debug1 2977 2978 call get_precond_rmax_zin( 2979 & rmax, ! out: max(g_r,g_r_im) 2980 & g_zr1, ! in : complex+accumulated g_zr 2981 & g_Az1, ! in : complex+accumulated g_Az 2982 & nsub, ! in : pointer to current (g_zr,g_Az) 2983 & precond, ! in : name of preconditioner routine 2984 & converge_precond, ! in : =.true. prec->max 2985 & omega, ! in : omega 2986 & gamwidth,! in : gamwidth 2987 & ncomp, ! in : nr. components 2988 & npol, ! in : nr. polarizations (1 or 2) 2989 & nvir, ! in : nr. virtual MOs 2990 & nocc, ! in : nr. occupied MOs 2991 & n, ! in : =sum_i (nocc * nvir)(i) i=1,npol 2992 & nvec, ! in : =3 (x,y,z) 2993 & iter, ! in : nr. iteration 2994 & debug) ! in : =.true. -> allow debug printouts 2995 2996 if (debug1) then 2997 if (ga_nodeid().eq.0) then 2998 write(*,1775) iter 2999 1775 format('---------g_z1-to-file(',i3,')-----START') 3000 endif 3001 call ga_print(g_z1) 3002 if (ga_nodeid().eq.0) then 3003 write(*,1776) iter 3004 1776 format('---------g_z1-to-file(',i3,')-----END') 3005 endif 3006 if (ga_nodeid().eq.0) then 3007 write(*,1773) iter 3008 1773 format('---------g_Az1-to-file(',i3,')-----START') 3009 endif 3010 call ga_print(g_Az1) 3011 if (ga_nodeid().eq.0) then 3012 write(*,1774) iter 3013 1774 format('---------g_Az1-to-file(',i3,')-----END') 3014 endif 3015 endif ! end-if-debug1 3016 3017c Note.- ".not.(flag2readfile .and. iter.eq.1) .and. cphf3write.eq.1" means 3018c if successfully read data (g_z1,g_Az1) from file 3019c then skip iter=1 to avoid storing repeteadly the last block. 3020 if ((.not.(flag2readfile .and. iter.eq.1).and. 3021 & cphf3write.eq.1) .or. 3022 & (cphf3write.eq.2 .and. rmax.lt.tol)) ! store only last (g_z1,g_Az1) block 3023 & then 3024 status=dft_CPHF2_write( 3025 & aorespfilename, ! in: filename 3026 & n, ! in: sum_{i=1,npol} nocc(i)*nvirt(i) 3027 & ncomp, ! in: nr. components 3028 & nvec, ! in: nr. of directions = 3 3029 & n1, ! in: =n*ncomp 3030 & nsub, ! in: nsub 3031 & nsub_file, ! in: last subspace index (nsub+1)= nr of subspaces stored 3032 & g_z1, ! in: history matrix z 3033 & g_Az1) ! in: history matrix Az 3034 nsub_file=nsub_file+nvec 3035 endif ! end-if-write-block 3036c -------- printout per iteration -------------- START 3037 if (oprint .and. ga_nodeid().eq.0) then 3038 write(6,3) iter, nsub+nvec, rmax, util_wallsec() 3039 call util_flush(6) 3040 3 format(' ', i5, i7, 3x,1p,d9.2,0p,f10.1,5x,i3) 3041 end if 3042c -------- printout per iteration -------------- END 3043c stop iterations if residual is smaller than criterion 3044 if (rmax .lt. tol) then 3045 converged = .true. 3046c ========== g_z1 --> g_z ======== START 3047c Note.- Extract last (n1,nvec) block from g_z1 and 3048c put it in g_z (this is the solution to Ax=b) 3049 m1=1 3050 m2=n 3051 p1=nsub+1 3052 p2=nsub+nvec 3053 do ipm=1,ncomp 3054 call ga_copy_patch('n',g_z1 ,m1,m2,p1,p2, 3055 $ g_z(ipm),1 ,n ,1,nvec) 3056 m1=m1+n 3057 m2=m2+n 3058 enddo ! end-loop-ipm 3059 if (debug1) then 3060 do ipm=1,ncomp 3061 if (ga_nodeid().eq.0) then 3062 write(*,2785) ipm,iter 3063 2785 format('----g_z-SOLUTION(',i3,',',i3,')-----START') 3064 endif 3065 call ga_print(g_z(ipm)) 3066 if (ga_nodeid().eq.0) then 3067 write(*,2786) ipm,iter 3068 2786 format('----g_z-SOLUTION(',i3,',',i3,')-----END') 3069 endif 3070 enddo ! end-loop-ipm 3071 endif ! end-if-debug1 3072c ========== g_z1 --> g_z ======== END 3073 goto 100 3074 end if 3075 3076 if (debug1) then 3077 if (ga_nodeid().eq.0) then 3078 write(*,2700) iter 3079 2700 format('---------g_z1-0(',i3,')-----START') 3080 endif 3081 call ga_print(g_z1) 3082 if (ga_nodeid().eq.0) then 3083 write(*,2701) iter 3084 2701 format('---------g_z1-0(',i3,')-----END') 3085 endif 3086 if (ga_nodeid().eq.0) then 3087 write(*,2702) iter 3088 2702 format('---------g_Az1-0(',i3,')-----START') 3089 endif 3090 call ga_print(g_Az1) 3091 if (ga_nodeid().eq.0) then 3092 write(*,2703) iter 3093 2703 format('---------g_Az1-0(',i3,')-----END') 3094 endif 3095 if (ga_nodeid().eq.0) then 3096 write(*,2704) iter 3097 2704 format('---------g_zr1-0(',i3,')-----START') 3098 endif 3099 call ga_print(g_zr1) 3100 if (ga_nodeid().eq.0) then 3101 write(*,2705) iter 3102 2705 format('---------g_zr1-0(',i3,')-----END') 3103 endif 3104 endif ! end-if-debug1 3105 3106 nsub = nsub + nvec 3107 3108 call solve_zlineq1( ! Using complex linear solver 3109 & g_Az1, ! in : history of g_Az 3110 & g_z1, ! in/out: history of g_z adding a block g_z1 3111 & g_zr1, ! in : g_zr 3112 & nsub, ! in : subspace length 3113 & nvec, ! in : increment of subspace 3114 & ncomp, ! in : nr. components 3115 & n, ! in : nr. elements per comp. 3116 & iter, ! in : iteration nr. 3117 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero as it converges) 3118 & debug1) ! in : =.true. show debug printouts 3119c -------- get g_z from g_z1 --- START 3120 m1=1 3121 m2=n 3122 p1=nsub+1 3123 p2=nsub+nvec 3124 call ga_inquire(g_z1,type,dim1,dim2) 3125 do ipm=1,ncomp 3126 call ga_copy_patch('n',g_z1 ,m1,m2,p1,p2, 3127 & g_z(ipm),1 ,n ,1 ,nvec) 3128 m1=m1+n 3129 m2=m2+n 3130 enddo ! end-loop-ipm 3131 3132 if (nsub .eq. maxsub-nvec) then 3133c 3134c Reduce the subspace as necessary 3135c 3136c ====== FA: left-shifting patch ==== START 3137c Note.- matrices Ay,y shift to left nvec positions 3138c removing leftmost patch of dimension: n4 x nvec 3139 do isub = nvec+1, maxsub, nvec 3140 call ga_copy_patch('n',g_Az1,1,n1,isub,isub+nvec-1, 3141 $ g_Az1,1,n1,isub-nvec,isub-1) 3142 call ga_copy_patch('n',g_z1 ,1,n1,isub,isub+nvec-1, 3143 $ g_z1 ,1,n1,isub-nvec,isub-1) 3144 enddo ! end-loop-isub 3145c ====== FA: left-shifting patch ==== END 3146 nsub = nsub - nvec 3147 end if ! (nsub .eq. maxsub) 3148 3149 enddo ! iter = 1,maxiter 3150c +++++++++++++++++++++++++++++++++++++++++++++++++ END 3151c ========== complex linear solver iteration ========= 3152c +++++++++++++++++++++++++++++++++++++++++++++++++ END 3153 3154 100 continue ! jump here if converged 3155 3156 if (.not. converged) then 3157 if (ga_nodeid().eq.0) then 3158 write (luout,*) 'WARNING: CPKS procedure is NOT converged' 3159 write (luout,*) ' I will proceed, but check your results!' 3160 endif 3161c ======= Still write non-converge (g_z1,g_Az1) ==== START 3162 if (cphf3write.eq.2) then 3163 nsub=nsub-nvec ! point to previous sub-space 3164 status=dft_CPHF2_write( 3165 & aorespfilename, ! in: filename 3166 & n, ! in: sum_{i=1,npol} nocc(i)*nvirt(i) 3167 & ncomp, ! in: nr. components 3168 & nvec, ! in: nr. of directions = 3 3169 & n1, ! in: =n*ncomp 3170 & nsub, ! in: nsub 3171 & nsub_file, ! in: last subspace index (nsub+1)= nr of subspaces stored 3172 & g_z1, ! in: history matrix z 3173 & g_Az1) ! in: history matrix Az 3174 endif 3175c ======= Still write non-converge (g_z1,g_Az1) ==== END 3176 endif 3177 if (.not. ga_destroy(g_zb1)) call errquit 3178 & ('lkain_2cpl3-cmplx: destroy zb1',3, GA_ERR) 3179 if (.not. ga_destroy(g_Az1)) call errquit 3180 & ('lkain_2cpl3-cmplx: destroy Az1',3, GA_ERR) 3181 if (.not. ga_destroy(g_z1)) call errquit 3182 & ('lkain_2cpl3-cmplx: destroy z1',4, GA_ERR) 3183 if (.not. ga_destroy(g_zr1)) call errquit 3184 & ('lkain_2cpl3-cmplx: destroy zr1',6, GA_ERR) 3185 if (.not. ga_destroy(g_Az)) call errquit 3186 & ('lkain_2cpl3-cmplx: destroy Az',3, GA_ERR) 3187 end 3188c ========= Reduce memory consumption ============== END 3189c ======================================================== 3190c ++++++++++++++++++++clean routine++++++++++++++++++++ END 3191 3192 subroutine conv2complex(g_z, ! out: = complx(g_xre,g_xim) 3193 & g_xre,! in : real arr 3194 & g_xim,! in : imaginary arr 3195 & n, ! in : n rows 3196 & nvec, ! in : nvec columns 3197 & ncomp)! in : nr. components 3198c 3199c Purpose: Convert into complex array 3200c (g_xre,g_xim) --> g_z 3201c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3202c ipm=1,ncomp 3203c Usual values: nvec=3 (x,y,z) ncomp=2 3204c 3205c Author: Fredy W. Aquino, Northwestern University 3206c Date : 04-08-12 3207 3208 implicit none 3209#include "errquit.fh" 3210#include "mafdecls.fh" 3211#include "global.fh" 3212#include "util.fh" 3213#include "rtdb.fh" 3214 integer ipm,ivec,idat, 3215 & n,nvec,ncomp, 3216 & l_zre,k_zre, 3217 & l_zim,k_zim 3218 integer g_xre(ncomp), 3219 & g_xim(ncomp),g_z(ncomp) 3220 double complex val_cmplx 3221 3222 if (.not.MA_Push_Get(mt_dbl,n,'hessv jfacs',l_zre,k_zre)) 3223 & call errquit('conv2complex: cannot allocate zre', 3224 & n, MA_ERR) 3225 if (.not.MA_Push_Get(mt_dbl,n,'hessv kfacs',l_zim,k_zim)) 3226 & call errquit('conv2complex: cannot allocate zim', 3227 & n, MA_ERR) 3228 do ipm=1,ncomp 3229 call ga_zero(g_z(ipm)) 3230 do ivec=1,nvec 3231 call ga_get(g_xre(ipm),1,n,ivec,ivec,dbl_mb(k_zre),n) 3232 call ga_get(g_xim(ipm),1,n,ivec,ivec,dbl_mb(k_zim),n) 3233 do idat=1,n 3234 val_cmplx=dcmplx(dbl_mb(k_zre+idat-1), 3235 & dbl_mb(k_zim+idat-1)) 3236 call ga_put(g_z(ipm),idat,idat,ivec,ivec,val_cmplx,1) 3237 enddo ! end-loop-idat 3238 enddo ! end-loop-ivec 3239 enddo ! end-loop-ipm 3240 if (.not.ma_pop_stack(l_zim)) 3241 $ call errquit('conv2complex: pop problem with l_zim', 3242 & 555,MA_ERR) 3243 if (.not.ma_pop_stack(l_zre)) 3244 $ call errquit('conv2complex: pop problem with l_zre', 3245 & 555,MA_ERR) 3246 return 3247 end 3248 3249 subroutine conv2complex1(g_z, ! out: = complx(g_xre,g_xim) 3250 & g_xre,! in : real arr 3251 & g_xim,! in : imaginary arr 3252 & nsub, ! in : pointer to block 3253 & nvir, ! in : nr. virtual MOs 3254 & nocc, ! in : nr. occupied MOs 3255 & ipm, ! in : =1,2 components indices 3256 & n, ! in : n rows 3257 & nvec) ! in : nvec columns 3258c 3259c Purpose: Convert into complex array 3260c (g_xre,g_xim) --> g_z 3261c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3262c ipm=1,ncomp 3263c Usual values: nvec=3 (x,y,z) ncomp=2 3264c 3265c Author: Fredy W. Aquino, Northwestern University 3266c Date : 04-08-12 3267 3268 implicit none 3269#include "errquit.fh" 3270#include "mafdecls.fh" 3271#include "global.fh" 3272#include "util.fh" 3273#include "rtdb.fh" 3274 integer ipm,ivec,ivec1,idat,i,j, 3275 & idat1,b1,b2,j1,nocc,nvir,ioff,ioff1, 3276 & n,nvec,ncomp,nsub, 3277 & l_zre,k_zre, 3278 & l_zim,k_zim 3279 integer g_xre,g_xim,g_z 3280 double complex val_cmplx 3281 3282 if (.not.MA_Push_Get(mt_dbl,nvir,'hessv jfacs',l_zre,k_zre)) 3283 & call errquit('conv2complex: cannot allocate zre', 3284 & nvir, MA_ERR) 3285 if (.not.MA_Push_Get(mt_dbl,nvir,'hessv kfacs',l_zim,k_zim)) 3286 & call errquit('conv2complex: cannot allocate zim', 3287 & nvir, MA_ERR) 3288 b1=nsub+1 3289 b2=nsub+nvec 3290 ivec1=1 3291 ioff1=(ipm-1)*n 3292 do ivec=b1,b2 3293 do i = ga_nodeid()+1,nocc,ga_nnodes() 3294 ioff = (i-1)*nvir + 1 3295 call ga_get(g_xre,ioff,ioff+nvir-1,ivec1,ivec1, 3296 $ dbl_mb(k_zre),nvir) 3297 call ga_get(g_xim,ioff,ioff+nvir-1,ivec1,ivec1, 3298 $ dbl_mb(k_zim),nvir) 3299 do j=1,nvir 3300 j1=ioff1+ioff+j-1 3301 val_cmplx=dcmplx(dbl_mb(k_zre+j-1), 3302 & dbl_mb(k_zim+j-1)) 3303 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3304 enddo ! end-loop-j 3305 enddo ! end-loop-i 3306 ivec1=ivec1+1 3307 enddo ! end-loop-ivec 3308 if (.not.ma_pop_stack(l_zim)) 3309 $ call errquit('conv2complex: pop problem with l_zim', 3310 & 555,MA_ERR) 3311 if (.not.ma_pop_stack(l_zre)) 3312 $ call errquit('conv2complex: pop problem with l_zre', 3313 & 555,MA_ERR) 3314 return 3315 end 3316 3317 subroutine conv2complex1_u( 3318 & g_z, ! out: = complx(g_xre,g_xim) 3319 & g_xre,! in : real arr 3320 & g_xim,! in : imaginary arr 3321 & nsub, ! in : pointer to block 3322 & npol, ! in : nr. polarizations 3323 & nvir, ! in : nr. virtual MOs 3324 & nocc, ! in : nr. occupied MOs 3325 & ipm, ! in : =1,2 components indices 3326 & n, ! in : n rows 3327 & nvec) ! in : nvec columns 3328c 3329c Purpose: Convert into complex array 3330c (g_xre,g_xim) --> g_z 3331c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3332c ipm=1,ncomp 3333c Usual values: nvec=3 (x,y,z) ncomp=2 3334c 3335c Author: Fredy W. Aquino, Northwestern University 3336c Date : 04-08-12 3337 3338 implicit none 3339#include "errquit.fh" 3340#include "mafdecls.fh" 3341#include "global.fh" 3342#include "util.fh" 3343#include "rtdb.fh" 3344 integer ipm,ivec,ivec1,idat,i,j, 3345 & idat1,b1,b2,j1, 3346 & ipol,npol,nocc(npol),nvir(npol), 3347 & ioff,ioff1,shift, 3348 & n,nvec,ncomp,nsub, 3349 & l_zre,k_zre, 3350 & l_zim,k_zim 3351 integer g_xre,g_xim,g_z 3352 double complex val_cmplx 3353 b1=nsub+1 3354 b2=nsub+nvec 3355 ivec1=1 3356 ioff1=(ipm-1)*n ! n=sum_{i=1,npol} (nocc*nvir)(i) 3357 do ivec=b1,b2 3358 do ipol=1,npol 3359 if (.not.MA_Push_Get(mt_dbl,nvir(ipol), 3360 & 'hessv jfacs',l_zre,k_zre)) 3361 & call errquit('conv2complex: cannot allocate zre', 3362 & nvir(ipol), MA_ERR) 3363 if (.not.MA_Push_Get(mt_dbl,nvir(ipol), 3364 & 'hessv kfacs',l_zim,k_zim)) 3365 & call errquit('conv2complex: cannot allocate zim', 3366 & nvir(ipol), MA_ERR) 3367 shift=nocc(1)*nvir(1)*(ipol-1) 3368 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 3369 ioff = shift+(i-1)*nvir(ipol) + 1 3370 call ga_get(g_xre,ioff,ioff+nvir(ipol)-1,ivec1,ivec1, 3371 $ dbl_mb(k_zre),nvir(ipol)) 3372 call ga_get(g_xim,ioff,ioff+nvir(ipol)-1,ivec1,ivec1, 3373 $ dbl_mb(k_zim),nvir(ipol)) 3374 do j=1,nvir(ipol) 3375 j1=ioff1+ioff+j-1 3376 val_cmplx=dcmplx(dbl_mb(k_zre+j-1), 3377 & dbl_mb(k_zim+j-1)) 3378 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3379 enddo ! end-loop-j 3380 enddo ! end-loop-i 3381 if (.not.ma_pop_stack(l_zim)) 3382 $ call errquit('conv2complex: pop problem with l_zim', 3383 & 555,MA_ERR) 3384 if (.not.ma_pop_stack(l_zre)) 3385 $ call errquit('conv2complex: pop problem with l_zre', 3386 & 555,MA_ERR) 3387 enddo ! end-loop-ipol 3388 ivec1=ivec1+1 3389 enddo ! end-loop-ivec 3390 3391 return 3392 end 3393 3394 subroutine conv2complex2(g_z, ! out: = complx(g_xre,g_xim) 3395 & g_xreim,! in : real arr 3396 & indrm) ! in : =1 -> re =2 -> im 3397c 3398c Purpose: Convert into complex array 3399c (g_xre,g_xim) --> g_z 3400c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3401c ipm=1,ncomp 3402c Usual values: nvec=3 (x,y,z) ncomp=2 3403c This routine does: g_z= g_z + g_xreim 3404c 3405c Author: Fredy W. Aquino, Northwestern University 3406c Date : 04-08-12 3407 3408 implicit none 3409#include "errquit.fh" 3410#include "mafdecls.fh" 3411#include "global.fh" 3412#include "util.fh" 3413#include "rtdb.fh" 3414 integer ipm,indrm, 3415 & ivec,idat, 3416 & n,nvec, 3417 & l_xreim,k_xreim, 3418 & l_z,k_z, 3419 & nocc,nvir,i,j,ioff 3420 integer g_xreim, 3421 & g_z,g_a,type 3422 double complex val_cmplx,one_cmplx 3423 one_cmplx =dcmplx( 1.0d0,0.0d0) 3424 if (indrm.ne.1 .and. 3425 & indrm.ne.2) then 3426 call errquit('conv2complex2: indrm ne 1 or 2', 3427 & 0,MA_ERR) 3428 endif 3429 if (.not. ga_create(MT_DCPL,1,1, 3430 & 'conv2complex2: A',0,0,g_a)) 3431 $ call errquit('solve_rlineq: failed allocating g_a', 3432 & 1,GA_ERR) 3433 call ga_inquire(g_z,type,n,nvec) ! get (n,nvec) 3434 if (.not.MA_Push_Get(mt_dbl,n,'hessv jfacs',l_xreim,k_xreim)) 3435 & call errquit('conv2complex2: cannot allocate xreim', 3436 & n, MA_ERR) 3437 if (.not.MA_Push_Get(mt_dcpl,n,'hessv kfacs',l_z,k_z)) 3438 & call errquit('conv2complex2: cannot allocate z', 3439 & n, MA_ERR) 3440 if (indrm.eq.1) then ! updating only REAL part 3441 do ivec=1,nvec 3442 call ga_get(g_xreim,1,n,ivec,ivec,dbl_mb(k_xreim),n) 3443 call ga_get(g_z ,1,n,ivec,ivec,dcpl_mb(k_z),n) 3444 do idat=1,n 3445 val_cmplx=dcmplx(dbl_mb(k_xreim+idat-1),0.0d0) 3446 call ga_put(g_a,1,1,1,1,val_cmplx,1) 3447 call ga_add_patch(one_cmplx,g_z,idat,idat,ivec,ivec, 3448 & one_cmplx,g_a,1 ,1 ,1 ,1 , 3449 & g_z,idat,idat,ivec,ivec) 3450 enddo ! end-loop-idat 3451 enddo ! end-loop-ivec 3452 else if (indrm.eq.2) then ! updating only IMAG part 3453 do ivec=1,nvec 3454 call ga_get(g_xreim,1,n,ivec,ivec,dbl_mb(k_xreim),n) 3455 call ga_get(g_z ,1,n,ivec,ivec,dcpl_mb(k_z),n) 3456 do idat=1,n 3457 val_cmplx=dcmplx(0.0d0,dbl_mb(k_xreim+idat-1)) 3458 call ga_put(g_a,1,1,1,1,val_cmplx,1) 3459 call ga_add_patch(one_cmplx,g_z,idat,idat,ivec,ivec, 3460 & one_cmplx,g_a,1 ,1 ,1 ,1 , 3461 & g_z,idat,idat,ivec,ivec) 3462 enddo ! end-loop-idat 3463 enddo ! end-loop-ivec 3464 endif ! end-if-indrm 3465 if (.not.ma_pop_stack(l_z)) 3466 $ call errquit('conv2complex2: pop problem with l_z', 3467 & 555,MA_ERR) 3468 if (.not.ma_pop_stack(l_xreim)) 3469 $ call errquit('conv2complex2: pop problem with l_xreim', 3470 & 555,MA_ERR) 3471 return 3472 end 3473 3474 subroutine conv2complex3(g_z, ! out: = complx(g_xre,g_xim) 3475 & g_xreim,! in : real arr 3476 & nvir, ! in : nr. virtual MOs 3477 & nocc, ! in : nr. occupied MOs 3478 & indrm) ! in : =1 -> re =2 -> im 3479c 3480c Purpose: Convert into complex array 3481c (g_xre,g_xim) --> g_z 3482c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3483c ipm=1,ncomp 3484c Usual values: nvec=3 (x,y,z) ncomp=2 3485c This routine does: g_z= g_xreim (copies either RE or IM) 3486c 3487c Author: Fredy W. Aquino, Northwestern University 3488c Date : 04-08-12 3489 3490 implicit none 3491#include "errquit.fh" 3492#include "mafdecls.fh" 3493#include "global.fh" 3494#include "util.fh" 3495#include "rtdb.fh" 3496 integer ipm,indrm, 3497 & ivec, 3498 & n,nvec, 3499 & l_xreim,k_xreim, 3500 & l_z,k_z, 3501 & nocc,nvir,i,j,j1,ioff 3502 integer g_xreim, 3503 & g_z,type 3504 double precision val_real,val_imag 3505 double complex val_cmplx,one_cmplx 3506 one_cmplx =dcmplx( 1.0d0,0.0d0) 3507 if (indrm.ne.1 .and. 3508 & indrm.ne.2) then 3509 call errquit('conv2complex2: indrm ne 1 or 2', 3510 & 0,MA_ERR) 3511 endif 3512 call ga_inquire(g_z,type,n,nvec) ! get (n,nvec) 3513 if (.not.MA_Push_Get(mt_dbl,nvir,'hessv jfacs',l_xreim,k_xreim)) 3514 & call errquit('conv2complex3: cannot allocate xreim', 3515 & nvir, MA_ERR) 3516 if (.not.MA_Push_Get(mt_dcpl,nvir,'hessv kfacs',l_z,k_z)) 3517 & call errquit('conv2complex3: cannot allocate z', 3518 & nvir, MA_ERR) 3519 if (indrm.eq.1) then ! updating only REAL part 3520 do ivec=1,nvec 3521 do i = ga_nodeid()+1,nocc,ga_nnodes() 3522 ioff = (i-1)*nvir + 1 3523 call ga_get(g_xreim,ioff,ioff+nvir-1,ivec,ivec, 3524 $ dbl_mb(k_xreim),nvir) 3525 call ga_get(g_z,ioff,ioff+nvir-1,ivec,ivec, 3526 $ dcpl_mb(k_z),nvir) 3527 do j=1,nvir 3528 j1=ioff+j-1 3529 val_imag =dimag(dcpl_mb(k_z+j-1)) 3530 val_cmplx=dcmplx(dbl_mb(k_xreim+j-1),val_imag) 3531 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3532 enddo ! end-loop-j 3533 enddo ! end-loop-i 3534 enddo ! end-loop-ivec 3535 else if (indrm.eq.2) then ! updating only IMAG part 3536 do ivec=1,nvec 3537 do i = ga_nodeid()+1,nocc,ga_nnodes() 3538 ioff = (i-1)*nvir + 1 3539 call ga_get(g_xreim,ioff,ioff+nvir-1,ivec,ivec, 3540 $ dbl_mb(k_xreim),nvir) 3541 call ga_get(g_z,ioff,ioff+nvir-1,ivec,ivec, 3542 $ dcpl_mb(k_z),nvir) 3543 do j=1,nvir 3544 j1=ioff+j-1 3545 val_real =dreal(dcpl_mb(k_z+j-1)) 3546 val_cmplx=dcmplx(val_real,dbl_mb(k_xreim+j-1)) 3547 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3548 enddo ! end-loop-j 3549 enddo ! end-loop-i 3550 enddo ! end-loop-ivec 3551 endif ! end-if-indrm 3552 if (.not.ma_pop_stack(l_z)) 3553 $ call errquit('conv2complex3: pop problem with l_z', 3554 & 555,MA_ERR) 3555 if (.not.ma_pop_stack(l_xreim)) 3556 $ call errquit('conv2complex3: pop problem with l_xreim', 3557 & 555,MA_ERR) 3558 return 3559 end 3560 3561 subroutine conv2complex4(g_z, ! out: = history matrix complex 3562 & g_xreim,! in : real arr 3563 & nsub, ! in : subblock index 3564 & ipm, ! in : = 1,2 to access slctd component 3565 & nvir, ! in : nr. virtual MOs 3566 & nocc, ! in : nr. occupied MOs 3567 & indrm) ! in : =1 -> re =2 -> im 3568c 3569c Purpose: Convert into complex array 3570c (g_xre,g_xim) --> g_z 3571c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3572c ipm=1,ncomp 3573c Usual values: nvec=3 (x,y,z) ncomp=2 3574c This routine does: g_z= g_xreim (copies either RE or IM) 3575c 3576c Author: Fredy W. Aquino, Northwestern University 3577c Date : 04-08-12 3578c 3579c dim(g_z) = (n1,maxsub) n1=n*ncomp maxsub=maxiter*nvec 3580c n=nocc*nvirt maxiter=10 (usually) nvec=3 (x,y,z) 3581c ncomp=2 3582 3583 implicit none 3584#include "errquit.fh" 3585#include "mafdecls.fh" 3586#include "global.fh" 3587#include "util.fh" 3588#include "rtdb.fh" 3589 integer ipm,indrm, 3590 & ivec,ivec1, 3591 & n,nvec, 3592 & l_xreim,k_xreim, 3593 & l_z,k_z,nsub, 3594 & nocc,nvir,i,j,j1, 3595 & ioff,ioff1,ioff2 3596 integer g_xreim, 3597 & g_z,type 3598 double precision val_real,val_imag 3599 double complex val_cmplx,one_cmplx 3600 one_cmplx =dcmplx( 1.0d0,0.0d0) 3601 if (indrm.ne.1 .and. 3602 & indrm.ne.2) then 3603 call errquit('conv2complex2: indrm ne 1 or 2', 3604 & 0,MA_ERR) 3605 endif 3606 call ga_inquire(g_xreim,type,n,nvec) ! get (n,nvec) 3607 if (.not.MA_Push_Get(mt_dbl,nvir,'hessv jfacs',l_xreim,k_xreim)) 3608 & call errquit('conv2complex3: cannot allocate xreim', 3609 & nvir, MA_ERR) 3610 if (.not.MA_Push_Get(mt_dcpl,nvir,'hessv kfacs',l_z,k_z)) 3611 & call errquit('conv2complex3: cannot allocate z', 3612 & nvir, MA_ERR) 3613 ioff1=(ipm-1)*n 3614 if (indrm.eq.1) then ! updating only REAL part 3615 ivec1=1 3616 do ivec=nsub+1,nsub+nvec 3617 do i = ga_nodeid()+1,nocc,ga_nnodes() 3618 ioff =(i-1)*nvir + 1 3619 ioff2=ioff1+ioff 3620 call ga_get(g_xreim,ioff,ioff+nvir-1,ivec1,ivec1, 3621 $ dbl_mb(k_xreim),nvir) 3622 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 3623 $ dcpl_mb(k_z),nvir) 3624 do j=1,nvir 3625 j1=ioff1+ioff+j-1 3626 val_imag =dimag(dcpl_mb(k_z+j-1)) 3627 val_cmplx=dcmplx(dbl_mb(k_xreim+j-1),val_imag) 3628 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3629 enddo ! end-loop-j 3630 enddo ! end-loop-i 3631 ivec1=ivec1+1 3632 enddo ! end-loop-ivec 3633 else if (indrm.eq.2) then ! updating only IMAG part 3634 ivec1=1 3635 do ivec=nsub+1,nsub+nvec 3636 do i = ga_nodeid()+1,nocc,ga_nnodes() 3637 ioff =(i-1)*nvir + 1 3638 ioff2=ioff1+ioff 3639 call ga_get(g_xreim,ioff,ioff+nvir-1,ivec1,ivec1, 3640 $ dbl_mb(k_xreim),nvir) 3641 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 3642 $ dcpl_mb(k_z),nvir) 3643 do j=1,nvir 3644 j1=ioff1+ioff+j-1 3645 val_real =dreal(dcpl_mb(k_z+j-1)) 3646 val_cmplx=dcmplx(val_real,dbl_mb(k_xreim+j-1)) 3647 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3648 enddo ! end-loop-j 3649 enddo ! end-loop-i 3650 ivec1=ivec1+1 3651 enddo ! end-loop-ivec 3652 endif ! end-if-indrm 3653 if (.not.ma_pop_stack(l_z)) 3654 $ call errquit('conv2complex3: pop problem with l_z', 3655 & 555,MA_ERR) 3656 if (.not.ma_pop_stack(l_xreim)) 3657 $ call errquit('conv2complex3: pop problem with l_xreim', 3658 & 555,MA_ERR) 3659 return 3660 end 3661 3662 subroutine conv2complex4_u( 3663 & g_z, ! out: = history matrix complex 3664 & g_xreim,! in : real arr 3665 & shift, ! in : = 0 spin 1, (nocc*nvir)(1) spin 2 3666 & nsub, ! in : subblock index 3667 & ipm, ! in : = 1,2 to access slctd component 3668 & nvir, ! in : nr. virtual MOs 3669 & nocc, ! in : nr. occupied MOs 3670 & indrm) ! in : =1 -> re =2 -> im 3671c 3672c Purpose: Convert into complex array 3673c (g_xre,g_xim) --> g_z 3674c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3675c ipm=1,ncomp 3676c Usual values: nvec=3 (x,y,z) ncomp=2 3677c This routine does: g_z= g_xreim (copies either RE or IM) 3678c 3679c Author: Fredy W. Aquino, Northwestern University 3680c Date : 04-08-12 3681c 3682c dim(g_z) = (n1,maxsub) n1=n*ncomp maxsub=maxiter*nvec 3683c n=nocc*nvirt maxiter=10 (usually) nvec=3 (x,y,z) 3684c ncomp=2 3685 3686 implicit none 3687#include "errquit.fh" 3688#include "mafdecls.fh" 3689#include "global.fh" 3690#include "util.fh" 3691#include "rtdb.fh" 3692 integer ipm,indrm, 3693 & ivec,ivec1, 3694 & n,nvec,shift, 3695 & l_xreim,k_xreim, 3696 & l_z,k_z,nsub, 3697 & nocc,nvir,i,j,j1, 3698 & ioff,ioff1,ioff2 3699 integer g_xreim, 3700 & g_z,type 3701 double precision val_real,val_imag 3702 double complex val_cmplx,one_cmplx 3703 one_cmplx =dcmplx( 1.0d0,0.0d0) 3704 if (indrm.ne.1 .and. 3705 & indrm.ne.2) then 3706 call errquit('conv2complex2: indrm ne 1 or 2', 3707 & 0,MA_ERR) 3708 endif 3709 call ga_inquire(g_xreim,type,n,nvec) ! get (n,nvec) 3710 if (.not.MA_Push_Get(mt_dbl,nvir,'hessv jfacs',l_xreim,k_xreim)) 3711 & call errquit('conv2complex3: cannot allocate xreim', 3712 & nvir, MA_ERR) 3713 if (.not.MA_Push_Get(mt_dcpl,nvir,'hessv kfacs',l_z,k_z)) 3714 & call errquit('conv2complex3: cannot allocate z', 3715 & nvir, MA_ERR) 3716 ioff1=shift+(ipm-1)*n 3717 if (indrm.eq.1) then ! updating only REAL part 3718 ivec1=1 3719 do ivec=nsub+1,nsub+nvec 3720 do i = ga_nodeid()+1,nocc,ga_nnodes() 3721 ioff =(i-1)*nvir + 1 3722 ioff2=ioff1+ioff 3723 call ga_get(g_xreim,ioff,ioff+nvir-1,ivec1,ivec1, 3724 $ dbl_mb(k_xreim),nvir) 3725 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 3726 $ dcpl_mb(k_z),nvir) 3727 do j=1,nvir 3728 j1=ioff1+ioff+j-1 3729 val_imag =dimag(dcpl_mb(k_z+j-1)) 3730 val_cmplx=dcmplx(dbl_mb(k_xreim+j-1),val_imag) 3731 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3732 enddo ! end-loop-j 3733 enddo ! end-loop-i 3734 ivec1=ivec1+1 3735 enddo ! end-loop-ivec 3736 else if (indrm.eq.2) then ! updating only IMAG part 3737 ivec1=1 3738 do ivec=nsub+1,nsub+nvec 3739 do i = ga_nodeid()+1,nocc,ga_nnodes() 3740 ioff =(i-1)*nvir + 1 3741 ioff2=ioff1+ioff 3742 call ga_get(g_xreim,ioff,ioff+nvir-1,ivec1,ivec1, 3743 $ dbl_mb(k_xreim),nvir) 3744 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 3745 $ dcpl_mb(k_z),nvir) 3746 do j=1,nvir 3747 j1=ioff1+ioff+j-1 3748 val_real =dreal(dcpl_mb(k_z+j-1)) 3749 val_cmplx=dcmplx(val_real,dbl_mb(k_xreim+j-1)) 3750 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3751 enddo ! end-loop-j 3752 enddo ! end-loop-i 3753 ivec1=ivec1+1 3754 enddo ! end-loop-ivec 3755 endif ! end-if-indrm 3756 if (.not.ma_pop_stack(l_z)) 3757 $ call errquit('conv2complex3: pop problem with l_z', 3758 & 555,MA_ERR) 3759 if (.not.ma_pop_stack(l_xreim)) 3760 $ call errquit('conv2complex3: pop problem with l_xreim', 3761 & 555,MA_ERR) 3762 return 3763 end 3764 3765 subroutine conv2complex4_u1( 3766 & g_z, ! out: = history matrix complex 3767 & g_xreim,! in : real arr 3768 & nsub, ! in : subblock index 3769 & ipm, ! in : = 1,2 to access slctd component 3770 & npol, ! in : nr. polarizations 3771 & nvir, ! in : nr. virtual MOs 3772 & nocc, ! in : nr. occupied MOs 3773 & indrm) ! in : =1 -> re =2 -> im 3774c 3775c Purpose: Convert into complex array 3776c (g_xre,g_xim) --> g_z 3777c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 3778c ipm=1,ncomp 3779c Usual values: nvec=3 (x,y,z) ncomp=2 3780c This routine does: g_z= g_xreim (copies either RE or IM) 3781c 3782c Author: Fredy W. Aquino, Northwestern University 3783c Date : 04-08-12 3784c 3785c dim(g_z) = (n1,maxsub) n1=n*ncomp maxsub=maxiter*nvec 3786c n=nocc*nvirt maxiter=10 (usually) nvec=3 (x,y,z) 3787c ncomp=2 3788 3789 implicit none 3790#include "errquit.fh" 3791#include "mafdecls.fh" 3792#include "global.fh" 3793#include "util.fh" 3794#include "rtdb.fh" 3795 integer ipm,indrm, 3796 & ivec,ivec1, 3797 & n,nvec,shift, 3798 & l_xreim,k_xreim, 3799 & l_z,k_z,nsub, 3800 & ipol,npol,nocc(npol),nvir(npol), 3801 & i,j,j1, 3802 & ioff,ioff1,ioff2 3803 integer g_xreim, 3804 & g_z,type 3805 double precision val_real,val_imag 3806 double complex val_cmplx,one_cmplx 3807 one_cmplx =dcmplx( 1.0d0,0.0d0) 3808 if (indrm.ne.1 .and. 3809 & indrm.ne.2) then 3810 call errquit('conv2complex2: indrm ne 1 or 2', 3811 & 0,MA_ERR) 3812 endif 3813 call ga_inquire(g_xreim,type,n,nvec) ! get (n,nvec) 3814 3815 ioff1=(ipm-1)*n 3816 if (indrm.eq.1) then ! updating only REAL part 3817 ivec1=1 3818 do ivec=nsub+1,nsub+nvec 3819 do ipol=1,npol 3820 if (.not.MA_Push_Get(mt_dbl,nvir(ipol),'hessv jfacs', 3821 & l_xreim,k_xreim)) 3822 & call errquit('conv2complex3: cannot allocate xreim', 3823 & nvir(ipol), MA_ERR) 3824 if (.not.MA_Push_Get(mt_dcpl,nvir(ipol),'hessv kfacs', 3825 & l_z,k_z)) 3826 & call errquit('conv2complex3: cannot allocate z', 3827 & nvir(ipol), MA_ERR) 3828 shift=nocc(1)*nvir(1)*(ipol-1) 3829 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 3830 ioff =shift+(i-1)*nvir(ipol) + 1 3831 ioff2=ioff1+ioff 3832 call ga_get(g_xreim,ioff,ioff+nvir(ipol)-1,ivec1,ivec1, 3833 $ dbl_mb(k_xreim),nvir(ipol)) 3834 call ga_get(g_z,ioff2,ioff2+nvir(ipol)-1,ivec,ivec, 3835 $ dcpl_mb(k_z),nvir(ipol)) 3836 do j=1,nvir(ipol) 3837 j1=ioff2+j-1 3838 val_imag =dimag(dcpl_mb(k_z+j-1)) 3839 val_cmplx=dcmplx(dbl_mb(k_xreim+j-1),val_imag) 3840 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3841 enddo ! end-loop-j 3842 enddo ! end-loop-i 3843 if (.not.ma_pop_stack(l_z)) 3844 $ call errquit('conv2complex3: pop problem with l_z', 3845 & 555,MA_ERR) 3846 if (.not.ma_pop_stack(l_xreim)) 3847 $ call errquit('conv2complex3: pop problem with l_xreim', 3848 & 555,MA_ERR) 3849 enddo ! end-loop-ipol 3850 ivec1=ivec1+1 3851 enddo ! end-loop-ivec 3852 else if (indrm.eq.2) then ! updating only IMAG part 3853 ivec1=1 3854 do ivec=nsub+1,nsub+nvec 3855 do ipol=1,npol 3856 if (.not.MA_Push_Get(mt_dbl,nvir(ipol),'hessv jfacs', 3857 & l_xreim,k_xreim)) 3858 & call errquit('conv2complex3: cannot allocate xreim', 3859 & nvir(ipol), MA_ERR) 3860 if (.not.MA_Push_Get(mt_dcpl,nvir(ipol),'hessv kfacs', 3861 & l_z,k_z)) 3862 & call errquit('conv2complex3: cannot allocate z', 3863 & nvir(ipol), MA_ERR) 3864 shift=nocc(1)*nvir(1)*(ipol-1) 3865 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 3866 ioff =shift+(i-1)*nvir(ipol) + 1 3867 ioff2=ioff1+ioff 3868 call ga_get(g_xreim,ioff,ioff+nvir(ipol)-1,ivec1,ivec1, 3869 $ dbl_mb(k_xreim),nvir(ipol)) 3870 call ga_get(g_z,ioff2,ioff2+nvir(ipol)-1,ivec,ivec, 3871 $ dcpl_mb(k_z),nvir(ipol)) 3872 do j=1,nvir(ipol) 3873 j1=ioff2+j-1 3874 val_real =dreal(dcpl_mb(k_z+j-1)) 3875 val_cmplx=dcmplx(val_real,dbl_mb(k_xreim+j-1)) 3876 call ga_put(g_z,j1,j1,ivec,ivec,val_cmplx,1) 3877 enddo ! end-loop-j 3878 enddo ! end-loop-i 3879 if (.not.ma_pop_stack(l_z)) 3880 $ call errquit('conv2complex3: pop problem with l_z', 3881 & 555,MA_ERR) 3882 if (.not.ma_pop_stack(l_xreim)) 3883 $ call errquit('conv2complex3: pop problem with l_xreim', 3884 & 555,MA_ERR) 3885 enddo ! end-loop-ipol 3886 ivec1=ivec1+1 3887 enddo ! end-loop-ivec 3888 endif ! end-if-indrm 3889 3890 return 3891 end 3892 3893 subroutine update_gz_reorim(g_z, ! out: = complx(g_xre,g_xim) 3894 & g_xreim,! in : real arr 3895 & indrm, ! in : =1 -> re =2 -> im 3896 & scl, ! in : scaling factor 3897 & nvir, 3898 & nocc, 3899 & ivec) 3900c 3901c Purpose: Convert into complex array 3902c (g_xre,g_xim) --> g_z 3903c structure of g_xre,g_xim: (n,nvec) n=nvir*nocc 3904c ipm=1,ncomp 3905c Usual values: nvec=3 (x,y,z) ncomp=2 3906c 3907c Author: Fredy W. Aquino, Northwestern University 3908c Date : 04-08-12 3909c 3910c Note.- To be used in rohf_hessv_2e3_opt_cmplx() 3911c located in ddscf/rohf_hessv3.F 3912c To mimic, 3913c call ga_mat_to_vec(g_tmp1,1,nvir,1,nclosed, 3914c $ g_ax_re(ipm),1,ivec,four,'+') [ scl=four RDFT] 3915c for complex g_z (instead of g_ax_re) 3916c g_xreim=g_tmp1 3917 3918 implicit none 3919#include "errquit.fh" 3920#include "mafdecls.fh" 3921#include "global.fh" 3922#include "util.fh" 3923#include "rtdb.fh" 3924 integer ipm,indrm, 3925 & ivec,idat,nvec, 3926 & n,n1,nvir,nocc, 3927 & l_xreim,k_xreim, 3928 & l_z,k_z,i,j,j1,ioff 3929 integer g_xreim, 3930 & g_z,g_a,type 3931 double precision scl 3932 double complex val_cmplx,one_cmplx,scl_cmplx 3933 one_cmplx =dcmplx(1.0d0,0.0d0) 3934 scl_cmplx =dcmplx(scl,0.0d0) 3935 if (indrm.ne.1 .and. 3936 & indrm.ne.2) then 3937 call errquit('conv2complex2: indrm ne 1 or 2', 3938 & 0,MA_ERR) 3939 endif 3940 if (.not. ga_create(MT_DCPL,1,1, 3941 & 'conv2complex2: A',0,0,g_a)) 3942 $ call errquit('solve_rlineq: failed allocating g_a', 3943 & 1,GA_ERR) 3944 call ga_inquire(g_z,type,n,nvec) ! get (n,nvec) 3945 if (.not.MA_Push_Get(mt_dbl,nvir,'hessv jfacs',l_xreim,k_xreim)) 3946 & call errquit('conv2complex2: cannot allocate xreim', 3947 & nvir, MA_ERR) 3948 if (.not.MA_Push_Get(mt_dcpl,nvir,'hessv kfacs',l_z,k_z)) 3949 & call errquit('conv2complex2: cannot allocate z', 3950 & nvir, MA_ERR) 3951 if (indrm.eq.1) then ! updating only REAL part 3952c ++++++++++++++++++ 3953c NOTE.- Assumming the ordering in dbl_mb(k_xreim) is same as in dcpl_mb(k_z) 3954c ++++++++++++++++++ 3955 do i = ga_nodeid()+1,nocc,ga_nnodes() 3956 ioff = (i-1)*nvir + 1 3957 call ga_get(g_xreim,1,nvir,i,i,dbl_mb(k_xreim),nvir) 3958 call ga_get(g_z,ioff,ioff+nvir-1,ivec,ivec, 3959 & dcpl_mb(k_z),nvir) 3960 do j=1,nvir 3961 val_cmplx=dcmplx(dbl_mb(k_xreim+j-1),0.0d0) 3962 call ga_put(g_a,1,1,1,1,val_cmplx,1) 3963 j1=ioff+j-1 3964 call ga_add_patch(one_cmplx,g_z,j1,j1,ivec,ivec, 3965 & scl_cmplx,g_a,1 ,1 ,1 ,1 , 3966 & g_z,j1,j1,ivec,ivec) 3967 enddo ! end-loop-j 3968 enddo ! end-loop-i 3969 else if (indrm.eq.2) then ! updating only IMAG part 3970 do i = ga_nodeid()+1,nocc,ga_nnodes() 3971 ioff = (i-1)*nvir + 1 3972 call ga_get(g_xreim,1,nvir,i,i,dbl_mb(k_xreim),nvir) 3973 call ga_get(g_z,ioff,ioff+nvir-1,ivec,ivec, 3974 & dcpl_mb(k_z),nvir) 3975 do j=1,nvir 3976 val_cmplx=dcmplx(0.0d0,dbl_mb(k_xreim+j-1)) 3977 call ga_put(g_a,1,1,1,1,val_cmplx,1) 3978 j1=ioff+j-1 3979 call ga_add_patch(one_cmplx,g_z,j1,j1,ivec,ivec, 3980 & scl_cmplx,g_a,1 ,1 ,1 ,1 , 3981 & g_z,j1,j1,ivec,ivec) 3982 enddo ! end-loop-j 3983 enddo ! end-loop-i 3984 endif ! end-if-indrm 3985 if (.not.ma_pop_stack(l_z)) 3986 $ call errquit('conv2complex2: pop problem with l_z', 3987 & 555,MA_ERR) 3988 if (.not.ma_pop_stack(l_xreim)) 3989 $ call errquit('conv2complex2: pop problem with l_xreim', 3990 & 555,MA_ERR) 3991 return 3992 end 3993 3994 subroutine update_gz_reorim1(g_z, ! out: = complx(g_xre,g_xim) 3995 & g_xreim,! in : real arr 3996 & indrm, ! in : =1 -> re =2 -> im 3997 & nsub, ! in : index to sub-block in g_z 3998 & ipm, ! in : = 1 or 2 index for component 3999 & n, ! in : = nocc*nvir 4000 & scl, ! in : scaling factor 4001 & nvir, 4002 & nocc, 4003 & ivec) 4004c 4005c Purpose: Convert into complex array 4006c (g_xre,g_xim) --> g_z 4007c structure of g_xre,g_xim: (n,nvec) n=nvir*nocc 4008c ipm=1,ncomp 4009c Usual values: nvec=3 (x,y,z) ncomp=2 4010c 4011c Author: Fredy W. Aquino, Northwestern University 4012c Date : 04-08-12 4013c Note.- To be used in rohf_hessv_2e3_opt_cmplx() 4014c located in ddscf/rohf_hessv3.F 4015c To mimic, 4016c call ga_mat_to_vec(g_tmp1,1,nvir,1,nclosed, 4017c $ g_ax_re(ipm),1,ivec,four,'+') [ scl=four RDFT] 4018c for complex g_z (instead of g_ax_re) 4019c g_xreim=g_tmp1 4020c g_z is history matrix of dim(n1,maxsub) 4021c n1=n*ncomp maxsub=maxiter*nvec 4022c n=nocc*nvir maxiter=10 (usually) nvec=3 (x,y,z) 4023 4024 implicit none 4025#include "errquit.fh" 4026#include "mafdecls.fh" 4027#include "global.fh" 4028#include "util.fh" 4029#include "rtdb.fh" 4030 integer ipm,indrm, 4031 & ivec,ivec1,nvec, 4032 & n,n1,nvir,nocc,nsub, 4033 & l_xreim,k_xreim, 4034 & l_z,k_z,i,j,j1,ioff,ioff1 4035 integer g_xreim, 4036 & g_z,type 4037 double precision scl,val_zre,val_zim 4038 double complex val_cmplx,one_cmplx,scl_cmplx 4039 one_cmplx =dcmplx(1.0d0,0.0d0) 4040 scl_cmplx =dcmplx(scl,0.0d0) 4041 if (indrm.ne.1 .and. 4042 & indrm.ne.2) then 4043 call errquit('update_gz_reorim1: indrm ne 1 or 2', 4044 & 0,MA_ERR) 4045 endif 4046 if (.not.MA_Push_Get(mt_dbl,nvir,'hessv jfacs',l_xreim,k_xreim)) 4047 & call errquit('conv2complex2: cannot allocate xreim', 4048 & nvir, MA_ERR) 4049 if (.not.MA_Push_Get(mt_dcpl,nvir,'hessv kfacs',l_z,k_z)) 4050 & call errquit('conv2complex2: cannot allocate z', 4051 & nvir, MA_ERR) 4052 ioff1=(ipm-1)*n 4053 ivec1=nsub+ivec 4054 if (indrm.eq.1) then ! updating only REAL part 4055c ++++++++++++++++++ 4056c NOTE.- Assumming the ordering in dbl_mb(k_xreim) is same as in dcpl_mb(k_z) 4057c ++++++++++++++++++ 4058 do i = ga_nodeid()+1,nocc,ga_nnodes() 4059 ioff1=(ipm-1)*n 4060 ivec1=nsub+ivec 4061 ioff = ioff1+(i-1)*nvir + 1 4062 call ga_get(g_xreim,1,nvir,i,i,dbl_mb(k_xreim),nvir) 4063 call ga_get(g_z,ioff,ioff+nvir-1,ivec1,ivec1, 4064 & dcpl_mb(k_z),nvir) 4065 do j=1,nvir 4066 val_zre=dreal(dcpl_mb(k_z+j-1)) 4067 val_zim=dimag(dcpl_mb(k_z+j-1)) 4068 val_cmplx=dcmplx(val_zre+scl*dbl_mb(k_xreim+j-1),val_zim) 4069 j1=ioff+j-1 4070 call ga_put(g_z,j1,j1,ivec1,ivec1,val_cmplx,1) 4071 enddo ! end-loop-j 4072 enddo ! end-loop-i 4073 else if (indrm.eq.2) then ! updating only IMAG part 4074 do i = ga_nodeid()+1,nocc,ga_nnodes() 4075 ioff = ioff1+(i-1)*nvir + 1 4076 call ga_get(g_xreim,1,nvir,i,i,dbl_mb(k_xreim),nvir) 4077 call ga_get(g_z,ioff,ioff+nvir-1,ivec1,ivec1, 4078 & dcpl_mb(k_z),nvir) 4079 do j=1,nvir 4080 val_zre=dreal(dcpl_mb(k_z+j-1)) 4081 val_zim=dimag(dcpl_mb(k_z+j-1)) 4082 val_cmplx=dcmplx(val_zre,val_zim+scl*dbl_mb(k_xreim+j-1)) 4083 j1=ioff+j-1 4084 call ga_put(g_z,j1,j1,ivec1,ivec1,val_cmplx,1) 4085 enddo ! end-loop-j 4086 enddo ! end-loop-i 4087 endif ! end-if-indrm 4088 if (.not.ma_pop_stack(l_z)) 4089 $ call errquit('conv2complex2: pop problem with l_z', 4090 & 555,MA_ERR) 4091 if (.not.ma_pop_stack(l_xreim)) 4092 $ call errquit('conv2complex2: pop problem with l_xreim', 4093 & 555,MA_ERR) 4094 return 4095 end 4096 4097 subroutine conv2reim(g_xre,! out : real arr 4098 & g_xim,! out : imaginary arr 4099 & g_z, ! in : = complx(g_xre,g_xim) 4100 & n, ! in : n rows 4101 & nvec, ! in : nvec columns 4102 & ncomp)! in : nr. components 4103c 4104c Purpose: Convert into (g_xre,g_xim) 4105c g_z -> (g_xre,g_xim) 4106c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4107c ipm=1,ncomp 4108c Usual values: nvec=3 (x,y,z) ncomp=2 4109c 4110c Author: Fredy W. Aquino, Northwestern University 4111c Date : 04-08-12 4112 4113 implicit none 4114#include "errquit.fh" 4115#include "mafdecls.fh" 4116#include "global.fh" 4117#include "util.fh" 4118#include "rtdb.fh" 4119 integer ipm,ivec,idat, 4120 & n,nvec,ncomp, 4121 & l_z,k_z 4122 integer g_xre(ncomp), 4123 & g_xim(ncomp),g_z(ncomp) 4124 double precision val_re,val_im 4125 4126 if (.not.MA_Push_Get(mt_dcpl,n,'conv2reim l_z', 4127 & l_z,k_z)) 4128 & call errquit('conv2complex: cannot allocate zre', 4129 & n, MA_ERR) 4130 do ipm=1,ncomp 4131 call ga_zero(g_xre(ipm)) 4132 call ga_zero(g_xim(ipm)) 4133 do ivec=1,nvec 4134 call ga_get(g_z(ipm),1,n,ivec,ivec,dcpl_mb(k_z),n) 4135 do idat=1,n 4136 val_re=dreal(dcpl_mb(k_z+idat-1)) 4137 val_im=dimag(dcpl_mb(k_z+idat-1)) 4138 call ga_put(g_xre(ipm),idat,idat,ivec,ivec,val_re,1) 4139 call ga_put(g_xim(ipm),idat,idat,ivec,ivec,val_im,1) 4140 enddo ! end-loop-idat 4141 enddo ! end-loop-ivec 4142 enddo ! end-loop-ipm 4143 if (.not.ma_pop_stack(l_z)) 4144 $ call errquit('conv2complex: pop problem with l_zim', 4145 & 555,MA_ERR) 4146 return 4147 end 4148 4149 subroutine conv2reim_rhs( 4150 & g_xre,! out : real arr 4151 & g_xim,! out : imaginary arr 4152 & g_z, ! in : = complx(g_xre,g_xim) 4153 & n, ! in : n rows 4154 & nvec, ! in : nvec columns 4155 & ncomp,! in : nr. components 4156 & nsub) ! in : =1,2=g_b,g_z index to subspace 4157c 4158c Purpose: Convert into (g_xre,g_xim) 4159c g_z -> (g_xre,g_xim) 4160c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4161c ipm=1,ncomp 4162c Usual values: nvec=3 (x,y,z) ncomp=2 4163c 4164c Author: Fredy W. Aquino, Northwestern University 4165c Date : 05-07-12 4166 4167 implicit none 4168#include "errquit.fh" 4169#include "mafdecls.fh" 4170#include "global.fh" 4171#include "util.fh" 4172#include "rtdb.fh" 4173 integer ipm,ivec,idat,nsub,shift,ivec1, 4174 & n,nvec,ncomp, 4175 & l_z,k_z 4176 integer g_xre(ncomp), 4177 & g_xim(ncomp),g_z(ncomp) 4178 double precision val_re,val_im 4179 4180 if (.not.MA_Push_Get(mt_dcpl,n,'conv2reim l_z', 4181 & l_z,k_z)) 4182 & call errquit('conv2complex: cannot allocate zre', 4183 & n, MA_ERR) 4184 shift=nvec*(nsub-1) 4185 do ipm=1,ncomp 4186 call ga_zero(g_xre(ipm)) 4187 call ga_zero(g_xim(ipm)) 4188 do ivec=1,nvec 4189 ivec1=shift+ivec 4190 call ga_get(g_z(ipm),1,n,ivec,ivec,dcpl_mb(k_z),1) 4191 do idat=1,n 4192 val_re=dreal(dcpl_mb(k_z+idat-1)) 4193 val_im=dimag(dcpl_mb(k_z+idat-1)) 4194 call ga_put(g_xre(ipm),idat,idat,ivec1,ivec1,val_re,1) 4195 call ga_put(g_xim(ipm),idat,idat,ivec1,ivec1,val_im,1) 4196 enddo ! end-loop-idat 4197 enddo ! end-loop-ivec 4198 enddo ! end-loop-ipm 4199 if (.not.ma_pop_stack(l_z)) 4200 $ call errquit('conv2complex: pop problem with l_zim', 4201 & 555,MA_ERR) 4202 return 4203 end 4204 4205 subroutine conv2reim1(g_xre,! out : real arr 4206 & g_xim,! out : imaginary arr 4207 & g_z, ! in : = complx(g_xre,g_xim) 4208 & nsub, ! in : pointer to block 4209 & nvir, ! in : nr. virtual MOs 4210 & nocc, ! in : nr. occupied MOs 4211 & ipm, ! in : =1,2 components indices 4212 & n, ! in : n rows 4213 & nvec) ! in : nvec columns 4214c 4215c Purpose: Extract into (g_xre,g_xim) 4216c g_z -> (g_xre,g_xim) 4217c g_z = g_zr1 or g_Az1 4218c dim(g_zr1)=(n1,nvec) nvec=3 (x,y and z) 4219c dim(g_Az1)=(n1,maxsub) maxsub=10*nvec 4220c n1=n*ncomp ncomp=2 (usually it stands for +/- solutions) 4221c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4222c ipm=1,ncomp 4223c For case g_z=g_zr1: nsub should be 0 4224c For case g_z=g_Az1: nsub should be real value 4225c Usual values: nvec=3 (x,y,z) ncomp=2 4226c 4227c Author: Fredy W. Aquino, Northwestern University 4228c Date : 04-21-12 4229 4230 implicit none 4231#include "errquit.fh" 4232#include "mafdecls.fh" 4233#include "global.fh" 4234#include "util.fh" 4235#include "rtdb.fh" 4236 integer ipm,ivec,ivec1, 4237 & a1,a2,b1,b2, 4238 & n,nvec,ncomp,nsub, 4239 & nocc,nvir,i,j,j1, 4240 & ioff,ioff1,ioff2, 4241 & l_z,k_z 4242 integer g_xre,g_xim,g_z 4243 double precision val_re,val_im 4244 4245 if (.not.MA_Push_Get(mt_dcpl,nvir,'conv2reim l_z', 4246 & l_z,k_z)) 4247 & call errquit('conv2complex: cannot allocate zre', 4248 & nvir, MA_ERR) 4249 call ga_zero(g_xre) 4250 call ga_zero(g_xim) 4251 a1=(ipm-1)*n+1 4252 a2=a1+n-1 4253 b1=nsub+1 4254 b2=nsub+nvec 4255 ivec1=1 4256 ioff1=(ipm-1)*n 4257 do ivec=b1,b2 4258 do i = ga_nodeid()+1,nocc,ga_nnodes() 4259 ioff = (i-1)*nvir + 1 4260 ioff2=ioff1+ioff 4261 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 4262 & dcpl_mb(k_z),nvir) 4263 do j=1,nvir 4264 j1=ioff+j-1 4265 val_re=dreal(dcpl_mb(k_z+j-1)) 4266 val_im=dimag(dcpl_mb(k_z+j-1)) 4267 call ga_put(g_xre,j1,j1,ivec1,ivec1,val_re,1) 4268 call ga_put(g_xim,j1,j1,ivec1,ivec1,val_im,1) 4269 enddo ! end-loop-j 4270 enddo ! end-loop-i 4271 ivec1=ivec1+1 4272 enddo ! end-loop-ivec 4273 if (.not.ma_pop_stack(l_z)) 4274 $ call errquit('conv2complex: pop problem with l_zim', 4275 & 555,MA_ERR) 4276 return 4277 end 4278 4279 subroutine conv2reim1_u( 4280 & g_xre,! out : real arr 4281 & g_xim,! out : imaginary arr 4282 & g_z, ! in : = complx(g_xre,g_xim) 4283 & nsub, ! in : pointer to block 4284 & npol, ! in : nr. polarizations 4285 & nvir, ! in : nr. virtual MOs 4286 & nocc, ! in : nr. occupied MOs 4287 & ipm, ! in : =1,2 components indices 4288 & n, ! in : n rows 4289 & nvec) ! in : nvec columns 4290c 4291c Purpose: Extract into (g_xre,g_xim) 4292c g_z -> (g_xre,g_xim) 4293c g_z = g_zr1 or g_Az1 4294c dim(g_zr1)=(n1,nvec) nvec=3 (x,y and z) 4295c dim(g_Az1)=(n1,maxsub) maxsub=10*nvec 4296c n1=n*ncomp ncomp=2 (usually it stands for +/- solutions) 4297c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4298c ipm=1,ncomp 4299c For case g_z=g_zr1: nsub should be 0 4300c For case g_z=g_Az1: nsub should be real value 4301c Usual values: nvec=3 (x,y,z) ncomp=2 4302c 4303c Author: Fredy W. Aquino, Northwestern University 4304c Date : 04-21-12 4305 4306 implicit none 4307#include "errquit.fh" 4308#include "mafdecls.fh" 4309#include "global.fh" 4310#include "util.fh" 4311#include "rtdb.fh" 4312 integer ipm,ivec,ivec1, 4313 & a1,a2,b1,b2, 4314 & n,nvec,ncomp,nsub, 4315 & ipol,npol, 4316 & nocc(npol),nvir(npol), 4317 & i,j,j1,shift, 4318 & ioff,ioff1,ioff2, 4319 & l_z,k_z 4320 integer g_xre,g_xim,g_z 4321 double precision val_re,val_im 4322 call ga_zero(g_xre) 4323 call ga_zero(g_xim) 4324 b1=nsub+1 4325 b2=nsub+nvec 4326 ivec1=1 4327 ioff1=(ipm-1)*n ! n=sum_{i=1,npol} (nocc*nvir)_i 4328 do ivec=b1,b2 4329 do ipol=1,npol 4330 if (.not.MA_Push_Get(mt_dcpl,nvir(ipol), 4331 & 'conv2reim l_z',l_z,k_z)) 4332 & call errquit('conv2complex: cannot allocate zre', 4333 & nvir(ipol), MA_ERR) 4334 shift=nocc(1)*nvir(1)*(ipol-1) 4335 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 4336 ioff = shift+(i-1)*nvir(ipol) + 1 4337 ioff2=ioff1+ioff 4338 call ga_get(g_z,ioff2,ioff2+nvir(ipol)-1,ivec,ivec, 4339 & dcpl_mb(k_z),nvir(ipol)) 4340 do j=1,nvir(ipol) 4341 j1=ioff+j-1 4342 val_re=dreal(dcpl_mb(k_z+j-1)) 4343 val_im=dimag(dcpl_mb(k_z+j-1)) 4344 call ga_put(g_xre,j1,j1,ivec1,ivec1,val_re,1) 4345 call ga_put(g_xim,j1,j1,ivec1,ivec1,val_im,1) 4346 enddo ! end-loop-j 4347 enddo ! end-loop-i 4348 if (.not.ma_pop_stack(l_z)) 4349 $ call errquit('conv2complex: pop problem with l_zim', 4350 & 555,MA_ERR) 4351 enddo ! end-loop-ipol 4352 ivec1=ivec1+1 4353 enddo ! end-loop-ivec 4354 4355 return 4356 end 4357 4358 subroutine getreorim(g_xreim,! out : real or im arr 4359 & g_z, ! in : = complx(g_xre,g_xim) 4360 & nvir, ! in : nr. virtual MOs 4361 & nocc, ! in : nr. occupied MOs 4362 & indrm) ! in : =1 -> re =2 -> im 4363c 4364c Purpose: Convert into (g_xre,g_xim) 4365c g_z -> (g_xre,g_xim) 4366c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4367c ipm=1,ncomp 4368c Usual values: nvec=3 (x,y,z) ncomp=2 4369c 4370c Author: Fredy W. Aquino, Northwestern University 4371c Date : 04-08-12 4372c --> This only works for closed shell where we have one single 4373c set of (nvir,nocc) 4374 4375 implicit none 4376#include "errquit.fh" 4377#include "mafdecls.fh" 4378#include "global.fh" 4379#include "util.fh" 4380#include "rtdb.fh" 4381 integer ipm,ivec,indrm, 4382 & n,nvec, ! obtained from ga_inquire(g_z) 4383 & ncomp, 4384 & l_z,k_z 4385 integer g_xreim,g_z,type, 4386 & i,j,j1,ioff,nocc,nvir 4387 double precision val_re,val_im 4388 if (indrm.ne.1 .and. 4389 & indrm.ne.2) then 4390 call errquit('getreorim: indrm ne 1 or 2', 4391 & 0,MA_ERR) 4392 endif 4393 call ga_inquire(g_z,type,n,nvec) ! get (n,nvec) 4394 if (.not.MA_Push_Get(mt_dcpl,nvir,'conv2reim l_z', 4395 & l_z,k_z)) 4396 & call errquit('getreorim: cannot allocate k_z', 4397 & nvir, MA_ERR) 4398 call ga_zero(g_xreim) 4399 if (indrm.eq.1) then ! copying only REAL part 4400 do ivec=1,nvec 4401 do i = ga_nodeid()+1,nocc,ga_nnodes() 4402 ioff = (i-1)*nvir + 1 4403 call ga_get(g_z,ioff,ioff+nvir-1,ivec,ivec, 4404 & dcpl_mb(k_z),nvir) 4405 do j=1,nvir 4406 val_re=dreal(dcpl_mb(k_z+j-1)) 4407 j1=ioff+j-1 4408 call ga_put(g_xreim,j1,j1,ivec,ivec,val_re,1) 4409 enddo ! end-loop-j 4410 enddo ! end-loop-i 4411 enddo ! end-loop-ivec 4412 else if (indrm.eq.2) then ! copying only IMAG part 4413 do ivec=1,nvec 4414 do i = ga_nodeid()+1,nocc,ga_nnodes() 4415 ioff = (i-1)*nvir + 1 4416 call ga_get(g_z,ioff,ioff+nvir-1,ivec,ivec, 4417 $ dcpl_mb(k_z),nvir) 4418 do j=1,nvir 4419 val_im=dimag(dcpl_mb(k_z+j-1)) 4420 j1=ioff+j-1 4421 call ga_put(g_xreim,j1,j1,ivec,ivec,val_im,1) 4422 enddo ! end-loop-j 4423 enddo ! end-loop-i 4424 enddo ! end-loop-ivec 4425 endif ! end-if-indrm 4426 if (.not.ma_pop_stack(l_z)) 4427 $ call errquit('getreorim: pop problem with l_zim', 4428 & 555,MA_ERR) 4429 return 4430 end 4431 4432 subroutine getreorim_u(g_xreim,! out : real or im arr 4433 & g_z, ! in : = complx(g_xre,g_xim) 4434 & shift, ! in : = 0 -> ipol=1, nocc*nvirt(1) -> ipol=2 4435 & nvir, ! in : nr. virtual MOs 4436 & nocc, ! in : nr. occupied MOs 4437 & indrm) ! in : =1 -> re =2 -> im 4438c 4439c Purpose: Convert into (g_xre,g_xim) 4440c g_z -> (g_xre,g_xim) 4441c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4442c ipm=1,ncomp 4443c Usual values: nvec=3 (x,y,z) ncomp=2 4444c 4445c Author: Fredy W. Aquino, Northwestern University 4446c Date : 04-08-12 4447c --> This only works for closed shell where we have one single 4448c set of (nvir,nocc) 4449 4450 implicit none 4451#include "errquit.fh" 4452#include "mafdecls.fh" 4453#include "global.fh" 4454#include "util.fh" 4455#include "rtdb.fh" 4456 integer ipm,ivec,indrm, 4457 & n,nvec, ! obtained from ga_inquire(g_z) 4458 & ncomp, 4459 & l_z,k_z 4460 integer g_xreim,g_z,type, 4461 & i,j,j1,ioff,ioff2,nocc,nvir, 4462 & shift 4463 double precision val_re,val_im 4464 if (indrm.ne.1 .and. 4465 & indrm.ne.2) then 4466 call errquit('getreorim: indrm ne 1 or 2', 4467 & 0,MA_ERR) 4468 endif 4469 call ga_inquire(g_z,type,n,nvec) ! get (n,nvec) 4470 if (.not.MA_Push_Get(mt_dcpl,nvir,'conv2reim l_z', 4471 & l_z,k_z)) 4472 & call errquit('getreorim: cannot allocate k_z', 4473 & nvir, MA_ERR) 4474 call ga_zero(g_xreim) 4475 if (indrm.eq.1) then ! copying only REAL part 4476 do ivec=1,nvec 4477 do i = ga_nodeid()+1,nocc,ga_nnodes() 4478 ioff = (i-1)*nvir + 1 4479 ioff2 = shift+ioff 4480 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 4481 & dcpl_mb(k_z),nvir) 4482 do j=1,nvir 4483 val_re=dreal(dcpl_mb(k_z+j-1)) 4484 j1=ioff+j-1 4485 call ga_put(g_xreim,j1,j1,ivec,ivec,val_re,1) 4486 enddo ! end-loop-j 4487 enddo ! end-loop-i 4488 enddo ! end-loop-ivec 4489 else if (indrm.eq.2) then ! copying only IMAG part 4490 do ivec=1,nvec 4491 do i = ga_nodeid()+1,nocc,ga_nnodes() 4492 ioff = (i-1)*nvir + 1 4493 ioff2 = shift+ioff 4494 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 4495 $ dcpl_mb(k_z),nvir) 4496 do j=1,nvir 4497 val_im=dimag(dcpl_mb(k_z+j-1)) 4498 j1=ioff+j-1 4499 call ga_put(g_xreim,j1,j1,ivec,ivec,val_im,1) 4500 enddo ! end-loop-j 4501 enddo ! end-loop-i 4502 enddo ! end-loop-ivec 4503 endif ! end-if-indrm 4504 if (.not.ma_pop_stack(l_z)) 4505 $ call errquit('getreorim: pop problem with l_zim', 4506 & 555,MA_ERR) 4507 return 4508 end 4509 4510 subroutine getreorim_u1( 4511 & g_xreim,! out : real or im arr 4512 & g_z, ! in : = complx(g_xre,g_xim) 4513 & npol, ! in : nr. polarizations 4514 & nvir, ! in : nr. virtual MOs 4515 & nocc, ! in : nr. occupied MOs 4516 & indrm) ! in : =1 -> re =2 -> im 4517c 4518c Purpose: Convert into (g_xre,g_xim) 4519c g_z -> (g_xre,g_xim) 4520c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4521c ipm=1,ncomp 4522c Usual values: nvec=3 (x,y,z) ncomp=2 4523c 4524c Author: Fredy W. Aquino, Northwestern University 4525c Date : 04-08-12 4526c --> This only works for closed shell where we have one single 4527c set of (nvir,nocc) 4528 4529 implicit none 4530#include "errquit.fh" 4531#include "mafdecls.fh" 4532#include "global.fh" 4533#include "util.fh" 4534#include "rtdb.fh" 4535 integer ipm,ivec,indrm, 4536 & n,nvec, ! obtained from ga_inquire(g_z) 4537 & ncomp, 4538 & l_z,k_z 4539 integer g_xreim,g_z,type, 4540 & i,j,j1,ioff, 4541 & ipol,npol,nocc(npol),nvir(npol), 4542 & shift 4543 double precision val_re,val_im 4544 if (indrm.ne.1 .and. 4545 & indrm.ne.2) then 4546 call errquit('getreorim: indrm ne 1 or 2', 4547 & 0,MA_ERR) 4548 endif 4549 call ga_inquire(g_z,type,n,nvec) ! get (n,nvec) 4550 call ga_zero(g_xreim) 4551 if (indrm.eq.1) then ! copying only REAL part 4552 do ivec=1,nvec 4553 do ipol=1,npol 4554 if (.not.MA_Push_Get(mt_dcpl,nvir(ipol), 4555 & 'conv2reim l_z',l_z,k_z)) 4556 & call errquit('getreorim: cannot allocate k_z', 4557 & nvir(ipol), MA_ERR) 4558 shift=nocc(1)*nvir(1)*(ipol-1) 4559 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 4560 ioff = shift+(i-1)*nvir(ipol) + 1 4561 call ga_get(g_z,ioff,ioff+nvir(ipol)-1,ivec,ivec, 4562 & dcpl_mb(k_z),nvir(ipol)) 4563 do j=1,nvir(ipol) 4564 val_re=dreal(dcpl_mb(k_z+j-1)) 4565 j1=ioff+j-1 4566 call ga_put(g_xreim,j1,j1,ivec,ivec,val_re,1) 4567 enddo ! end-loop-j 4568 enddo ! end-loop-i 4569 if (.not.ma_pop_stack(l_z)) 4570 $ call errquit('getreorim: pop problem with l_zim', 4571 & 555,MA_ERR) 4572 enddo ! end-loop-ipol 4573 enddo ! end-loop-ivec 4574 else if (indrm.eq.2) then ! copying only IMAG part 4575 do ivec=1,nvec 4576 do ipol=1,npol 4577 if (.not.MA_Push_Get(mt_dcpl,nvir(ipol), 4578 & 'conv2reim l_z',l_z,k_z)) 4579 & call errquit('getreorim: cannot allocate k_z', 4580 & nvir(ipol), MA_ERR) 4581 shift=nocc(1)*nvir(1)*(ipol-1) 4582 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 4583 ioff = shift+(i-1)*nvir(ipol) + 1 4584 call ga_get(g_z,ioff,ioff+nvir(ipol)-1,ivec,ivec, 4585 $ dcpl_mb(k_z),nvir(ipol)) 4586 do j=1,nvir(ipol) 4587 val_im=dimag(dcpl_mb(k_z+j-1)) 4588 j1=ioff+j-1 4589 call ga_put(g_xreim,j1,j1,ivec,ivec,val_im,1) 4590 enddo ! end-loop-j 4591 enddo ! end-loop-i 4592 if (.not.ma_pop_stack(l_z)) 4593 $ call errquit('getreorim: pop problem with l_zim', 4594 & 555,MA_ERR) 4595 enddo ! end-loop-ipol 4596 enddo ! end-loop-ivec 4597 endif ! end-if-indrm 4598 4599 return 4600 end 4601 4602 subroutine getreorim1(g_xreim,! out : real or im arr 4603 & g_z, ! in : = complx(g_xre,g_xim) 4604 & nsub, ! in : subblock index 4605 & ipm, ! in : = 1,2 to access slctd component 4606 & nvir, ! in : nr. virtual MOs 4607 & nocc, ! in : nr. occupied MOs 4608 & indrm) ! in : =1 -> re =2 -> im 4609c 4610c Purpose: Convert into (g_xre,g_xim) 4611c g_z -> (g_xre,g_xim) 4612c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4613c ipm=1,ncomp 4614c Usual values: nvec=3 (x,y,z) ncomp=2 4615c 4616c Author: Fredy W. Aquino, Northwestern University 4617c Date : 04-24-12 4618c g_z : history matrix (g_Az1 or g_z1) 4619 4620 implicit none 4621#include "errquit.fh" 4622#include "mafdecls.fh" 4623#include "global.fh" 4624#include "util.fh" 4625#include "rtdb.fh" 4626 integer ipm,ivec,ivec1,indrm, 4627 & n,nvec, ! obtained from ga_inquire(g_z) 4628 & ncomp,nsub, 4629 & l_z,k_z 4630 integer g_xreim,g_z,type, 4631 & i,j,j1,ioff,ioff1,ioff2,nocc,nvir 4632 double precision val_re,val_im 4633 if (indrm.ne.1 .and. 4634 & indrm.ne.2) then 4635 call errquit('getreorim1: indrm ne 1 or 2', 4636 & 0,MA_ERR) 4637 endif 4638 call ga_inquire(g_xreim,type,n,nvec) ! get (n,nvec) 4639 4640 if (.not.MA_Push_Get(mt_dcpl,nvir,'conv2reim l_z', 4641 & l_z,k_z)) 4642 & call errquit('getreorim: cannot allocate k_z', 4643 & nvir, MA_ERR) 4644 call ga_zero(g_xreim) 4645 if (indrm.eq.1) then ! copying only REAL part 4646 ivec1=1 4647 ioff1=(ipm-1)*n 4648 do ivec=nsub+1,nsub+nvec 4649 do i = ga_nodeid()+1,nocc,ga_nnodes() 4650 ioff = (i-1)*nvir + 1 4651 ioff2=ioff1+ioff 4652 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 4653 & dcpl_mb(k_z),nvir) 4654 do j=1,nvir 4655 val_re=dreal(dcpl_mb(k_z+j-1)) 4656 j1=ioff+j-1 4657 call ga_put(g_xreim,j1,j1,ivec1,ivec1,val_re,1) 4658 enddo ! end-loop-j 4659 enddo ! end-loop-i 4660 ivec1=ivec1+1 4661 enddo ! end-loop-ivec 4662 else if (indrm.eq.2) then ! copying only IMAG part 4663 ivec1=1 4664 ioff1=(ipm-1)*n 4665 do ivec=nsub+1,nsub+nvec 4666 do i = ga_nodeid()+1,nocc,ga_nnodes() 4667 ioff = (i-1)*nvir + 1 4668 ioff2=ioff1+ioff 4669 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 4670 $ dcpl_mb(k_z),nvir) 4671 do j=1,nvir 4672 val_im=dimag(dcpl_mb(k_z+j-1)) 4673 j1=ioff+j-1 4674 call ga_put(g_xreim,j1,j1,ivec1,ivec1,val_im,1) 4675 enddo ! end-loop-j 4676 enddo ! end-loop-i 4677 ivec1=ivec1+1 4678 enddo ! end-loop-ivec 4679 endif ! end-if-indrm 4680 if (.not.ma_pop_stack(l_z)) 4681 $ call errquit('getreorim: pop problem with l_zim', 4682 & 555,MA_ERR) 4683 return 4684 end 4685 4686 subroutine getreorim1_u1( 4687 & g_xreim,! out : real or im arr 4688 & g_z, ! in : = complx(g_xre,g_xim) 4689 & nsub, ! in : subblock index 4690 & ipm, ! in : = 1,2 to access slctd component 4691 & npol, 4692 & nvir, ! in : nr. virtual MOs 4693 & nocc, ! in : nr. occupied MOs 4694 & indrm) ! in : =1 -> re =2 -> im 4695c 4696c Purpose: Convert into (g_xre,g_xim) 4697c g_z -> (g_xre,g_xim) 4698c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4699c ipm=1,ncomp 4700c Usual values: nvec=3 (x,y,z) ncomp=2 4701c 4702c Author: Fredy W. Aquino, Northwestern University 4703c Date : 04-24-12 4704c g_z : history matrix (g_Az1 or g_z1) 4705 4706 implicit none 4707#include "errquit.fh" 4708#include "mafdecls.fh" 4709#include "global.fh" 4710#include "util.fh" 4711#include "rtdb.fh" 4712 integer ipm,ivec,ivec1,indrm, 4713 & n,nvec, ! obtained from ga_inquire(g_z) 4714 & ncomp,nsub, 4715 & l_z,k_z 4716 integer g_xreim,g_z,type, 4717 & i,j,j1,ioff,ioff1,ioff2, 4718 & ipol,npol,nocc(npol),nvir(npol), 4719 & shift 4720 double precision val_re,val_im 4721 if (indrm.ne.1 .and. 4722 & indrm.ne.2) then 4723 call errquit('getreorim1_u1: indrm ne 1 or 2', 4724 & 0,MA_ERR) 4725 endif 4726 call ga_inquire(g_xreim,type,n,nvec) ! get (n,nvec) 4727 call ga_zero(g_xreim) 4728 if (indrm.eq.1) then ! copying only REAL part 4729 ivec1=1 4730 ioff1=(ipm-1)*n ! n=sum_{i=1,npol} (nocc*nvir)(i) 4731 do ivec=nsub+1,nsub+nvec 4732 do ipol=1,npol 4733 if (.not.MA_Push_Get(mt_dcpl,nvir(ipol),'conv2reim l_z', 4734 & l_z,k_z)) 4735 & call errquit('getreorim: cannot allocate k_z', 4736 & nvir(ipol), MA_ERR) 4737 shift=nocc(1)*nvir(1)*(ipol-1) 4738 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 4739 ioff = shift+(i-1)*nvir(ipol) + 1 4740 ioff2=ioff1+ioff 4741 call ga_get(g_z,ioff2,ioff2+nvir(ipol)-1,ivec,ivec, 4742 & dcpl_mb(k_z),1) 4743 do j=1,nvir(ipol) 4744 val_re=dreal(dcpl_mb(k_z+j-1)) 4745 j1=ioff+j-1 4746 call ga_put(g_xreim,j1,j1,ivec1,ivec1,val_re,1) 4747 enddo ! end-loop-j 4748 enddo ! end-loop-i 4749 if (.not.ma_pop_stack(l_z)) 4750 $ call errquit('getreorim: pop problem with l_zim', 4751 & 555,MA_ERR) 4752 enddo ! end-loop-ipol 4753 ivec1=ivec1+1 4754 enddo ! end-loop-ivec 4755 else if (indrm.eq.2) then ! copying only IMAG part 4756 ivec1=1 4757 ioff1=(ipm-1)*n 4758 do ivec=nsub+1,nsub+nvec 4759 do ipol=1,npol 4760 if (.not.MA_Push_Get(mt_dcpl,nvir(ipol),'conv2reim l_z', 4761 & l_z,k_z)) 4762 & call errquit('getreorim: cannot allocate k_z', 4763 & nvir(ipol), MA_ERR) 4764 shift=nocc(1)*nvir(1)*(ipol-1) 4765 do i = ga_nodeid()+1,nocc(ipol),ga_nnodes() 4766 ioff = shift+(i-1)*nvir(ipol) + 1 4767 ioff2=ioff1+ioff 4768 call ga_get(g_z,ioff2,ioff2+nvir(ipol)-1,ivec,ivec, 4769 $ dcpl_mb(k_z),1) 4770 do j=1,nvir(ipol) 4771 val_im=dimag(dcpl_mb(k_z+j-1)) 4772 j1=ioff+j-1 4773 call ga_put(g_xreim,j1,j1,ivec1,ivec1,val_im,1) 4774 enddo ! end-loop-j 4775 enddo ! end-loop-i 4776 if (.not.ma_pop_stack(l_z)) 4777 $ call errquit('getreorim: pop problem with l_zim', 4778 & 555,MA_ERR) 4779 enddo ! end-loop-ipol 4780 ivec1=ivec1+1 4781 enddo ! end-loop-ivec 4782 endif ! end-if-indrm 4783 return 4784 end 4785 4786 subroutine getreorim1_u( 4787 & g_xreim,! out : real or im arr 4788 & g_z, ! in : = complx(g_xre,g_xim) 4789 & nsub, ! in : subblock index 4790 & shift, ! in : = 0 for spin 1 ncomp*(nocc*nvir)(1) for spin 2 4791 & ipm, ! in : = 1,2 to access slctd component 4792 & nvir, ! in : nr. virtual MOs 4793 & nocc, ! in : nr. occupied MOs 4794 & indrm) ! in : =1 -> re =2 -> im 4795c 4796c Purpose: Convert into (g_xre,g_xim) 4797c g_z -> (g_xre,g_xim) 4798c structure of g_xre(ipm),g_xim(ipm): (n,nvec) 4799c ipm=1,ncomp 4800c Usual values: nvec=3 (x,y,z) ncomp=2 4801c 4802c Author: Fredy W. Aquino, Northwestern University 4803c Date : 04-24-12 4804c g_z : history matrix (g_Az1 or g_z1) 4805 4806 implicit none 4807#include "errquit.fh" 4808#include "mafdecls.fh" 4809#include "global.fh" 4810#include "util.fh" 4811#include "rtdb.fh" 4812 integer ipm,ivec,ivec1,indrm, 4813 & n,nvec, ! obtained from ga_inquire(g_z) 4814 & ncomp,nsub,shift, 4815 & l_z,k_z 4816 integer g_xreim,g_z,type, 4817 & i,j,j1,ioff,ioff1,ioff2,nocc,nvir 4818 double precision val_re,val_im 4819 if (indrm.ne.1 .and. 4820 & indrm.ne.2) then 4821 call errquit('getreorim1: indrm ne 1 or 2', 4822 & 0,MA_ERR) 4823 endif 4824 call ga_inquire(g_xreim,type,n,nvec) ! get (n,nvec) 4825 4826 if (.not.MA_Push_Get(mt_dcpl,nvir,'conv2reim l_z', 4827 & l_z,k_z)) 4828 & call errquit('getreorim: cannot allocate k_z', 4829 & nvir, MA_ERR) 4830 call ga_zero(g_xreim) 4831 if (indrm.eq.1) then ! copying only REAL part 4832 ivec1=1 4833 ioff1=(ipm-1)*n+shift 4834 do ivec=nsub+1,nsub+nvec 4835 do i = ga_nodeid()+1,nocc,ga_nnodes() 4836 ioff = (i-1)*nvir + 1 4837 ioff2=ioff1+ioff 4838 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 4839 & dcpl_mb(k_z),1) 4840 do j=1,nvir 4841 val_re=dreal(dcpl_mb(k_z+j-1)) 4842 j1=ioff+j-1 4843 call ga_put(g_xreim,j1,j1,ivec1,ivec1,val_re,1) 4844 enddo ! end-loop-j 4845 enddo ! end-loop-i 4846 ivec1=ivec1+1 4847 enddo ! end-loop-ivec 4848 else if (indrm.eq.2) then ! copying only IMAG part 4849 ivec1=1 4850 ioff1=shift+(ipm-1)*n 4851 do ivec=nsub+1,nsub+nvec 4852 do i = ga_nodeid()+1,nocc,ga_nnodes() 4853 ioff = (i-1)*nvir + 1 4854 ioff2=ioff1+ioff 4855 call ga_get(g_z,ioff2,ioff2+nvir-1,ivec,ivec, 4856 $ dcpl_mb(k_z),1) 4857 do j=1,nvir 4858 val_im=dimag(dcpl_mb(k_z+j-1)) 4859 j1=ioff+j-1 4860 call ga_put(g_xreim,j1,j1,ivec1,ivec1,val_im,1) 4861 enddo ! end-loop-j 4862 enddo ! end-loop-i 4863 ivec1=ivec1+1 4864 enddo ! end-loop-ivec 4865 endif ! end-if-indrm 4866 if (.not.ma_pop_stack(l_z)) 4867 $ call errquit('getreorim: pop problem with l_zim', 4868 & 555,MA_ERR) 4869 return 4870 end 4871 4872 subroutine updating_Az1_z1_zr1( 4873 & g_Az1, ! in/ou: 4874 & g_z1, ! in/ou: 4875 & g_zr1, ! in/ou: 4876 & g_Az, ! in : 4877 & g_z, ! in : 4878 & g_zr, ! in : 4879 & nvec, ! in : 4880 & ncomp, ! in : 4881 & nsub, ! in : 4882 & n) ! in : 4883c 4884c Author : Fredy W. Aquino, Northwestern University 4885c Purpose: Update (g_Az1,g_z1,g_zr1) 4886c Date : 03-15-12 4887 4888 implicit none 4889#include "errquit.fh" 4890#include "mafdecls.fh" 4891#include "global.fh" 4892#include "util.fh" 4893#include "rtdb.fh" 4894 integer ncomp,nvec,nsub,n 4895 integer g_Az1,g_z1,g_zr1, 4896 & g_Az(ncomp), 4897 & g_z(ncomp), 4898 & g_zr(ncomp) 4899 integer p1,p2,m1,m2,ipm 4900 p1=nsub+1 4901 p2=nsub+nvec 4902 m1=1 4903 m2=n 4904 do ipm=1,ncomp 4905 call ga_copy_patch('n',g_Az(ipm),1 ,n ,1 ,nvec, 4906 $ g_Az1 ,m1,m2,p1,p2) 4907 call ga_copy_patch('n',g_z(ipm) ,1 ,n ,1 ,nvec, 4908 $ g_z1 ,m1,m2,p1,p2) 4909 call ga_copy_patch('n',g_zr(ipm),1 ,n ,1 ,nvec, 4910 $ g_zr1 ,m1,m2,1 ,nvec) 4911 m1=m1+n 4912 m2=m2+n 4913 enddo ! end-loop-ipm 4914 return 4915 end 4916c -------------- solve_rlineq ---------------- START 4917 subroutine solve_xlineq( 4918 & g_x, ! in/out: updated solution 4919 & g_Ax1, ! in : history of g_Az 4920 & g_x1, ! in : history of g_z 4921 & g_xr1, ! in : history of g_zr 4922 & nsub, ! in : subspace length 4923 & nvec, ! in : increment of subspace 4924 & ncomp, ! in : nr. components 4925 & n, ! in : nr. elements per comp. 4926 & iter, ! in : iteration nr. 4927 & debug1)! in : =.true. show debug printouts 4928c 4929c Author : Fredy W. Aquino, Northwestern University 4930c Purpose: Solve 'complex' linear equation using real 'history' GA arrays 4931c 4932c Date : 03-15-12 4933c 4934c dim(g_Az1)=dim(z1)=(ncomp*n,maxsub) 4935c dim(g_zr1)=(ncomp*n,nvec) 4936 4937 implicit none 4938#include "errquit.fh" 4939#include "mafdecls.fh" 4940#include "global.fh" 4941#include "util.fh" 4942#include "rtdb.fh" 4943 integer nsub,nvec,ncomp,n,n1,iter,ipm 4944 integer g_a,g_b,g_c, 4945 & g_x1,g_Ax1,g_xr1, 4946 & g_x(ncomp) 4947 logical debug1 4948 double precision one,mone,zero 4949 parameter (one=1.0d0,mone=-1.0d0,zero=0.0d0) 4950 external ga_svd_solve_seq,update_g_x 4951c Form and solve the subspace equations using SVD in order 4952c to manage near linear dependence in the subspace. 4953 n1=ncomp*n 4954 if (.not. ga_create(MT_DBL, nsub, nsub, 4955 & 'solve_rlineq: A',0,0,g_a)) 4956 $ call errquit('solve_rlineq: failed allocating g_a', 4957 & nsub,GA_ERR) 4958 if (.not. ga_create(MT_DBL, nsub, nvec, 4959 & 'solve_rlineq: B',0,0,g_b)) 4960 $ call errquit('solve_rlineq: failed allocating g_b', 4961 & nsub,GA_ERR) 4962 if (.not. ga_create(MT_DBL, nsub, nvec, 4963 & 'solve_rlineq: C',0,0,g_c)) 4964 $ call errquit('solve_rlineq: failed allocating g_c', 4965 & nsub,GA_ERR) 4966 call ga_zero(g_a) 4967 call ga_zero(g_b) 4968 call ga_zero(g_c) 4969 4970 if (debug1) then 4971 if (ga_nodeid().eq.0) 4972 & write(*,*) '-------BEF:g_x1(',iter,')-------START' 4973 call ga_print(g_x1) 4974 if (ga_nodeid().eq.0) 4975 & write(*,*) '-------BEF:g_x1(',iter,')-------END' 4976 endif ! end-if-debug1 4977 call ga_dgemm('t','n',nsub,nsub,n1,one, 4978 & g_x1,g_Ax1,zero,g_a) 4979 call ga_dgemm('t','n',nsub,nvec,n1,one, 4980 & g_x1,g_xr1,zero,g_b) 4981 4982 if (debug1) then 4983 if (ga_nodeid().eq.0) 4984 & write(*,*) '-------g_a--------START' 4985 call ga_print(g_a) 4986 if (ga_nodeid().eq.0) 4987 & write(*,*) '-------g_a--------END' 4988 if (ga_nodeid().eq.0) 4989 & write(*,*) '-------g_b--------START' 4990 call ga_print(g_b) 4991 if (ga_nodeid().eq.0) 4992 & write(*,*) '-------g_b--------END' 4993 endif ! end-if-debug 4994 4995c The threshold used here should reflect the accuracy in the 4996c products. If very accurate products are used, 4997c then there is big 4998c advantage for small cases (maxsub close to n) in using a very 4999c small threshold in the SVD solve (e.g., 1e-14), but for more 5000c realistic examples (maxsub << n) there is only a little 5001c advantage and in the precence of real noise in the products 5002c screening with a realistic threshold is important. 5003 5004 call ga_svd_solve_seq(g_a,g_b,g_c,1d-14) 5005 5006 if (debug1) then 5007 if (ga_nodeid().eq.0) 5008 & write(*,*) '-------g_c(',iter,')--------START' 5009 call ga_print(g_c) 5010 if (ga_nodeid().eq.0) 5011 & write(*,*) '-------g_c(',iter,')--------END' 5012 endif ! end-if-debug1 5013 5014 call ga_dgemm('n','n',n1,nvec,nsub,mone, 5015 & g_Ax1,g_c,one,g_xr1) 5016 5017 if (debug1) then 5018 if (ga_nodeid().eq.0) then 5019 write(*,10) iter 5020 10 format('---------g_xr1-1(',i3,')-----START') 5021 endif 5022 call ga_print(g_xr1) 5023 if (ga_nodeid().eq.0) then 5024 write(*,6) iter 5025 6 format('---------g_xr1-1(',i3,')-----END') 5026 endif 5027 endif ! end-if-debug1 5028 5029 call update_g_x(g_x, ! in/ou: solution updated 5030 & g_xr1,! in : added to g_z 5031 & ncomp,! in : nr. components 5032 & nvec, ! in : (x,y,z) 5033 & n) ! in : vector length 5034 if (debug1) then 5035 do ipm=1,ncomp 5036 if (ga_nodeid().eq.0) then 5037 write(*,2) ipm,iter 5038 2 format('---------g_x-1(',i3,',',i3,')-----START') 5039 endif 5040 call ga_print(g_x(ipm)) 5041 if (ga_nodeid().eq.0) then 5042 write(*,3) ipm,iter 5043 3 format('---------g_x-1(',i3,',',i3,')-----END') 5044 endif 5045 enddo ! end-loop-ipm 5046 endif ! end-if-debug1 5047 call ga_zero(g_xr1) 5048 call ga_dgemm('n','n',n1,nvec,nsub,one, 5049 & g_x1,g_c,zero,g_xr1) 5050 5051 if (debug1) then 5052 if (ga_nodeid().eq.0) then 5053 write(*,7) iter 5054 7 format('---------g_xr1-2(',i3,')-----START') 5055 endif 5056 call ga_print(g_xr1) 5057 if (ga_nodeid().eq.0) then 5058 write(*,9) iter 5059 9 format('---------g_xr1-2(',i3,')-----END') 5060 endif 5061 endif ! end-if-debug1 5062 5063 call update_g_x(g_x, ! in/ou: solution updated 5064 & g_xr1,! in : added to g_z 5065 & ncomp,! in : nr. components 5066 & nvec, ! in : (x,y,z) 5067 & n) ! in : vector length 5068 5069 if (debug1) then 5070 do ipm=1,ncomp 5071 if (ga_nodeid().eq.0) then 5072 write(*,4) ipm,iter 5073 4 format('---------g_x-2(',i3,',',i3,')-----START') 5074 endif 5075 call ga_print(g_x(ipm)) 5076 if (ga_nodeid().eq.0) then 5077 write(*,5) ipm,iter 5078 5 format('---------g_x-2(',i3,',',i3,')-----END') 5079 endif 5080 enddo ! end-loop-ipm 5081 endif ! end-if-debug1 5082 5083 if (.not. ga_destroy(g_a)) call errquit 5084 & ('solve_zlineq: a',0, GA_ERR) 5085 if (.not. ga_destroy(g_b)) call errquit 5086 & ('solve_zlineq: b',0, GA_ERR) 5087 if (.not. ga_destroy(g_c)) call errquit 5088 & ('solve_zlineq: c',0, GA_ERR) 5089 return 5090 end 5091c -------------- solve_rlineq ---------------- END 5092 5093 subroutine solve_zlineq( 5094 & g_z, ! in/out: updated solution 5095 & g_Az1, ! in : history of g_Az 5096 & g_z1, ! in : history of g_z 5097 & g_zr1, ! in : history of g_zr 5098 & nsub, ! in : subspace length 5099 & nvec, ! in : increment of subspace 5100 & ncomp, ! in : nr. components 5101 & n, ! in : nr. elements per comp. 5102 & iter, ! in : iteration nr. 5103 & debug1)! in : =.true. show debug printouts 5104c 5105c Author : Fredy W. Aquino, Northwestern University 5106c Purpose: Solve complex linear equation using 'history' GA arrays 5107c Date : 03-15-12 5108c 5109c dim(g_Az1)=dim(z1)=(ncomp*n,maxsub) 5110c dim(g_zr1)=(ncomp*n,nvec) 5111 5112 implicit none 5113#include "errquit.fh" 5114#include "mafdecls.fh" 5115#include "global.fh" 5116#include "util.fh" 5117#include "rtdb.fh" 5118 integer nsub,nvec,ncomp,n,n1,iter,ipm 5119 integer g_a,g_b,g_c, 5120 & g_z1,g_Az1,g_zr1, 5121 & g_z(ncomp) 5122 logical debug1 5123 double complex one_cmplx,mone_cmplx,zero_cmplx 5124 external ga_svd_solve_seq_cmplx,update_g_z 5125c Form and solve the subspace equations using SVD in order 5126c to manage near linear dependence in the subspace. 5127c 5128 one_cmplx =dcmplx( 1.0d0,0.0d0) 5129 mone_cmplx=dcmplx(-1.0d0,0.0d0) 5130 zero_cmplx=dcmplx( 0.0d0,0.0d0) 5131 n1=ncomp*n 5132 if (.not. ga_create(MT_DCPL, nsub, nsub, 5133 & 'solve_zlineq: A',0,0,g_a)) 5134 $ call errquit('solve_zlineq: failed allocating g_a', 5135 & nsub,GA_ERR) 5136 if (.not. ga_create(MT_DCPL, nsub, nvec, 5137 & 'solve_zlineq: B',0,0,g_b)) 5138 $ call errquit('solve_zlineq: failed allocating g_b', 5139 & nsub,GA_ERR) 5140 if (.not. ga_create(MT_DCPL, nsub, nvec, 5141 & 'solve_zlineq: C',0,0,g_c)) 5142 $ call errquit('solve_zlineq: failed allocating g_c', 5143 & nsub,GA_ERR) 5144 call ga_zero(g_a) 5145 call ga_zero(g_b) 5146 call ga_zero(g_c) 5147 if (debug1) then 5148 if (ga_nodeid().eq.0) 5149 & write(*,*) '-------BEF:g_z1(',iter,')-------START' 5150 call ga_print(g_z1) 5151 if (ga_nodeid().eq.0) 5152 & write(*,*) '-------BEF:g_z1(',iter,')-------END' 5153 endif ! end-if-debug1 5154 call get_cconjugate(g_z1) ! out: complex-conjugate of g_z1 5155 call ga_zgemm('t','n',nsub,nsub,n1,one_cmplx, 5156 & g_z1,g_Az1,zero_cmplx,g_a) 5157 call ga_zgemm('t','n',nsub,nvec,n1,one_cmplx, 5158 & g_z1,g_zr1,zero_cmplx,g_b) 5159 if (debug1) then 5160 if (ga_nodeid().eq.0) 5161 & write(*,*) '-------g_a--------START' 5162 call ga_print(g_a) 5163 if (ga_nodeid().eq.0) 5164 & write(*,*) '-------g_a--------END' 5165 if (ga_nodeid().eq.0) 5166 & write(*,*) '-------g_b--------START' 5167 call ga_print(g_b) 5168 if (ga_nodeid().eq.0) 5169 & write(*,*) '-------g_b--------END' 5170 endif ! end-if-debug 5171 5172 call ga_svd_solve_seq_cmplx(g_a,g_b,g_c,1d-14) 5173 5174 if (debug1) then 5175 if (ga_nodeid().eq.0) 5176 & write(*,*) '-------g_c(',iter,')--------START' 5177 call ga_print(g_c) 5178 if (ga_nodeid().eq.0) 5179 & write(*,*) '-------g_c(',iter,')--------END' 5180 endif ! end-if-debug1 5181 5182 call ga_zgemm('n','n',n1,nvec,nsub,mone_cmplx, 5183 & g_Az1,g_c,one_cmplx,g_zr1) 5184 5185 if (debug1) then 5186 if (ga_nodeid().eq.0) then 5187 write(*,10) iter 5188 10 format('---------g_zr1-1(',i3,')-----START') 5189 endif 5190 call ga_print(g_zr1) 5191 if (ga_nodeid().eq.0) then 5192 write(*,6) iter 5193 6 format('---------g_zr1-1(',i3,')-----END') 5194 endif 5195 endif ! end-if-debug1 5196 5197 call update_g_z(g_z, ! in/ou: solution updated 5198 & g_zr1,! in : added to g_z 5199 & ncomp,! in : nr. components 5200 & nvec, ! in : (x,y,z) 5201 & n) ! in : vector length 5202 if (debug1) then 5203 do ipm=1,ncomp 5204 if (ga_nodeid().eq.0) then 5205 write(*,2) ipm,iter 5206 2 format('---------g_z-1(',i3,',',i3,')-----START') 5207 endif 5208 call ga_print(g_z(ipm)) 5209 if (ga_nodeid().eq.0) then 5210 write(*,3) ipm,iter 5211 3 format('---------g_z-1(',i3,',',i3,')-----END') 5212 endif 5213 enddo ! end-loop-ipm 5214 endif ! end-if-debug1 5215 call ga_zero(g_zr1) 5216 call get_cconjugate(g_z1) ! put back g_z1 5217 call ga_zgemm('n','n',n1,nvec,nsub,one_cmplx, 5218 & g_z1,g_c,zero_cmplx,g_zr1) 5219 5220 if (debug1) then 5221 if (ga_nodeid().eq.0) then 5222 write(*,7) iter 5223 7 format('---------g_zr1-2(',i3,')-----START') 5224 endif 5225 call ga_print(g_zr1) 5226 if (ga_nodeid().eq.0) then 5227 write(*,9) iter 5228 9 format('---------g_zr1-2(',i3,')-----END') 5229 endif 5230 endif ! end-if-debug1 5231 5232 call update_g_z(g_z, ! in/ou: solution updated 5233 & g_zr1,! in : added to g_z 5234 & ncomp,! in : nr. components 5235 & nvec, ! in : (x,y,z) 5236 & n) ! in : vector length 5237 5238 if (debug1) then 5239 do ipm=1,ncomp 5240 if (ga_nodeid().eq.0) then 5241 write(*,4) ipm,iter 5242 4 format('---------g_z-2(',i3,',',i3,')-----START') 5243 endif 5244 call ga_print(g_z(ipm)) 5245 if (ga_nodeid().eq.0) then 5246 write(*,5) ipm,iter 5247 5 format('---------g_z-2(',i3,',',i3,')-----END') 5248 endif 5249 enddo ! end-loop-ipm 5250 endif ! end-if-debug1 5251 5252 if (.not. ga_destroy(g_a)) call errquit 5253 & ('solve_zlineq: a',0, GA_ERR) 5254 if (.not. ga_destroy(g_b)) call errquit 5255 & ('solve_zlineq: b',0, GA_ERR) 5256 if (.not. ga_destroy(g_c)) call errquit 5257 & ('solve_zlineq: c',0, GA_ERR) 5258 return 5259 end 5260c +++++++++++++++++++++++++++++++++++++++++++++++++++ 5261c +++++++++ FA-12-06-13: fix-KAIN +++++++++++++ START 5262c +++++++++++++++++++++++++++++++++++++++++++++++++++ 5263 subroutine getdiffs_Az1z1( 5264 & g_Az1, ! in/out: history of g_Az 5265 & g_z1, ! in/out: history of g_z adding a block g_z1 5266 & nsub, ! in : subspace length 5267 & nvec, ! in : increment of subspace 5268 & ncomp, ! in : nr. components 5269 & n3, ! in : nr. elements per comp. 5270 & op) ! in : = -1 DO differences 5271 ! = +1 UNDO differences 5272c Purpose: Compute KAIN differences in (g_Az1,g_z1)_k k=0,...,n-1 5273c using (g_z1)_n 5274c Note.- n1=nsub/3 should be pointing to n+1 5275 implicit none 5276#include "errquit.fh" 5277#include "mafdecls.fh" 5278#include "global.fh" 5279#include "util.fh" 5280#include "rtdb.fh" 5281 integer g_z1,g_Az1,op, 5282 & nsub,nvec,ncomp, 5283 & n1,n2,n3,i 5284 integer p1,p2,q1,q2 5285 double complex op_cmplx,one_cmplx 5286 5287 if (op.ne.-1.and.op.ne.1) then 5288 call errquit( 5289 & 'getdiffs_Az1z1: failed op ne +1 or -1') 5290 endif 5291 if (op.eq.-1) then 5292 op_cmplx=dcmplx(-1.0d0,0.0d0) 5293 else if (op.eq.1) then 5294 op_cmplx=dcmplx(+1.0d0,0.0d0) 5295 endif 5296 if (nsub .lt. 6) then 5297 call errquit('getdiffs_Az1z1: failed nsub lt 6') 5298 endif 5299 one_cmplx =dcmplx( 1.0d0,0.0d0) 5300 n1=ncomp*n3 5301 n2=nsub/nvec+1 ! = n+1 CONDITION: nsub>=6 5302c --- Compute differences up to n1-2=n-1 -- START 5303 do i=1,n2-2 5304 p1=(i-1)*nvec+1 5305 p2=p1+nvec-1 5306 q1=nsub-nvec+1 5307 q2=q1+nvec-1 5308 call ga_add_patch( op_cmplx, g_z1,1,n1,q1,q2, 5309 $ one_cmplx, g_z1,1,n1,p1,p2, 5310 $ g_z1,1,n1,p1,p2) 5311 call ga_add_patch( op_cmplx,g_Az1,1,n1,q1,q2, 5312 $ one_cmplx,g_Az1,1,n1,p1,p2, 5313 $ g_Az1,1,n1,p1,p2) 5314 enddo ! end-loop-i 5315c --- Compute differences up to n1-2=n-1 -- END 5316 return 5317 end 5318 5319 subroutine solve_zlineq1_fixed( 5320 & g_Az1, ! in : history of g_Az 5321 & g_z1, ! in/out: history of g_z adding a block g_z1 5322 & g_zr1, ! in : g_zr 5323 & nsub, ! in : subspace length 5324 & nvec, ! in : increment of subspace 5325 & ncomp, ! in : nr. components 5326 & n, ! in : nr. elements per comp. 5327 & iter, ! in : iteration nr. 5328 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 5329 & debug1) ! in : =.true. show debug printouts 5330c 5331c Author : Fredy W. Aquino, Northwestern University 5332c Purpose: Solve complex linear equation using history GA arrays 5333c and reducing memory cost 5334c Date : 03-15-12 5335c 5336c dim(g_Az1)=dim(z1)=(ncomp*n,maxsub) 5337c dim(g_zr1)=(ncomp*n,nvec) 5338 5339 implicit none 5340#include "errquit.fh" 5341#include "mafdecls.fh" 5342#include "global.fh" 5343#include "util.fh" 5344#include "rtdb.fh" 5345 integer nsub,nsub1,nvec,ncomp, 5346 & p1,p2,q1,q2, 5347 & n,n1,iter,ipm,checkorth 5348 integer g_a,g_b,g_c, 5349 & g_z1,g_Az1,g_zr1 5350 logical debug1 5351 double complex one_cmplx,mone_cmplx,zero_cmplx 5352 external ga_svd_solve_seq_cmplx, 5353 & update_g_z, 5354 & toview_orthz1c, 5355 & getdiffs_Az1z1 5356c Form and solve the subspace equations using SVD in order 5357c to manage near linear dependence in the subspace. 5358c 5359 one_cmplx =dcmplx( 1.0d0,0.0d0) 5360 mone_cmplx=dcmplx(-1.0d0,0.0d0) 5361 zero_cmplx=dcmplx( 0.0d0,0.0d0) 5362 n1=ncomp*n 5363 nsub1=nsub-nvec ! nvec=3 5364 if (.not. ga_create(MT_DCPL, nsub1, nsub1, 5365 & 'solve_zlineq: A',0,0,g_a)) 5366 $ call errquit('solve_zlineq: failed allocating g_a', 5367 & nsub1,GA_ERR) 5368 if (.not. ga_create(MT_DCPL, nsub1, nvec, 5369 & 'solve_zlineq: B',0,0,g_b)) 5370 $ call errquit('solve_zlineq: failed allocating g_b', 5371 & nsub1,GA_ERR) 5372 if (.not. ga_create(MT_DCPL, nsub1, nvec, 5373 & 'solve_zlineq: C',0,0,g_c)) 5374 $ call errquit('solve_zlineq: failed allocating g_c', 5375 & nsub1,GA_ERR) 5376 call ga_zero(g_a) 5377 call ga_zero(g_b) 5378 call ga_zero(g_c) 5379 if (debug1) then 5380 if (ga_nodeid().eq.0) 5381 & write(*,*) '-------BEF:g_z1(',iter,')-------START' 5382 call ga_print(g_z1) 5383 if (ga_nodeid().eq.0) 5384 & write(*,*) '-------BEF:g_z1(',iter,')-------END' 5385 if (ga_nodeid().eq.0) 5386 & write(*,*) '-------BEF:g_Az1(',iter,')-------START' 5387 call ga_print(g_Az1) 5388 if (ga_nodeid().eq.0) 5389 & write(*,*) '-------BEF:g_Az1(',iter,')-------END' 5390 if (ga_nodeid().eq.0) 5391 & write(*,*) '-------BEF:g_zr1(',iter,')-------START' 5392 call ga_print(g_zr1) 5393 if (ga_nodeid().eq.0) 5394 & write(*,*) '-------BEF:g_zr1(',iter,')-------END' 5395 endif ! end-if-debug1 5396 call getdiffs_Az1z1( 5397 & g_Az1, ! in/out: history of g_Az 5398 & g_z1, ! in/out: history of g_z adding a block g_z1 5399 & nsub, ! in : subspace length 5400 & nvec, ! in : increment of subspace 5401 & ncomp, ! in : nr. components 5402 & n, ! in : nr. elements per comp. 5403 & -1) ! in : = -1 DO differences 5404 ! = +1 UNDO differences 5405 5406 call get_cconjugate(g_z1) ! out: complex-conjugate of g_z1 5407 call ga_zgemm('t','n',nsub1,nsub1,n1,one_cmplx, 5408 & g_z1,g_Az1,zero_cmplx,g_a) 5409 call ga_zgemm('t','n',nsub1,nvec,n1,one_cmplx, 5410 & g_z1,g_zr1,zero_cmplx,g_b) 5411 5412 if (debug1) then 5413 if (ga_nodeid().eq.0) 5414 & write(*,10) iter 5415 10 format('-------g_a(',i4,')--------START') 5416 call ga_print(g_a) 5417 if (ga_nodeid().eq.0) 5418 & write(*,*) iter 5419 11 format('-------g_a(',i4,')--------END') 5420 if (ga_nodeid().eq.0) 5421 & write(*,12) iter 5422 12 format('-------g_b(',i4,')--------START') 5423 call ga_print(g_b) 5424 if (ga_nodeid().eq.0) 5425 & write(*,13) iter 5426 13 format('-------g_b(',i4,')--------END') 5427 endif ! end-if-debug 5428 5429 call ga_svd_solve_seq_cmplx(g_a,g_b,g_c,1d-14) 5430 5431 if (debug1) then 5432 if (ga_nodeid().eq.0) 5433 & write(*,14) iter 5434 14 format('-------g_c(',i4,')--------START') 5435 call ga_print(g_c) 5436 if (ga_nodeid().eq.0) 5437 & write(*,15) iter 5438 15 format('-------g_c(',i4,')--------END') 5439 endif ! end-if-debug1 5440 5441 call ga_zgemm('n','n',n1,nvec,nsub1, 5442 & mone_cmplx,g_Az1,g_c, 5443 & one_cmplx ,g_zr1) 5444c 000000000000 check-orthonogality-1 000000000000 START 5445c Compute: g_z1^t . (g_zr1-Az1c)=0 by construction 5446c 000000000000 check-orthonogality-1 000000000000 END 5447 call get_cconjugate(g_z1) ! put back g_z1 as it was 5448 5449 if (debug1) then 5450 if (ga_nodeid().eq.0) then 5451 write(*,20) iter 5452 20 format('---------g_zr1-1(',i3,')-----START') 5453 endif 5454 call ga_print(g_zr1) 5455 if (ga_nodeid().eq.0) then 5456 write(*,6) iter 5457 6 format('---------g_zr1-1(',i3,')-----END') 5458 endif 5459 endif ! end-if-debug1 5460 5461c --- construct new (n1,nvec) block-in g_z1------ START 5462c Note.- It uses previous (n1,nvec) block in g_z1 and 5463c g_zr1(=g_Az1 * g_c) 5464 p1=nsub-nvec+1 5465 p2=p1+nvec-1 5466 q1=p1+nvec 5467 q2=p2+nvec 5468 call ga_add_patch(one_cmplx,g_zr1,1,n1,1,nvec, 5469 $ one_cmplx,g_z1 ,1,n1,p1,p2, 5470 $ g_z1 ,1,n1,q1,q2) 5471c --- construct new (n1,nvec) block-in g_z1------ END 5472 if (debug1) then 5473 if (ga_nodeid().eq.0) then 5474 write(*,2) iter 5475 2 format('---------g_z1-1(',i3,')-----START') 5476 endif 5477 call ga_print(g_z1) 5478 if (ga_nodeid().eq.0) then 5479 write(*,3) iter 5480 3 format('---------g_z1-1(',i3,')-----END') 5481 endif 5482 endif ! end-if-debug1 5483 call ga_zero(g_zr1) 5484 call ga_zgemm('n','n',n1,nvec,nsub1,one_cmplx, 5485 & g_z1,g_c,zero_cmplx,g_zr1) 5486c 000000000000 check-orthonogality-2 000000000000 START 5487c Compute: g_z1^t . z1c: 5488 if (debug1) then 5489 if (ga_nodeid().eq.0) 5490 & write(*,*) '-------z1c(',iter,')--------START' 5491 call ga_print(g_zr1) 5492 if (ga_nodeid().eq.0) 5493 & write(*,*) '-------z1c(',iter,')--------END' 5494 endif ! end-if-debug 5495 5496 call get_cconjugate(g_z1) ! conjugate for next op 5497 call ga_zero(g_b) 5498 call ga_zgemm('t','n',nsub1,nvec,n1,one_cmplx, 5499 & g_z1,g_zr1,zero_cmplx,g_b) 5500 call get_cconjugate(g_z1) ! put back as it was 5501 if (checkorth.eq.1) then ! display z1^t*(z1c) 5502 call toview_orthz1c( 5503 & g_b, 5504 & nsub1, 5505 & nvec, 5506 & iter) 5507 endif 5508c endif ! end-if-debug1 5509c 000000000000 check-orthonogality-2 000000000000 END 5510 if (debug1) then 5511 if (ga_nodeid().eq.0) then 5512 write(*,7) iter 5513 7 format('---------g_zr1-2(',i3,')-----START') 5514 endif 5515 call ga_print(g_zr1) 5516 if (ga_nodeid().eq.0) then 5517 write(*,9) iter 5518 9 format('---------g_zr1-2(',i3,')-----END') 5519 endif 5520 endif ! end-if-debug1 5521 5522c --- update new (n1,nvec) block-in g_z1------ START 5523 p1=nsub-nvec+1 5524 p2=p1+nvec-1 5525 q1=p1+nvec 5526 q2=p2+nvec 5527 call ga_add_patch(one_cmplx,g_zr1,1,n1,1,nvec, 5528 $ one_cmplx,g_z1 ,1,n1,q1,q2, 5529 $ g_z1 ,1,n1,q1,q2) 5530c --- update new (n1,nvec) block-in g_z1------ END 5531 5532 call getdiffs_Az1z1( 5533 & g_Az1, ! in/out: history of g_Az 5534 & g_z1, ! in/out: history of g_z adding a block g_z1 5535 & nsub, ! in : subspace length 5536 & nvec, ! in : increment of subspace 5537 & ncomp, ! in : nr. components 5538 & n, ! in : nr. elements per comp. 5539 & 1) ! in : = -1 DO differences 5540 ! = +1 UNDO differences 5541 if (debug1) then 5542 if (ga_nodeid().eq.0) then 5543 write(*,4) iter 5544 4 format('---------g_z1-2(',i3,')-----START') 5545 endif 5546 call ga_print(g_z1) 5547 if (ga_nodeid().eq.0) then 5548 write(*,5) iter 5549 5 format('---------g_z1-2(',i3,')-----END') 5550 endif 5551 endif ! end-if-debug1 5552 5553 if (.not. ga_destroy(g_a)) call errquit 5554 & ('solve_zlineq: a',0, GA_ERR) 5555 if (.not. ga_destroy(g_b)) call errquit 5556 & ('solve_zlineq: b',0, GA_ERR) 5557 if (.not. ga_destroy(g_c)) call errquit 5558 & ('solve_zlineq: c',0, GA_ERR) 5559 return 5560 end 5561 5562 subroutine solve_zlineq1( 5563 & g_Az1, ! in : history of g_Az 5564 & g_z1, ! in/out: history of g_z adding a block g_z1 5565 & g_zr1, ! in : g_zr 5566 & nsub, ! in : subspace length 5567 & nvec, ! in : increment of subspace 5568 & ncomp, ! in : nr. components 5569 & n, ! in : nr. elements per comp. 5570 & iter, ! in : iteration nr. 5571 & checkorth,! in : =1 display: z1^t*(z1c) (goes to zero is it converges) 5572 & debug1) ! in : =.true. show debug printouts 5573c 5574c Author : Fredy W. Aquino, Northwestern University 5575c Purpose: Solve complex linear equation using history GA arrays 5576c and reducing memory cost 5577c Date : 03-15-12 5578c 5579c dim(g_Az1)=dim(z1)=(ncomp*n,maxsub) 5580c dim(g_zr1)=(ncomp*n,nvec) 5581 5582 implicit none 5583#include "errquit.fh" 5584#include "mafdecls.fh" 5585#include "global.fh" 5586#include "util.fh" 5587#include "rtdb.fh" 5588 integer nsub,nvec,ncomp, 5589 & p1,p2,q1,q2, 5590 & n,n1,iter,ipm,checkorth 5591 integer g_a,g_b,g_c, 5592 & g_z1,g_Az1,g_zr1 5593 logical debug1 5594 double complex one_cmplx,mone_cmplx,zero_cmplx 5595 external ga_svd_solve_seq_cmplx, 5596 & update_g_z, 5597 & toview_orthz1c 5598c Form and solve the subspace equations using SVD in order 5599c to manage near linear dependence in the subspace. 5600c 5601 one_cmplx =dcmplx( 1.0d0,0.0d0) 5602 mone_cmplx=dcmplx(-1.0d0,0.0d0) 5603 zero_cmplx=dcmplx( 0.0d0,0.0d0) 5604 n1=ncomp*n 5605 if (.not. ga_create(MT_DCPL, nsub, nsub, 5606 & 'solve_zlineq: A',0,0,g_a)) 5607 $ call errquit('solve_zlineq: failed allocating g_a', 5608 & nsub,GA_ERR) 5609 if (.not. ga_create(MT_DCPL, nsub, nvec, 5610 & 'solve_zlineq: B',0,0,g_b)) 5611 $ call errquit('solve_zlineq: failed allocating g_b', 5612 & nsub,GA_ERR) 5613 if (.not. ga_create(MT_DCPL, nsub, nvec, 5614 & 'solve_zlineq: C',0,0,g_c)) 5615 $ call errquit('solve_zlineq: failed allocating g_c', 5616 & nsub,GA_ERR) 5617 call ga_zero(g_a) 5618 call ga_zero(g_b) 5619 call ga_zero(g_c) 5620 if (debug1) then 5621 if (ga_nodeid().eq.0) 5622 & write(*,*) '-------BEF:g_z1(',iter,')-------START' 5623 call ga_print(g_z1) 5624 if (ga_nodeid().eq.0) 5625 & write(*,*) '-------BEF:g_z1(',iter,')-------END' 5626 if (ga_nodeid().eq.0) 5627 & write(*,*) '-------BEF:g_Az1(',iter,')-------START' 5628 call ga_print(g_Az1) 5629 if (ga_nodeid().eq.0) 5630 & write(*,*) '-------BEF:g_Az1(',iter,')-------END' 5631 if (ga_nodeid().eq.0) 5632 & write(*,*) '-------BEF:g_zr1(',iter,')-------START' 5633 call ga_print(g_zr1) 5634 if (ga_nodeid().eq.0) 5635 & write(*,*) '-------BEF:g_zr1(',iter,')-------END' 5636 endif ! end-if-debug1 5637 5638 call get_cconjugate(g_z1) ! out: complex-conjugate of g_z1 5639 call ga_zgemm('t','n',nsub,nsub,n1,one_cmplx, 5640 & g_z1,g_Az1,zero_cmplx,g_a) 5641 call ga_zgemm('t','n',nsub,nvec,n1,one_cmplx, 5642 & g_z1,g_zr1,zero_cmplx,g_b) 5643 if (debug1) then 5644 if (ga_nodeid().eq.0) 5645 & write(*,10) iter 5646 10 format('-------g_a(',i4,')--------START') 5647 call ga_print(g_a) 5648 if (ga_nodeid().eq.0) 5649 & write(*,*) iter 5650 11 format('-------g_a(',i4,')--------END') 5651 if (ga_nodeid().eq.0) 5652 & write(*,12) iter 5653 12 format('-------g_b(',i4,')--------START') 5654 call ga_print(g_b) 5655 if (ga_nodeid().eq.0) 5656 & write(*,13) iter 5657 13 format('-------g_b(',i4,')--------END') 5658 endif ! end-if-debug 5659 5660 call ga_svd_solve_seq_cmplx(g_a,g_b,g_c,1d-14) 5661 5662 if (debug1) then 5663 if (ga_nodeid().eq.0) 5664 & write(*,14) iter 5665 14 format('-------g_c(',i4,')--------START') 5666 call ga_print(g_c) 5667 if (ga_nodeid().eq.0) 5668 & write(*,15) iter 5669 15 format('-------g_c(',i4,')--------END') 5670 endif ! end-if-debug1 5671 5672 call ga_zgemm('n','n',n1,nvec,nsub,mone_cmplx, 5673 & g_Az1,g_c,one_cmplx,g_zr1) 5674c 000000000000 check-orthonogality-1 000000000000 START 5675c Compute: g_z1^t . (g_zr1-Az1c)=0 by construction 5676c 000000000000 check-orthonogality-1 000000000000 END 5677 call get_cconjugate(g_z1) ! put back g_z1 as it was 5678 5679 if (debug1) then 5680 if (ga_nodeid().eq.0) then 5681 write(*,20) iter 5682 20 format('---------g_zr1-1(',i3,')-----START') 5683 endif 5684 call ga_print(g_zr1) 5685 if (ga_nodeid().eq.0) then 5686 write(*,6) iter 5687 6 format('---------g_zr1-1(',i3,')-----END') 5688 endif 5689 endif ! end-if-debug1 5690 5691c --- construct new (n1,nvec) block-in g_z1------ START 5692c Note.- It uses previous (n1,nvec) block in g_z1 and 5693c g_zr1(=g_Az1 * g_c) 5694 p1=nsub-nvec+1 5695 p2=nsub-nvec+nvec 5696 q1=p1+nvec 5697 q2=p2+nvec 5698 call ga_add_patch(one_cmplx,g_zr1,1,n1,1,nvec, 5699 $ one_cmplx,g_z1 ,1,n1,p1,p2, 5700 $ g_z1 ,1,n1,q1,q2) 5701c --- construct new (n1,nvec) block-in g_z1------ END 5702 if (debug1) then 5703 if (ga_nodeid().eq.0) then 5704 write(*,2) iter 5705 2 format('---------g_z1-1(',i3,')-----START') 5706 endif 5707 call ga_print(g_z1) 5708 if (ga_nodeid().eq.0) then 5709 write(*,3) iter 5710 3 format('---------g_z1-1(',i3,')-----END') 5711 endif 5712 endif ! end-if-debug1 5713 call ga_zero(g_zr1) 5714 call ga_zgemm('n','n',n1,nvec,nsub,one_cmplx, 5715 & g_z1,g_c,zero_cmplx,g_zr1) 5716c 000000000000 check-orthonogality-2 000000000000 START 5717c Compute: g_z1^t . z1c: 5718 if (debug1) then 5719 if (ga_nodeid().eq.0) 5720 & write(*,*) '-------z1c(',iter,')--------START' 5721 call ga_print(g_zr1) 5722 if (ga_nodeid().eq.0) 5723 & write(*,*) '-------z1c(',iter,')--------END' 5724 endif ! end-if-debug 5725 5726 call get_cconjugate(g_z1) ! conjugate for next op 5727 call ga_zero(g_b) 5728 call ga_zgemm('t','n',nsub,nvec,n1,one_cmplx, 5729 & g_z1,g_zr1,zero_cmplx,g_b) 5730 call get_cconjugate(g_z1) ! put back as it was 5731 if (checkorth.eq.1) then ! display z1^t*(z1c) 5732 call toview_orthz1c( 5733 & g_b, 5734 & nsub, 5735 & nvec, 5736 & iter) 5737 endif 5738c endif ! end-if-debug1 5739c 000000000000 check-orthonogality-2 000000000000 END 5740 if (debug1) then 5741 if (ga_nodeid().eq.0) then 5742 write(*,7) iter 5743 7 format('---------g_zr1-2(',i3,')-----START') 5744 endif 5745 call ga_print(g_zr1) 5746 if (ga_nodeid().eq.0) then 5747 write(*,9) iter 5748 9 format('---------g_zr1-2(',i3,')-----END') 5749 endif 5750 endif ! end-if-debug1 5751 5752c --- update new (n1,nvec) block-in g_z1------ START 5753 p1=nsub-nvec+1 5754 p2=nsub-nvec+nvec 5755 q1=p1+nvec 5756 q2=p2+nvec 5757 call ga_add_patch(one_cmplx,g_zr1,1,n1,1,nvec, 5758 $ one_cmplx,g_z1 ,1,n1,q1,q2, 5759 $ g_z1 ,1,n1,q1,q2) 5760c --- update new (n1,nvec) block-in g_z1------ END 5761 if (debug1) then 5762 if (ga_nodeid().eq.0) then 5763 write(*,4) iter 5764 4 format('---------g_z1-2(',i3,')-----START') 5765 endif 5766 call ga_print(g_z1) 5767 if (ga_nodeid().eq.0) then 5768 write(*,5) iter 5769 5 format('---------g_z1-2(',i3,')-----END') 5770 endif 5771 endif ! end-if-debug1 5772 5773 if (.not. ga_destroy(g_a)) call errquit 5774 & ('solve_zlineq: a',0, GA_ERR) 5775 if (.not. ga_destroy(g_b)) call errquit 5776 & ('solve_zlineq: b',0, GA_ERR) 5777 if (.not. ga_destroy(g_c)) call errquit 5778 & ('solve_zlineq: c',0, GA_ERR) 5779 return 5780 end 5781 5782 subroutine toview_orthz1c( 5783 & g_b, 5784 & nsub, 5785 & nvec, 5786 & iter) 5787c 5788c Author : Fredy W. Aquino, Northwestern University 5789c Purpose: Visualize g_b with 8 decimals. 5790c Date : 03-15-12 5791 5792 implicit none 5793#include "errquit.fh" 5794#include "mafdecls.fh" 5795#include "global.fh" 5796#include "util.fh" 5797#include "rtdb.fh" 5798c Note.- g_z= z1^t . (z1c) it is becoming zero 5799c as the iteration increases 5800 integer nsub,nvec,g_b, 5801 & l_z,k_z, 5802 & i,j,iter 5803 double precision valre,valim 5804 if (.not.MA_Push_Get(mt_dcpl,nvec,'g_bre',l_z,k_z)) 5805 & call errquit('toview_orthz1c: cannot allocate zre', 5806 & nvec, MA_ERR) 5807 if (ga_nodeid().eq.0) 5808 & write(*,1) iter 5809 1 format('-------z1^t*(z1c)(',i4,')--------START') 5810 do i=1,nsub 5811 call ga_get(g_b,i,i,1,nvec,dcpl_mb(k_z),1) 5812 if (ga_nodeid().eq.0) then 5813 write(*,'(i8,":",3(" (",f14.8,",",f14.8,") "))') 5814 & i,(dreal(dcpl_mb(k_z+j-1)),dimag(dcpl_mb(k_z+j-1)),j=1,nvec) 5815 endif 5816 enddo ! end-loop-idata 5817 if (ga_nodeid().eq.0) 5818 & write(*,2) iter 5819 2 format('-------z1^t*(z1c)(',i4,')--------END') 5820 if (.not.ma_pop_stack(l_z)) 5821 $ call errquit('toview_orthz1c: pop problem with l_zim', 5822 & 555,MA_ERR) 5823 return 5824 end 5825 5826 subroutine toview_orthz1c_short( 5827 & g_b, 5828 & nblocks, 5829 & nvec, 5830 & iter) 5831c 5832c Author : Fredy W. Aquino, Northwestern University 5833c Purpose: Visualize g_b with 8 decimals. 5834c Date : 03-15-12 5835 5836 implicit none 5837#include "errquit.fh" 5838#include "mafdecls.fh" 5839#include "global.fh" 5840#include "util.fh" 5841#include "rtdb.fh" 5842c Note.- g_z= z1^t . (z1c) it is becoming zero 5843c as the iteration increases 5844 integer nblocks,nvec,g_b, 5845 & l_z,k_z, 5846 & i,j,iter 5847 double precision valre,valim 5848 if (.not.MA_Push_Get(mt_dcpl,nvec,'g_bre',l_z,k_z)) 5849 & call errquit('toview_orthz1c: cannot allocate zre', 5850 & nvec, MA_ERR) 5851 if (ga_nodeid().eq.0) then 5852 write(*,16) iter 5853 16 format('---------z1^t*(z1c)(',i3,')-----START') 5854 endif 5855 do i=1,nblocks 5856 call ga_get(g_b,i,i,1,nvec,dcpl_mb(k_z),1) 5857 if (ga_nodeid().eq.0) then 5858 write(*,'(i8,":",3(" (",f14.8,",",f14.8,") "))') 5859 & i,(dreal(dcpl_mb(k_z+j-1)),dimag(dcpl_mb(k_z+j-1)),j=1,nvec) 5860 endif 5861 enddo ! end-loop-idata 5862 if (ga_nodeid().eq.0) then 5863 write(*,17) iter 5864 17 format('---------z1^t*(z1c)(',i3,')-----END') 5865 endif 5866 if (.not.ma_pop_stack(l_z)) 5867 $ call errquit('toview_orthz1c: pop problem with l_zim', 5868 & 555,MA_ERR) 5869 return 5870 end 5871 5872 subroutine ga_svd_solve_seq_cmplx( 5873 & g_a, ! in : a of a x = b 5874 & g_b, ! in : b of a x = b 5875 & g_x, ! out: x of a x = b 5876 & tol) ! in : tolerance 5877c 5878c Author: Fredy W. Aquino, Northwestern University 5879c Date : 03-15-12 5880c 5881c Note.- Adapted to do complex calc. from ga_svd_solve_seq() 5882c located in ga_it2.F 5883 5884 implicit none 5885#include "errquit.fh" 5886#include "global.fh" 5887#include "mafdecls.fh" 5888#include "util.fh" 5889 integer g_a, g_b, g_x 5890 double precision tol 5891c 5892c Solve for X from the linear equations 5893c 5894c A*X = B 5895c 5896c A(m,n)*X(n,nvec) = B(m,nvec) 5897c 5898c Where A is a general real matrix (not necessarily square, or 5899c symmetric, or full rank) and X and B are matrices with one or more 5900c columns representing the solutions and right hand sides. Singular 5901c values of A less than tol are neglected. X is returned. 5902c 5903c If the SVD of A is U*values*VT, then the solution 5904c is of the form 5905c 5906c V*(1/values)*UT*B 5907c 5908c where the reciprocal of values less than tol are neglected. 5909c 5910 integer m,n,nn,type,nvec,nsing,i, 5911 & l_val,k_val, 5912 & g_u,g_vt,g_tmp 5913 logical oprint 5914 double complex one_cmplx,zero_cmplx 5915 external ga_svd_seq_cmplx,ga_scale_lh_cmplx, 5916 & get_cconjugate 5917 5918 oprint = util_print('debug svdsolve', print_high) .and. 5919 $ ga_nodeid().eq.0 5920 5921 call ga_inquire(g_a, type, m, n) 5922 call ga_inquire(g_b, type, nn, nvec) 5923 5924 if (nn .ne. n) call errquit('gasvdsol: b does not conform',nn, 5925 & GA_ERR) 5926 nsing = min(m,n) 5927 if (.not. ma_push_get(MT_DBL, nsing, 'gasvdsol', 5928 & l_val, k_val)) 5929 $ call errquit('gasvdsol: val',nsing, MA_ERR) 5930 if (.not. ga_create(MT_DCPL,m,nsing,'gasvd',0,0,g_u)) 5931 $ call errquit('gasvdsol: u',m*nsing, GA_ERR) 5932 if (.not. ga_create(MT_DCPL,nsing,n,'gasvd',0,0,g_vt)) 5933 $ call errquit('gasvdsol: u',nsing*n, GA_ERR) 5934 if (.not. ga_create(MT_DCPL,nsing,nvec,'gasvd',0,0,g_tmp)) 5935 $ call errquit('gasvdsol: tmp',nsing*nvec, GA_ERR) 5936 call ga_zero(g_tmp) 5937 5938 call ga_svd_seq_cmplx(g_a,g_u,g_vt,dbl_mb(k_val)) 5939 5940 do i = 0, nsing-1 5941 if (dbl_mb(k_val+i) .lt. tol) then 5942 if (ga_nodeid() .eq. 0 .and. oprint) then 5943 write(6,*) ' neglecting ', i+1, dbl_mb(k_val+i) 5944 endif 5945 dbl_mb(k_val+i) = 0.0d0 5946 else 5947 dbl_mb(k_val+i) = 1.0d0/dbl_mb(k_val+i) 5948 end if 5949 end do 5950c Ax=b from SVD: A= U w V^t -> x=A^{-1}b A^{-1}=V w^{-1} U^t 5951c Note.- Using property: U^{-1}=U^t V^{-1}=V^t 5952c Using property: (AB)^{-1}=B^{-1}A^{-1} (FA-04-06-12) 5953 one_cmplx =dcmplx(1.0d0,0.0d0) 5954 zero_cmplx=dcmplx(0.0d0,0.0d0) 5955c Note.- U^t --> U^H (complex conjugate + transposed) 5956 call get_cconjugate(g_u) 5957 call ga_zgemm('t','n',nsing,nvec,m,one_cmplx,g_u,g_b, 5958 & zero_cmplx,g_tmp) ! U^t b -> g_tmp 5959 call ga_scale_lh_cmplx(g_tmp,dbl_mb(k_val)) ! w^{-1} U^t b -> g_tmp 5960 call ga_zero(g_x) 5961c Note.-since g_vt = V^H to get V from V^H : V=complex conjugate + transpose of V^H 5962 call get_cconjugate(g_vt) 5963 call ga_zgemm('t','n',n,nvec,nsing,one_cmplx,g_vt,g_tmp, 5964 & zero_cmplx,g_x) ! V w^{-1} U^t b -> g_x 5965 if (.not. ga_destroy(g_tmp)) call errquit('gasvdsol: des',1, 5966 & GA_ERR) 5967 if (.not. ga_destroy(g_u)) call errquit('gasvdsol: des',2, 5968 & GA_ERR) 5969 if (.not. ga_destroy(g_vt)) call errquit('gasvdsol: des',3, 5970 & GA_ERR) 5971 if (.not. ma_pop_stack(l_val)) call errquit('gasvdsol: pop',4, 5972 & GA_ERR) 5973 5974 end 5975 5976 subroutine ga_svd_seq_cmplx(g_a, g_u, g_vt, values) 5977c Author: Fredy W. Aquino, Northwestern University 5978c Date : 03-15-12 5979c 5980c Note.- Adapted from ga_svd_seq 5981c to handle complex g_a FA-04-08-12 5982 5983 implicit none 5984#include "errquit.fh" 5985#include "global.fh" 5986#include "mafdecls.fh" 5987 integer g_a, g_u, g_vt 5988 double precision values(*) 5989 external zgesvd 5990c 5991c Perform SVD on rectangular matrix 5992c 5993c nsing = min(n,m) 5994c g_a(m,n) --- input matrix 5995c g_u(m,nsing) --- left singular vectors (output) 5996c g_vt(nsing,n) --- right singular vectors transposed (output) 5997c values(nsing) --- singular values (output) 5998c 5999c A = U*values*VT 6000c 6001c A possible parallel algorithm is to diagonalize ATA to get 6002c V and AAT to get U --- both have values**2 as eigenvalues. 6003 6004 integer n, m, type,n_rwork, 6005 & l_a,k_a, 6006 & l_u,k_u, 6007 & l_vt,k_vt, 6008 $ l_work,k_work, 6009 $ l_rwork,k_rwork, 6010 & lwork, info, nsing 6011 6012 integer i ! for debugging purpose 6013 call ga_inquire(g_a, type, m, n) 6014 nsing = min(m,n) 6015 call ga_sync() ! FA-added 07-01-12 6016c 000000000000000000000000000000000000000000000000000000000 6017 if (ga_nodeid() .eq. 0) then ! 000000 node-0 00 START 6018 lwork = 10*max(m,n) 6019 6020 if (.not. ma_push_get(MT_DCPL, m*n, 'gasvd1',l_a,k_a)) 6021 $ call errquit('gasvd: a',m*n, MA_ERR) 6022 if (.not. ma_push_get(MT_DCPL, m*nsing, 'gasvd2',l_u,k_u)) 6023 $ call errquit('gasvd: u',m*nsing, MA_ERR) 6024 if (.not. ma_push_get(MT_DCPL, nsing*n, 'gasvd3',l_vt,k_vt)) 6025 $ call errquit('gasvd: vt',nsing*n, MA_ERR) 6026 if (.not. ma_push_get(MT_DCPL, lwork, 'gasvd4',l_work,k_work)) 6027 $ call errquit('gasvd: work',lwork, MA_ERR) 6028 n_rwork=5*min(m,n) 6029 if (.not. ma_push_get(MT_DBL, n_rwork, 'gasvd5', 6030 & l_rwork, k_rwork)) 6031 $ call errquit('gasvd: rwork',n_rwork, MA_ERR) 6032 6033 call ga_get(g_a, 1, m, 1, n, dcpl_mb(k_a), m) 6034 call zgesvd('s','s',m,n,dcpl_mb(k_a),m,values, 6035 $ dcpl_mb(k_u),m,dcpl_mb(k_vt),nsing, 6036 $ dcpl_mb(k_work),lwork,dbl_mb(k_rwork),info) 6037 if (info .ne. 0) then 6038 call errquit('gasvd: failed', info, MEM_ERR) 6039 endif 6040 call ga_put(g_u, 1, n, 1, nsing, dcpl_mb(k_u), n) 6041 call ga_put(g_vt, 1, nsing, 1, m, dcpl_mb(k_vt), n) 6042c Deallocating l_a and (l_u,l_vt,l_work,l_rwork) 6043 if (.not. ma_chop_stack(l_a)) call errquit('gasvd a',0, 6044 & MA_ERR) 6045 end if ! 000000000000000000000000000000 node-0 00 END 6046c 000000000000000000000000000000000000000000000000000000000 6047 call ga_sync() 6048 call ga_brdcst(1,values,n*8,0) 6049 call ga_sync() 6050 end 6051 6052 subroutine ga_scale_lh_cmplx(g_a,vector) 6053c 6054c Author: Fredy W. Aquino, Northwestern University 6055c Date : 03-15-12 6056c 6057c Note.- Adapted from ga_scale_lh in ga_extra.F 6058c to handle complex g_a FA-04-08-12 6059 6060 implicit none 6061#include "global.fh" 6062#include "mafdecls.fh" 6063#include "msgids.fh" 6064 integer g_a 6065 double precision vector(*) 6066c 6067c Do full matrix times diagonal matrix with the diagonal 6068c matrix on the left hand side stored as a vector 6069c This boils down to a row wise scaling of the g_a 6070c 6071c do i=1,nbf 6072c do j=1,nbf 6073c g_a(i,j)=g_a(i,j)*vector(i) 6074c enddo 6075c enddo 6076 6077 integer ma_type, dim1, dim2, n 6078 integer i, j, ilo, ihi, jlo, jhi 6079 double complex number 6080 6081 call ga_sync() 6082 call ga_inquire(g_a, ma_type, dim1, dim2) 6083 if (ma_type.ne.mt_dcpl) then 6084 write(0,*) ' ma_type ',ma_type,' mt_dcpl ',mt_dcpl 6085 call errquit 6086 $ ('ga_scale_lh_cmplx: array is not complex', g_a,0) 6087 endif 6088 n = dim1 6089c 6090c Extract and sum the diags local to each process 6091 6092 call ga_distribution(g_a, ga_nodeid(), ilo, ihi, jlo, jhi) 6093 if (ilo.gt.0 .and. jlo.gt.0) then 6094 do i = ilo,ihi 6095 do j = jlo,jhi 6096 call ga_get(g_a, i, i, j, j, number, 1) 6097 number = dcmplx(dreal(number)*vector(i), 6098 & dimag(number)*vector(i)) 6099 call ga_put(g_a,i, i, j, j, number, 1) 6100 enddo 6101 enddo 6102 endif 6103 call ga_sync() 6104 end 6105 6106 subroutine update_g_x(g_x, ! in/ou: solution updated 6107 & g_xr1,! in : added to g_z 6108 & ncomp,! in : nr. components 6109 & nvec, ! in : (x,y,z) 6110 & n) ! in : vector length 6111c 6112c Author: Fredy W. Aquino, Northwestern University 6113c Date : 03-15-12 6114 6115 implicit none 6116#include "errquit.fh" 6117#include "mafdecls.fh" 6118#include "global.fh" 6119#include "util.fh" 6120#include "rtdb.fh" 6121 integer ipm,ncomp,nvec,n,m1,m2 6122 integer g_x(ncomp),g_xr1 6123 double precision one 6124 one=1.0d0 6125 m1=1 6126 m2=n 6127 do ipm=1,ncomp 6128 call ga_add_patch(one,g_xr1 ,m1,m2,1,nvec, 6129 $ one,g_x(ipm),1 ,n ,1,nvec, 6130 $ g_x(ipm),1 ,n ,1,nvec) 6131 m1=m1+n 6132 m2=m2+n 6133 enddo !end-loop-ipm 6134 return 6135 end 6136 6137 subroutine update_g_z(g_z, ! in/ou: solution updated 6138 & g_zr1,! in : added to g_z 6139 & ncomp,! in : nr. components 6140 & nvec, ! in : (x,y,z) 6141 & n) ! in : vector length 6142c 6143c Author: Fredy W. Aquino, Northwestern University 6144c Date : 03-15-12 6145 6146 implicit none 6147#include "errquit.fh" 6148#include "mafdecls.fh" 6149#include "global.fh" 6150#include "util.fh" 6151#include "rtdb.fh" 6152 integer ipm,ncomp,nvec,n,m1,m2 6153 integer g_z(ncomp),g_zr1 6154 double complex one_cmplx 6155 one_cmplx=dcmplx(1.0d0,0.0d0) 6156 m1=1 6157 m2=n 6158 do ipm=1,ncomp 6159 call ga_add_patch(one_cmplx,g_zr1 ,m1,m2,1,nvec, 6160 $ one_cmplx,g_z(ipm),1 ,n ,1,nvec, 6161 $ g_z(ipm),1 ,n ,1,nvec) 6162 m1=m1+n 6163 m2=m2+n 6164 enddo !end-loop-ipm 6165 return 6166 end 6167 6168 subroutine get_cconjugate(g_a) 6169c 6170c Author: Fredy W. Aquino, Northwestern University 6171c Date : 03-15-12 6172 6173 implicit none 6174#include "errquit.fh" 6175#include "mafdecls.fh" 6176#include "global.fh" 6177#include "util.fh" 6178#include "rtdb.fh" 6179 integer g_a,i,j,ilo,ihi,jlo,jhi 6180 integer dim1,dim2,ma_type 6181 double complex number 6182c Purpose: Compute complex conjugate of g_a 6183 call ga_sync() 6184 call ga_inquire(g_a, ma_type, dim1, dim2) 6185 if (ma_type.ne.mt_dcpl) then 6186 write(0,*) ' ma_type ',ma_type,' mt_dcpl ',mt_dcpl 6187 call errquit 6188 $ ('get_cconjugate: array is not complex', g_a,0) 6189 endif 6190 call ga_distribution(g_a,ga_nodeid(),ilo,ihi,jlo,jhi) 6191 if (ilo.gt.0 .and. jlo.gt.0) then 6192 do i = ilo,ihi 6193 do j = jlo,jhi 6194 call ga_get(g_a,i,i,j,j,number,1) 6195 number = dcmplx( dreal(number), 6196 & -dimag(number)) 6197 call ga_put(g_a,i,i,j,j,number,1) 6198 enddo 6199 enddo 6200 endif 6201 call ga_sync() 6202 return 6203 end 6204 6205 subroutine get_modulus(g_a) 6206c 6207c Author: Fredy W. Aquino, Northwestern University 6208c Date : 03-15-12 6209 6210 implicit none 6211#include "errquit.fh" 6212#include "mafdecls.fh" 6213#include "global.fh" 6214#include "util.fh" 6215#include "rtdb.fh" 6216 integer g_a,i,j,ilo,ihi,jlo,jhi 6217 integer dim1,dim2,ma_type 6218 double complex number 6219 double precision mod 6220c Purpose: Compute complex conjugate of g_a 6221 call ga_sync() 6222 call ga_inquire(g_a, ma_type, dim1, dim2) 6223 if (ma_type.ne.mt_dcpl) then 6224 write(0,*) ' ma_type ',ma_type,' mt_dcpl ',mt_dcpl 6225 call errquit 6226 $ ('get_cconjugate: array is not complex', g_a,0) 6227 endif 6228 call ga_distribution(g_a,ga_nodeid(),ilo,ihi,jlo,jhi) 6229 if (ilo.gt.0 .and. jlo.gt.0) then 6230 do i = ilo,ihi 6231 do j = jlo,jhi 6232 call ga_get(g_a,i,i,j,j,number,1) 6233 mod=dreal(number)**2+ 6234 & dimag(number)**2 6235 if (mod .gt. 0.0d0) then 6236 mod=dsqrt(mod) 6237 else 6238 mod=0.0d0 6239 endif 6240 number = dcmplx(mod,0.0d0) 6241 call ga_put(g_a,i,i,j,j,number,1) 6242 enddo 6243 enddo 6244 endif 6245 call ga_sync() 6246 return 6247 end 6248 6249 subroutine getrmax_z(rmax, ! out: max(all elements g_zr) 6250 & g_zr, ! in : 6251 & n, ! in : nr. rows in g_zr 6252 & nvec, ! in : nr. cols in g_zr 6253 & ncomp)! in P nr. components in g_zr 6254c 6255c Author: Fredy W. Aquino, Northwestern University 6256c Date : 03-15-12 6257 6258 implicit none 6259#include "errquit.fh" 6260#include "mafdecls.fh" 6261#include "global.fh" 6262#include "util.fh" 6263#include "rtdb.fh" 6264 double precision dat,rmax 6265 integer ncomp,n,nvec,nreim, 6266 & i,cc,ipm,g_zr(ncomp), 6267 & g_arr ! scratch arr 6268 integer l_a,k_a 6269 external ga_maxelt 6270 nreim=2 6271 if (.not. ma_push_get(MT_DCPL, n*nvec,'gasvd',l_a,k_a)) 6272 $ call errquit('getrmax_z: a',n*nvec, MA_ERR) 6273 if (.not. ga_create(MT_DBL,nreim*n*nvec*ncomp,1, 6274 & 'getrmax_z: arr',0, 0, g_arr)) 6275 $ call errquit('lkain: failed allocating zb', 1, 6276 & GA_ERR) 6277 call ga_zero(g_arr) 6278 cc=0 6279 do ipm=1,ncomp 6280 call ga_get(g_zr(ipm),1,n,1,nvec,dcpl_mb(k_a),nvec) 6281 do i=1,n*nvec 6282 dat=dreal(dcpl_mb(k_a+i-1)) 6283 call ga_put(g_arr,cc,cc,1,1,dat,1) 6284 cc=cc+1 6285 enddo ! end-loop-i 6286 do i=1,n*nvec 6287 dat=dimag(dcpl_mb(k_a+i-1)) 6288 call ga_put(g_arr,cc,cc,1,1,dat,1) 6289 cc=cc+1 6290 enddo ! end-loop-i 6291 enddo ! end-loop-ipm 6292 call ga_maxelt(g_arr,rmax) 6293 if (ga_nodeid().eq.0) 6294 & write(*,*) 'In getrmax_z: rmax=',rmax 6295 6296 if (.not. ga_destroy(g_arr)) call errquit 6297 & ('getrmax_z: arr',0, GA_ERR) 6298 if (.not. ma_chop_stack(l_a)) call errquit('getrmax_z ma',0, 6299 & MA_ERR) 6300 return 6301 end 6302c -------------- get_precond_rmax_re -------------- START 6303 subroutine get_precond_rmax_re( 6304 & rmax, ! out: max(g_r,g_r_im) 6305 & g_r, ! in : real part of g_zr 6306 & g_Ax, ! in : real part of g_Az 6307 & precond, ! in : name of preconditioner routine 6308 & converge_precond, ! in : =.true. prec->max 6309 & omega, ! in : omega 6310 & ncomp, ! in : nr. components 6311 & iter, ! in : nr. iteration 6312 & debug) ! in : =.true. -> allow debug printouts 6313c 6314c Author: Fredy W. Aquino, Northwestern University 6315c Date : 03-15-12 6316 6317 implicit none 6318#include "errquit.fh" 6319#include "mafdecls.fh" 6320#include "global.fh" 6321#include "stdio.fh" 6322#include "util.fh" 6323 integer iter,ipm,cc,ncomp 6324 double precision rmax,omg(2), 6325 & omega,rmx(2) 6326 integer g_r(ncomp),g_Ax(ncomp) 6327 logical debug,converge_precond 6328 external precond ! preconditioner routine 6329c convergence checking: 6330c find the largest element of the residual either 6331c before or after the call to the preconditioner 6332 omg(1)=-omega 6333 omg(2)= omega 6334 if (converge_precond) then 6335 do ipm=1,ncomp 6336 call precond(g_r(ipm),omg(ipm)) 6337 enddo ! end-loop-ipm 6338 endif ! end-if-conver_precond 6339c ----- find Absolute maximum -------- START 6340 rmx(1)=0.0d0 6341 rmx(2)=0.0d0 6342 do ipm=1,ncomp 6343 call ga_maxelt(g_r(ipm),rmx(ipm)) 6344 enddo ! end-loop-ipm 6345 rmax = max(rmx(1),rmx(2)) 6346c ----- find Absolute maximum -------- END 6347 if (.not.converge_precond) then 6348 do ipm=1,ncomp 6349 call precond(g_r(ipm),omg(ipm)) 6350 enddo ! end-loop-ipm 6351 endif ! end-if-conver_precond 6352 do ipm=1,ncomp 6353 call precond(g_Ax(ipm),omg(ipm)) 6354 enddo ! end-loop-ipm 6355 return 6356 end 6357c -------------- get_precond_rmax_re -------------- END 6358 subroutine get_precond_rmax( 6359 & rmax, ! out: max(g_r,g_r_im) 6360 & g_r, ! in : real part of g_zr 6361 & g_r_im, ! in : imag part of g_zr 6362 & g_Ax, ! in : real part of g_Az 6363 & g_Ax_im, ! in : imag part of g_Az 6364 & precond, ! in : name of preconditioner routine 6365 & converge_precond, ! in : =.true. prec->max 6366 & omega, ! in : omega 6367 & gamwidth,! in : gamwidth 6368 & ncomp, ! in : nr. components 6369 & iter, ! in : nr. iteration 6370 & debug) ! in : =.true. -> allow debug printouts 6371c 6372c Author: Fredy W. Aquino, Northwestern University 6373c Date : 03-15-12 6374 6375 implicit none 6376#include "errquit.fh" 6377#include "mafdecls.fh" 6378#include "global.fh" 6379#include "stdio.fh" 6380#include "util.fh" 6381 integer iter,ipm,cc,ncomp 6382 double precision rmax,omg(2), 6383 & omega,gamwidth 6384 integer g_r(ncomp),g_r_im(ncomp), 6385 & g_Ax(ncomp),g_Ax_im(ncomp) 6386 logical debug,converge_precond 6387 external get_maxzarr, 6388 & precond ! preconditioner routine 6389 omg(1)=-omega 6390 omg(2)= omega 6391c convergence checking: 6392c find the largest element of the residual either 6393c before or after the call to the preconditioner 6394 if (converge_precond) then 6395 do ipm=1,ncomp 6396 call precond(g_r(ipm),g_r_im(ipm),omg(ipm),gamwidth) 6397 enddo ! end-loop-ipm 6398 endif ! end-if-conver_precond 6399 call get_maxzarr( 6400 & rmax, ! ou: max(g_re,g_im) 6401 & g_r, ! in: real part 6402 & g_r_im,! in: imaginary part 6403 & ncomp, ! in: nr. components 6404 & iter, ! in: iteration nr. 6405 & debug) ! in: =.true. -> allow debugging printouts 6406 if (.not.converge_precond) then 6407 do ipm=1,ncomp 6408 call precond(g_r(ipm),g_r_im(ipm) ,omg(ipm),gamwidth) 6409 enddo ! end-loop-ipm 6410 endif ! end-if-conver_precond 6411 do ipm=1,ncomp 6412 call precond(g_Ax(ipm),g_Ax_im(ipm),omg(ipm),gamwidth) 6413 enddo ! end-loop-ipm 6414 return 6415 end 6416 6417 subroutine get_maxzarr( 6418 & rmax, ! ou: max(g_re,g_im) 6419 & g_re, ! in: real part 6420 & g_im, ! in: imaginary part 6421 & ncomp, ! in: nr. components 6422 & iter, ! in: iteration nr. 6423 & debug) ! in: =.true. -> allow debugging printouts 6424c Note.- ga_maxelt -> max(abs(a(i,j)),value) 6425c 6426c Author: Fredy W. Aquino, Northwestern University 6427c Date : 03-15-12 6428 6429 implicit none 6430#include "errquit.fh" 6431#include "mafdecls.fh" 6432#include "global.fh" 6433#include "stdio.fh" 6434#include "util.fh" 6435 logical debug 6436 integer i,iter,ipm,cc,n,ncomp, 6437 & l_dat,k_dat 6438 double precision rmax 6439 integer g_re(ncomp),g_im(ncomp) 6440 external ga_maxelt 6441 n=2*ncomp 6442 if (.not.MA_Push_Get(mt_dbl,n,'hessv jfacs',l_dat,k_dat)) 6443 & call errquit('get_maxzarr: cannot allocate dat', 6444 & n, MA_ERR) 6445 cc=0 6446 do ipm=1,ncomp 6447 call ga_maxelt(g_re(ipm),dbl_mb(k_dat+cc )) 6448 call ga_maxelt(g_im(ipm),dbl_mb(k_dat+cc+1)) 6449 cc=cc+2 6450 enddo ! end-loop-ncomp 6451 rmax=-1.0d0 ! any negative number so that it pick rmax_arr(1) 6452 do i=1,2*ncomp 6453 if (dbl_mb(k_dat+i-1).gt.rmax) rmax=dbl_mb(k_dat+i-1) 6454 enddo ! end-loop-i 6455 if (debug) then 6456 if (ga_nodeid().eq.0) then 6457 write(*,1) iter,rmax, 6458 & dbl_mb(k_dat ),dbl_mb(k_dat+1), 6459 & dbl_mb(k_dat+2),dbl_mb(k_dat+3) 6460 1 format('(iter,rmax,rmax_arr)=(', 6461 & i3,',',f15.8,',[',f15.8,',',f15.8,',', 6462 & f15.8,',',f15.8,'])') 6463 endif 6464 endif ! end-if-debug 6465 if (.not.ma_pop_stack(l_dat)) 6466 $ call errquit('get_maxzarr: pop problem with l_dat',555, 6467 & MA_ERR) 6468 return 6469 end 6470 6471 subroutine get_precond_rmax_zin( 6472 & rmax, ! out: max(g_r,g_r_im) 6473 & g_zr1, ! in : complex+accumulated g_zr 6474 & g_Az1, ! in : complex+accumulated g_Az 6475 & nsub, ! in : pointer to current (g_zr,g_Az) 6476 & precond, ! in : name of preconditioner routine 6477 & converge_precond, ! in : =.true. prec->max 6478 & omega, ! in : omega 6479 & gamwidth,! in : gamwidth 6480 & ncomp, ! in : nr. components 6481 & npol, ! in : nr. polarizations 6482 & nvir, ! in : nr. virtual MOs 6483 & nocc, ! in : nr. occupied MOs 6484 & n, ! in : =nocc * nvir 6485 & nvec, ! in : =3 (x,y,z) 6486 & iter, ! in : nr. iteration 6487 & debug) ! in : =.true. -> allow debug printouts 6488c 6489c Author: Fredy W. Aquino, Northwestern University 6490c Date : 03-15-12 6491 6492 implicit none 6493#include "errquit.fh" 6494#include "mafdecls.fh" 6495#include "global.fh" 6496#include "stdio.fh" 6497#include "util.fh" 6498 integer iter,ipm,cc,ncomp,nmx,i, 6499 & npol,nvir(npol),nocc(npol) 6500 double precision rmax, 6501 & omg(2), 6502 & gam(2), 6503 & omega,gamwidth 6504 integer nsub,n,nvec, 6505 & l_max,k_max, 6506 & g_zr1,g_Az1, 6507 & g_dre,g_dim ! scratch GA used for (g_r or g_Ax) 6508 logical debug,converge_precond 6509 external conv2reim1_u,conv2complex1_u, 6510 & precond ! preconditioner routine 6511 6512c --> Create (g_dre,g_dim) scratch GA arrays 6513 if (.not. ga_create(MT_DBL,n,nvec, 6514 & 'get_precond_rmax_zin: g_dre',0,0,g_dre)) 6515 $ call errquit('get_precond_rmax_zin: failed alloc g_dre', 6516 & nvec,GA_ERR) 6517 if (.not. ga_create(MT_DBL,n,nvec, 6518 & 'get_precond_rmax_zin: g_dre',0,0,g_dim)) 6519 $ call errquit('get_precond_rmax_zin: failed alloc g_dim', 6520 & nvec,GA_ERR) 6521 nmx=2*ncomp 6522 if (.not.MA_Push_Get(mt_dbl,nmx,'hessv jfacs',l_max,k_max)) 6523 & call errquit('get_precond_rmax_zin: cannot allocate max', 6524 & nmx, MA_ERR) 6525 omg(1)=-omega 6526 omg(2)= omega 6527 gam(1)=-gamwidth 6528 gam(2)= gamwidth 6529c convergence checking: 6530c find the largest element of the residual either 6531c before or after the call to the preconditioner 6532 if (converge_precond) then 6533 cc=0 6534 do ipm=1,ncomp 6535c ------- extract g_zr1 --> (g_dre,g_dim) ------- START 6536 call conv2reim1_u( 6537 & g_dre, ! out : real arr 6538 & g_dim, ! out : imaginary arr 6539 & g_zr1, ! in : = complx(g_xre,g_xim) 6540 & 0, ! in : pointer to block 6541 & npol, ! in : nr. polarizations 6542 & nvir, ! in : nr. virtual MOs 6543 & nocc, ! in : nr. occupied MOs 6544 & ipm, ! in : =1,2 components indices 6545 & n, ! in : n rows 6546 & nvec) ! in : nvec columns 6547c ------- extract g_zr1 --> (g_dre,g_dim) ------- END 6548c call precond(g_dre,g_dim,omg(ipm),gamwidth) 6549 call precond(g_dre,g_dim,omg(ipm),gam(ipm)) ! FA-03-12-14 6550c endif 6551c ------- Collect max values -------------------- START 6552 call ga_maxelt(g_dre,dbl_mb(k_max+cc )) 6553 call ga_maxelt(g_dim,dbl_mb(k_max+cc+1)) 6554 cc=cc+2 6555c ------- Collect max values -------------------- END 6556c ------- update (g_dre,g_dim) --> g_zr1 ------- START 6557 call conv2complex1_u( 6558 & g_zr1, ! out: = complx(g_xre,g_xim) 6559 & g_dre, ! in : real arr 6560 & g_dim, ! in : imaginary arr 6561 & 0, ! in : pointer to block 6562 & npol, ! in : nr. polarizations 6563 & nvir, ! in : nr. virtual MOs 6564 & nocc, ! in : nr. occupied MOs 6565 & ipm, ! in : =1,2 components indices 6566 & n, ! in : n rows 6567 & nvec) ! in : nvec columns 6568c ------- update (g_dre,g_dim) --> g_zr1 ------- END 6569 enddo ! end-loop-ipm 6570 endif ! end-if-conver_precond 6571 if (.not.converge_precond) then 6572 cc=0 6573 do ipm=1,ncomp 6574 call conv2reim1_u( 6575 & g_dre, ! out : real arr 6576 & g_dim, ! out : imaginary arr 6577 & g_zr1, ! in : = complx(g_xre,g_xim) 6578 & 0, ! in : pointer to block 6579 & npol, ! in : nr. polarizations 6580 & nvir, ! in : nr. virtual MOs 6581 & nocc, ! in : nr. occupied MOs 6582 & ipm, ! in : =1,2 components indices 6583 & n, ! in : n rows 6584 & nvec) ! in : nvec columns 6585c ------- Collect max values -------------------- START 6586 call ga_maxelt(g_dre,dbl_mb(k_max+cc )) 6587 call ga_maxelt(g_dim,dbl_mb(k_max+cc+1)) 6588 cc=cc+2 6589c ------- Collect max values -------------------- END 6590c call precond(g_dre,g_dim,omg(ipm),gamwidth) 6591 call precond(g_dre,g_dim,omg(ipm),gam(ipm)) ! FA-03-12-14 6592 call conv2complex1_u( 6593 & g_zr1,! out: = complx(g_xre,g_xim) 6594 & g_dre,! in : real arr 6595 & g_dim,! in : imaginary arr 6596 & 0, ! in : pointer to block 6597 & npol, ! in : nr. polarizations 6598 & nvir, ! in : nr. virtual MOs 6599 & nocc, ! in : nr. occupied MOs 6600 & ipm, ! in : =1,2 components indices 6601 & n, ! in : n rows 6602 & nvec) ! in : nvec columns 6603 enddo ! end-loop-ipm 6604 endif ! end-if-conver_precond 6605c ----- obtain rmax ------- START 6606 rmax=-1.0d0 ! any negative number so that it pick rmax_arr(1) 6607 do i=1,2*ncomp 6608 if (dbl_mb(k_max+i-1).gt.rmax) rmax=dbl_mb(k_max+i-1) 6609 enddo ! end-loop-i 6610 if (debug) then 6611 if (ga_nodeid().eq.0) then 6612 write(*,1) iter,rmax, 6613 & dbl_mb(k_max ),dbl_mb(k_max+1), 6614 & dbl_mb(k_max+2),dbl_mb(k_max+3) 6615 1 format('(iter,rmax,rmax_arr)=(', 6616 & i3,',',f15.8,',[',f15.8,',',f15.8,',', 6617 & f15.8,',',f15.8,'])') 6618 endif 6619 endif ! end-if-debug 6620c ----- obtain rmax ------- END 6621 do ipm=1,ncomp 6622 call conv2reim1_u( 6623 & g_dre, ! out : real arr 6624 & g_dim, ! out : imaginary arr 6625 & g_Az1, ! in : = complx(g_xre,g_xim) 6626 & nsub, ! in : pointer to block 6627 & npol, ! in : nr. polarizations 6628 & nvir, ! in : nr. virtual MOs 6629 & nocc, ! in : nr. occupied MOs 6630 & ipm, ! in : =1,2 components indices 6631 & n, ! in : n rows 6632 & nvec) ! in : nvec columns 6633c call precond(g_dre,g_dim,omg(ipm),gamwidth) 6634 call precond(g_dre,g_dim,omg(ipm),gam(ipm)) ! FA-03-12-14 6635 call conv2complex1_u( 6636 & g_Az1,! out: = complx(g_xre,g_xim) 6637 & g_dre,! in : real arr 6638 & g_dim,! in : imaginary arr 6639 & nsub, ! in : pointer to block 6640 & npol, ! in : nr. polarizations 6641 & nvir, ! in : nr. virtual MOs 6642 & nocc, ! in : nr. occupied MOs 6643 & ipm, ! in : =1,2 components indices 6644 & n, ! in : n rows 6645 & nvec) ! in : nvec columns 6646 enddo ! end-loop-ipm 6647 if (.not. ga_destroy(g_dre)) call errquit 6648 & ('get_precond_rmax_zin: g_dre',0, GA_ERR) 6649 if (.not. ga_destroy(g_dim)) call errquit 6650 & ('get_precond_rmax_zin: g_dim',0, GA_ERR) 6651 if (.not.ma_pop_stack(l_max)) 6652 $ call errquit('get_precond_rmax_zin: pop problem with l_max', 6653 & 555,MA_ERR) 6654 return 6655 end 6656c =============== FA:complex solver ==================== END 6657