1 SUBROUTINE tce_mo2e_hybrid_2eorb_split(d_v2ga,d_v2sf, 2 1 kax_v2_alpha_offset) 3C $Id$ 4C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6C t ( p1 p2 h3 h4 )_t 7 IMPLICIT NONE 8c#include "rtdb.fh" 9#include "global.fh" 10#include "mafdecls.fh" 11#include "stdio.fh" 12#include "util.fh" 13#include "bas.fh" 14#include "schwarz.fh" 15#include "sym.fh" 16#include "sf.fh" 17#include "errquit.fh" 18#include "tce.fh" 19#include "tce_main.fh" 20c 21c 22c integer rtdb ! Run-time database 23 integer d_v2ga,d_v2sf 24 integer kax_v2_alpha_offset ! MO integrals offset 25c integer size_2e ! 2e file size 26c integer size_2e_ga,size_2e_sf 27c 28 INTEGER size_2g2a,l_2g2a,k_2g2a 29 INTEGER azone1,azone2,azone3,azone4 30 INTEGER g1b,g2b,g3b,g4b 31 INTEGER igi1,igi2,igi3,igi4 32 INTEGER ii,i,j,k,l,N,ipos1,ipos2,ipos3,ipos4 33 INTEGER del1,del2,p1rel,p2rel 34 INTEGER size_4a,l_4a,k_4a 35c 36 integer mu,nu,rho,sigma 37 integer mu_lo,mu_hi 38 integer nu_lo,nu_hi 39 integer rho_lo,rho_hi 40 integer sigma_lo,sigma_hi 41 integer mu_range 42 integer nu_range 43 integer rho_range 44 integer sigma_range 45 integer mu1,nu1,rho1,sigma1 46 integer shift_mu,shift_nu 47 integer shift_rho,shift_sigma 48 integer work1,work2 ! Work array sizes 49 integer l_work1,k_work1 ! Work array 1 50 integer l_work2,k_work2 ! Work array 2 51 integer imu1,inu1,irho1,isigma1 52c 53 integer l_movecs_orb,k_movecs_orb 54 integer l_gpair,k_gpair 55 integer len_pair,g12_shift 56c ATTENTION,ACHTUNG,UWAGA 2000 - max # of CPU 57c 58 integer size_2g2z,l_2g2z,k_2g2z 59 integer tot_azone1_sh,tot_azone2_sh 60 integer tot_azone3_sh,tot_azone4_sh 61 integer ixi,jxi,point_pair 62c 63 integer iha,ihb !number of corr. alpha, beta holes 64 integer ipa,ipb !number of corr. alpha, beta particles 65c compression 66 integer max_size_temp,size_temp,sumx 67 double precision wall,cpu,wall1,cpu1,wall2,cpu2,wall3,cpu3 68c 69 double precision tot_zone(1000) 70c 71 integer l_3a1m_offset,k_3a1m_offset,size_3a1mf 72 integer l_1a3m_offset,k_1a3m_offset,size_1a3mf 73 integer d_1a3m,d_3a1m 74 integer size_3a1m 75 integer l_3a1m,k_3a1m 76 integer size_amc 77 integer key_3a1m,offset_3a1m 78 integer l_4a_sort,k_4a_sort 79 integer size_2a2m,l_2a2m,k_2a2m 80 integer l_3a1m_sort,k_3a1m_sort 81 integer l_2a2m_aux,k_2a2m_aux 82 integer key_1a3m,offset_1a3m 83 integer l_1a3m,k_1a3m,size_1a3m 84 integer l_1a3m_sort,k_1a3m_sort 85 INTEGER IROW,ICOL,IRES 86 INTEGER INDEX_PAIR 87 integer l_4m,k_4m,size_4m,key_4m,offset_4m 88 integer sf3a1m_chunk,sf1a3m_chunk 89c 90 integer l_integral,l_coeff 91 integer k_integral,k_coeff 92 integer size_ic,size_icc,size_integral,size_coeff,max_na 93c 94 integer l_4af_offset,k_4af_offset,d_4af 95 integer k_2a2m_offset,l_2a2m_offset 96 integer sf_chunk,request 97 integer key_4af,offset_4af,size_4af 98 integer sf2a2m_chunk,key_2a2m,offset_2a2m 99 integer d_2a2m,size_2a2mf 100 character*255 filename,filename_aux 101c 102 integer size_max1,size_max2,ip_max1,ip_max2 103 integer chunk_max1,chunk_max2,i_from_x,i_to_x 104 integer isizef(5),imaxch(5) 105 integer d_max1,d_max2 106c 107 integer l_a4_offset,k_a4_offset 108 integer offset_bl4a,size_bl4a,a4_ini,a4_fin 109 integer offset_ismall,length_a4,key_ini 110 integer l_a3_offset,k_a3_offset 111 integer length_a3,offset_bl3a1m,size_bl3a1m 112 integer size_3a1mi,a3_ini,a3_fin 113c 114 integer l_a2_offset,k_a2_offset,length_a2 115 integer offset_bl2a2m,size_bl2a2m,a2_ini,a2_fin 116 integer size_1a3mi,size_2a2mi 117c 118 integer length_a1 119 integer l_a1_offset,k_a1_offset 120 integer offset_bl1a3m,size_bl1a3m,a1_ini,a1_fin 121c I/O improvements 122 integer handle_4a,handle_3a1m,handle_2a2m,handle_1a3m 123c 124c *** debug *** 125c double precision xxx,xmax 126c integer iqx 127 integer ierrcode1,ierrcode2 128c ************* 129c 130c multiple files =============== 131 integer k_offset_4a_m(1000),l_offset_4a_m(1000) 132 integer k_offset_3a1m_m(1000),l_offset_3a1m_m(1000) 133 integer k_offset_2a2m_m(1000),l_offset_2a2m_m(1000) 134 integer k_offset_1a3m_m(1000),l_offset_1a3m_m(1000) 135 integer size_4a_m(1000),size_3a1m_m(1000) 136 integer size_2a2m_m(1000),size_1a3m_m(1000) 137 integer n_4a_files,n_3a1m_files 138 integer n_2a2m_files,n_1a3m_files 139 integer handle_4a_m(1000),handle_3a1m_m(1000) 140 integer handle_2a2m_m(1000),handle_1a3m_m(1000) 141 integer my_file_to_write,my_file_to_read 142 integer n_max_files 143c 144 integer size_l(1000),n_str,size_g 145 integer addr 146c 147c *** debug *** 148 double precision xmax 149c ============================== 150 logical parallel 151c 152 INTEGER length 153 INTEGER next 154 INTEGER nprocs 155 INTEGER count 156 integer nxtask 157 external nxtask 158 logical nodezero 159 logical idiskl 160c 161c 162c 163ccx idisk=.true. 164 if(idisk.eq.0) then 165 idiskl=.false. 166 else 167 idiskl=.true. 168 end if 169c 170 parallel = .true. 171c 172c 173 max_size_temp=imaxsize**4 174c 175c 176 do ii=1,1000 177 tot_zone(ii)=0.0d0 178 enddo 179 if(atpart.gt.1000) 180 & call errquit('tce_zones: atpart too big',1,MA_ERR) 181 sumx=0 182 do ii=1,atpart 183 tot_zone(ii)=sumx 184 sumx=sumx+nalength(ii) 185 enddo 186c 187 nodezero=(ga_nodeid().eq.0) 188c 189c *** debug *** 190c if(nodezero) then 191c write(6,*)'--------- NEW LOOP STRUCTURE --------' 192c call util_flush(6) 193c end if 194c ************* 195c 196c this module is called only if intorb = .true. 197c N is the number of correlated orbitals 198 N = nmo(1) - nfc(1) - nfv(1) 199 iha = nocc(1)-nfc(1) 200 ihb = nocc(ipol)-nfc(ipol) 201 ipa = nmo(1)-nocc(1)-nfv(1) 202 ipb = nmo(ipol)-nocc(ipol)-nfv(ipol) 203c 204 sf_chunk=(imaxsize+10)**4 205 sf3a1m_chunk=((imaxsize+10)**3)*tile_dim 206 sf2a2m_chunk=((tile_dim)**2)*((imaxsize+10)**2) 207 sf1a3m_chunk=((tile_dim)**3)*(imaxsize+10) 208c 209c l_integral and l_coeff local files are opened here 210c ATTENTION,ACHTUNG,UWAGA - "manually" defined 211cc size_ic=2*(imaxsize+10)**4 212cc size_ic=2*(imaxsize)**4 213 max_na=0 214 do ixi=1,atpart 215 if(nalength(ixi).gt.max_na) max_na=nalength(ixi) 216 enddo 217c it was 218cc size_ic=2*(max_na)**4+1 219c it is 220 size_ic=2*((max_na)**4)+1 221 size_icc=tile_dim*max_na 222c 223 if(nodezero) then 224 write(6,*)'2_EL_BATCH AND COEFF MATRIX' 225 write(6,*)'size_ic',size_ic 226 write(6,*)'size_icc',size_icc 227 write(6,*)'tile_dim',tile_dim 228 write(6,*)'max_na',max_na 229 call util_flush(6) 230 end if 231c 232 if (.not.ma_push_get(mt_dbl,size_ic,'l_int', 233 1 l_integral,k_integral)) 234 1 call errquit('tce_4s: MA problem l_int',0,MA_ERR) 235c 236 if (.not.ma_push_get(mt_dbl,size_icc,'l_coeff', 237 1 l_coeff,k_coeff)) 238 1 call errquit('tce_4s: MA problem l_coeff',0,MA_ERR) 239c 240c 241c 242 chunk_max1=size_ic 243 chunk_max2=size_ic 244c 245c offsets for 2 246c 247c 248c DISK USAGE ONLY !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 249c 250 if(idiskl) then 251 if(.not.parallel) 252 1 call errquit('sf only for parallel runs',1,DISK_ERR) 253c 254c 255c dummy for idiskl true 256c 257c 258 else 259 if(.not.parallel) 260 1 call errquit('sf only for parallel runs',1,DISK_ERR) 261 if(parallel) call ga_sync() 262 if(size_4af.le.size_max2) then 263 call createfile(filename,d_max1,size_max1) 264 call reconcilefile(d_max1,size_max1) 265 call ga_zero(d_max1) 266 call createfile(filename,d_max2,size_max2) 267 call reconcilefile(d_max2,size_max2) 268 call ga_zero(d_max2) 269 else 270 call createfile(filename,d_max2,size_max2) 271 call reconcilefile(d_max2,size_max2) 272 call ga_zero(d_max2) 273 call createfile(filename,d_max1,size_max1) 274 call reconcilefile(d_max1,size_max1) 275 call ga_zero(d_max1) 276 end if 277 end if 278c 279c 280c alpha orbitals only 281c 282 if (.not.ma_push_get(mt_dbl,nbf*(iha+ipa) 283 1 ,"sorted MO coeffs", 284 2 l_movecs_orb,k_movecs_orb)) 285 3 call errquit('tce_mo2e_zone: MA problem 1',0, 286 2 BASIS_ERR) 287 call dfill(nbf*(iha+ipa),0.0d0, dbl_mb(k_movecs_orb), 1) 288 do i=1,iha 289 do isigma1=1,nbf 290 dbl_mb(k_movecs_orb+(i-1)*nbf+isigma1-1)= 291 & dbl_mb(k_movecs_sorted+(i-1)*nbf+isigma1-1) 292 enddo 293 enddo 294 do i=iha+1,iha+ipa 295 do isigma1=1,nbf 296 dbl_mb(k_movecs_orb+(i-1)*nbf+isigma1-1)= 297 & dbl_mb(k_movecs_sorted+(i+ihb-1)*nbf+isigma1-1) 298 enddo 299 enddo 300c 301c 302c 303c 304 n_max_files=1000 305 do i=1,n_max_files 306 k_offset_4a_m(i)=0 307 l_offset_4a_m(i)=0 308 k_offset_3a1m_m(i)=0 309 l_offset_3a1m_m(i)=0 310 k_offset_2a2m_m(i)=0 311 l_offset_2a2m_m(i)=0 312 k_offset_1a3m_m(i)=0 313 l_offset_1a3m_m(i)=0 314 size_4a_m(i)=0 315 size_3a1m_m(i)=0 316 size_2a2m_m(i)=0 317 size_1a3m_m(i)=0 318 enddo 319c 320c write(6,*)'step1' 321c call util_flush(6) 322c 323cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 324ccx call tce_1a3m_offsetyy1(l_offset_1a3m_m,k_offset_1a3m_m, xx 325ccx & size_1a3m_m,n_1a3m_files) xx 326cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 327c 328 do i=1,1000 329 size_l(i)=0 330 enddo 331c 332 i = 0 333 DO g3b = 1,noa+nva !k 334 i=i+1 335 length=0 336 DO g4b = g3b,noa+nva !l 337 DO g2b = 1,noa+nva !i 338 DO azone1 = 1,atpart !nu 339 length = length + 1 340 END DO 341 END DO 342 END DO 343 size_l(i)=length 344 END DO 345 n_str=i 346 n_1a3m_files=n_str 347c 348 do i=1,n_str 349 IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname4', 350 & l_offset_1a3m_m(i),k_offset_1a3m_m(i))) 351 & CALL ERRQUIT('tce_t2_offset',0,MA_ERR) 352 int_mb(k_offset_1a3m_m(i)) = size_l(i) 353c 354c write(6,*)'1a3m yy1 i size_l(i)',i,size_l(i) 355c call util_flush(6) 356c 357 enddo 358c 359 i = 0 360 DO g3b = 1,noa+nva !k 361 i=i+1 362 addr=0 363 size_g=0 364 length=size_l(i) 365 DO g4b = g3b,noa+nva !l 366 DO g2b = 1,noa+nva !i 367 DO azone1 = 1,atpart !nu 368 addr = addr + 1 369 int_mb(k_offset_1a3m_m(i)+addr)=azone1-1+atpart*(g2b-1+(noa+nva)* 370 & (g4b-1+(noa+nva)*(g3b-1))) 371 int_mb(k_offset_1a3m_m(i)+length+addr) = size_g 372 size_g = size_g + 373 & int_mb(k_range_alpha+g3b-1) * int_mb(k_range_alpha+g4b-1) 374 & * int_mb(k_range_alpha+g2b-1) * nalength(azone1) 375 END DO 376 END DO 377 END DO 378 size_1a3m_m(i)=size_g 379 END DO 380c 381c 382c 383c 384c write(6,*)'step2 n_1a3m_files',n_1a3m_files 385c call util_flush(6) 386c 387cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 388cxxxxx call tce_2a2m_offsetyy1(l_offset_2a2m_m,k_offset_2a2m_m, xx 389cxxxxx & size_2a2m_m,n_2a2m_files) xx 390cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 391c 392 do i=1,1000 393 size_l(i)=0 394 enddo 395c 396 i = 0 397 DO g3b = 1,noa+nva !k 398 i=i+1 399 length=0 400 DO g4b = g3b,noa+nva !l 401 DO azone1 = 1,atpart !nu 402 DO azone2 = azone1,atpart !mu 403 length = length + 1 404 END DO 405 END DO 406 END DO 407 size_l(i)=length 408 END DO 409 n_str=i 410 n_2a2m_files=n_str 411c 412 do i=1,n_str 413 IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname3', 414 & l_offset_2a2m_m(i),k_offset_2a2m_m(i))) 415 & CALL ERRQUIT('tce_t2_offset',0,MA_ERR) 416 int_mb(k_offset_2a2m_m(i)) = size_l(i) 417c 418c write(6,*)'2a2m yy1 i size_l(i)',i,size_l(i) 419c call util_flush(6) 420c 421 enddo 422c 423 i = 0 424 DO g3b = 1,noa+nva !k 425 i=i+1 426 addr=0 427 size_g=0 428 length=size_l(i) 429 DO g4b = g3b,noa+nva !l 430 DO azone1 = 1,atpart !nu 431 DO azone2 = azone1,atpart !mu 432 addr = addr + 1 433 int_mb(k_offset_2a2m_m(i)+addr)=azone2 - 1 + atpart*( azone1 - 1 + 434 & atpart*(g4b - 1 + (noa+nva) * (g3b-1))) 435 int_mb(k_offset_2a2m_m(i)+length+addr) = size_g 436 size_g = size_g + 437 & int_mb(k_range_alpha+g3b-1) * int_mb(k_range_alpha+g4b-1) 438 & * nalength(azone1) * nalength(azone2) 439 END DO 440 END DO 441 END DO 442 size_2a2m_m(i)=size_g 443 END DO 444c 445c 446c 447c write(6,*)'step3,n_2a2m_files',n_2a2m_files 448c call util_flush(6) 449cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 450ccx call tce_3a1m_offsetyy1(l_offset_3a1m_m,k_offset_3a1m_m, xxx 451ccx & size_3a1m_m,n_3a1m_files) xxx 452cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 453c write(6,*)'step4 n_3a1m_files' 454c call util_flush(6) 455c 456 do i=1,1000 457 size_l(i)=0 458 enddo 459c 460 i=0 461 DO azone1 = 1,atpart !nu 462 i=i+1 463 length=0 464 DO azone2 = azone1,atpart !mu 465 DO g4b = 1,noa+nva !g2b 466 DO azone3 = 1,atpart !sigma 467 length = length + 1 468 END DO 469 END DO 470 END DO 471 size_l(i)=length 472 END DO 473 n_str=i 474 n_3a1m_files=n_str 475c *** debug *** 476c write(6,*)'from 3a1m' 477c do i=1,n_str 478c write(6,*)'size_l(i) i',size_l(i),i 479c call util_flush(6) 480c enddo 481c write(6,*) 482c ************* 483c 484 do i=1,n_str 485 IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname2', 486 & l_offset_3a1m_m(i),k_offset_3a1m_m(i))) 487 & CALL ERRQUIT('tce_t2_offset',0,MA_ERR) 488 int_mb(k_offset_3a1m_m(i)) = size_l(i) 489c 490c write(6,*)'3a1m yy1 i size_l(i)',i,size_l(i) 491c call util_flush(6) 492c 493 enddo 494c 495 i=0 496 DO azone1 = 1,atpart !nu 497 i=i+1 498 addr=0 499 size_g=0 500 length=size_l(i) 501 DO azone2 = azone1,atpart !mu 502 DO g4b = 1,noa+nva !g2b 503 DO azone3 = 1,atpart !sigma 504 addr = addr + 1 505 int_mb(k_offset_3a1m_m(i)+addr)=azone3-1+atpart*(g4b-1+(noa+nva)* 506 & (azone2 - 1 + atpart * (azone1 - 1))) 507 int_mb(k_offset_3a1m_m(i)+length+addr) = size_g 508 size_g = size_g + nalength(azone1) * nalength(azone2) * 509 & nalength(azone3) * int_mb(k_range_alpha+g4b-1) 510 END DO 511 END DO 512 END DO 513 size_3a1m_m(i)=size_g 514 END DO 515c 516cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 517cxx call tce_4a_offsetyy1(l_offset_4a_m,k_offset_4a_m, xxxx 518cxx & size_4a_m,n_4a_files) xxxx 519cxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx 520c 521 do i=1,1000 522 size_l(i)=0 523 enddo 524c 525 i = 0 526 DO azone1 = 1,atpart !nu 527 i=i+1 528 length=0 529 DO azone2 = azone1,atpart !mu 530 DO azone3 = 1,atpart !sigma 531 DO azone4 = azone3,atpart !rho 532 length = length + 1 533 END DO 534 END DO 535 END DO 536 size_l(i)=length 537 END DO 538 n_str=i 539 n_4a_files=n_str 540c 541 do i=1,n_str 542 IF (.not.MA_PUSH_GET(mt_int,2*size_l(i)+1,'noname1', 543 & l_offset_4a_m(i),k_offset_4a_m(i))) 544 & CALL ERRQUIT('tce_t2_offset',0,MA_ERR) 545 int_mb(k_offset_4a_m(i)) = size_l(i) 546c 547c write(6,*)'4a yy1 i size_l(i)',i,size_l(i) 548c call util_flush(6) 549c 550 enddo 551c 552 i=0 553 DO azone1 = 1,atpart !nu 554 i=i+1 555 addr=0 556 size_g=0 557 length=size_l(i) 558 DO azone2 = azone1,atpart !mu 559 DO azone3 = 1,atpart !sigma 560 DO azone4 = azone3,atpart !rho 561 addr = addr + 1 562 int_mb(k_offset_4a_m(i)+addr)=azone4 - 1 + atpart * (azone3 - 1 + 563 & atpart * (azone2 - 1 + atpart * (azone1 - 1))) 564 int_mb(k_offset_4a_m(i)+length+addr) = size_g 565 size_g = size_g + nalength(azone1) * nalength(azone2) * 566 & nalength(azone3) * nalength(azone4) 567 END DO 568 END DO 569 END DO 570 size_4a_m(i)=size_g 571 END DO 572c 573c 574c 575c 576c 577c write(6,*)'step5 n_4a_files',n_4a_files 578c call util_flush(6) 579c debug ******* 580c stop 581c ************* 582c 583c *** debug *** 584 if(nodezero) then 585 write(6,*)'n_4a_files',n_4a_files 586 write(6,*)'n_3a1m_files',n_3a1m_files 587 write(6,*)'n_2a2m_files',n_2a2m_files 588 write(6,*)'n_1a3m_files',n_1a3m_files 589 write(6,*)'atpart',atpart 590 write(6,*)'noa+nva',noa+nva 591 write(6,*)'noa',noa 592 write(6,*)'nva',nva 593 call util_flush(6) 594 end if 595c ************* 596c 597c 598 call int_mem_2e4c(work1,work2) 599 if (.not.ma_push_get(mt_dbl,work1,'work1',l_work1,k_work1)) 600 1 call errquit('tce_ao2e: MA problem work1',0,MA_ERR) 601 if (.not.ma_push_get(mt_dbl,work2,'work2',l_work2,k_work2)) 602 1 call errquit('tce_ao2e: MA problem work2',1,MA_ERR) 603c 604c 605c 606 607 if(nodezero) then 608 write(6,*)'before sf_create' 609 write(6,*)'n_4a_files',n_4a_files 610 write(6,*)'sizes:' 611 do i=1,n_4a_files 612 write(6,301) i,size_4a_m(i) 613 enddo 614 write(6,*)'-----------------' 615 301 format('size_4a_m(i)',2x,i4,2x,i10) 616 call util_flush(6) 617 end if 618c 619 if(idiskl) then 620 do i=1,n_4a_files 621ccx call tce_filenameindexed(i,'a4f',filename_aux) 622ccx call util_file_name(filename_aux,.false.,.false.,filename) 623 call tce_filename_4ind(i,'a4f',filename) 624c *** debug *** 625c write(6,*)'filename=',filename,i,ga_nodeid() 626c write(6,*)'size_4a_m(i)',size_4a_m(i),i,ga_nodeid() 627c 628c ************* 629 if (sf_create(filename,dble(bytes)*dble(size_4a_m(i)), 630 1 dble(bytes)*dble(size_4a_m(i)),chunk_max1,handle_4a_m(i)) 631 1 .ne.0) 632 2 call errquit('4-index: sf problem opening 4af',0,DISK_ERR) 633 enddo 634 end if 635c 636 if(nodezero) then 637 write(6,*)'after sf_create' 638 call util_flush(6) 639 end if 640c 641c ============================ 642c 643 cpu = - util_cpusec() 644 wall = - util_wallsec() 645c 646 nprocs = GA_NNODES() 647 count = 0 648 next = NXTASK(nprocs, 1) 649c attention: I have interchanged the orderign 650c from azone1 azone2 azone3 azone4 651c to azone3 azone4 azone1 azone2 652c DO azone1 = 1,atpart !nu 653c DO azone2 = azone1,atpart !mu 654 DO azone3 = 1,atpart !sigma 655 DO azone4 = azone3,atpart !rho 656 DO azone1 = 1,atpart !nu 657 DO azone2 = azone1,atpart !mu 658 IF (next.eq.count) THEN 659c --------------------------- 660 my_file_to_write=azone1 661c(atpart*(atpart+1))/2- 662c 1 ((atpart-azone1+1)*(atpart-azone1))/2- 663c 1 (atpart-azone2+1)+1 664 size_4a = nalength(azone1)*nalength(azone2)* 665 1 nalength(azone3)*nalength(azone4) 666 if(.not.ma_push_get(mt_dbl,size_4a,'4a',l_4a,k_4a)) 667 1 call errquit('tce_4af_zones1: MA problem',0,MA_ERR) 668 call dfill(size_4a, 0.0d0, dbl_mb(k_4a), 1) 669 shift_mu = 0 670 do mu = a2length(azone2)+1,a2length(azone2+1) 671 if (.not.bas_cn2bfr(ao_bas_han,mu,mu_lo,mu_hi)) 672 1 call errquit('tce_ao2e: basis fn range problem 1',0, 673 2 BASIS_ERR) 674 mu_range = mu_hi - mu_lo + 1 675 shift_nu = 0 676 do nu = a2length(azone1)+1,a2length(azone1+1) 677 if (.not.bas_cn2bfr(ao_bas_han,nu,nu_lo,nu_hi)) 678 1 call errquit('tce_ao2e: basis fn range problem 1',0, 679 2 BASIS_ERR) 680 nu_range = nu_hi - nu_lo + 1 681 shift_rho = 0 682 do rho = a2length(azone4)+1,a2length(azone4+1) 683 if (.not.bas_cn2bfr(ao_bas_han,rho,rho_lo,rho_hi)) 684 1 call errquit('tce_ao2e: basis fn range problem 1',0, 685 2 BASIS_ERR) 686 rho_range = rho_hi - rho_lo + 1 687 shift_sigma = 0 688 do sigma = a2length(azone3)+1,a2length(azone3+1) 689 if (.not.bas_cn2bfr(ao_bas_han,sigma,sigma_lo,sigma_hi)) 690 1 call errquit('tce_ao2e: basis fn range problem 1',0, 691 2 BASIS_ERR) 692 sigma_range = sigma_hi - sigma_lo + 1 693 if (schwarz_shell(rho,sigma)*schwarz_shell(mu,nu) 694 1 .ge. tol2e) then 695 call int_2e4c(ao_bas_han,mu,nu,ao_bas_han,rho,sigma, 696 1 work2,dbl_mb(k_work2),work1,dbl_mb(k_work1)) 697 i=0 698 do mu1 = 1,mu_range 699 do nu1 = 1,nu_range 700 do rho1 = 1,rho_range 701 do sigma1 = 1,sigma_range 702 i=i+1 703 inu1=nu1+shift_nu 704 isigma1=sigma1+shift_sigma 705 imu1=mu1+shift_mu 706 irho1=rho1+shift_rho 707c (isigma1,irho1|inu1, imu1) 708c differnce with other versiosn 709c here 710 ipos1=(((inu1-1)*nalength(azone2)+imu1-1)* 711 1 nalength(azone3)+isigma1-1)*nalength(azone4) 712 2 +irho1 713 dbl_mb(k_4a+ipos1-1)=dbl_mb(k_work1+i-1) 714 enddo 715 enddo 716 enddo 717 enddo 718 end if !schwarz screening 719 shift_sigma = shift_sigma + sigma_range 720 enddo !sigma 721 shift_rho = shift_rho + rho_range 722 enddo !rho 723 shift_nu = shift_nu + nu_range 724 enddo !nu 725 shift_mu = shift_mu + mu_range 726 enddo !mu 727c 728c fixing offsets and sf_writing 729 key_4af=azone4 - 1 + atpart * (azone3 - 1 + 730 & atpart * (azone2 - 1 + atpart * (azone1 - 1))) 731 call tce_hash(int_mb(k_offset_4a_m(my_file_to_write)), 732 & key_4af,offset_4af) 733 if(idiskl) then !---- 734c *** debug *** 735c xmax=0.0d0 736c do i=1,size_4a 737c xmax=xmax+dbl_mb(k_4a+i-1) 738c enddo 739c write(6,200) azone4,azone3,azone2,azone1,xmax 740c 200 format('4A ',4i5,3x,f19.8) 741c call util_flush(6) 742c ************* 743 ierrcode1=sf_write(handle_4a_m(my_file_to_write), 744 1 dble(bytes)*dble(offset_4af), 745 1 dble(bytes)*dble(size_4a),dbl_mb(k_4a),request) 746ccx if (sf_write(i_to_x,dble(bytes)*dble(offset_4af), 747ccx 1 dble(bytes)*dble(size_4a),dbl_mb(k_4a),request).ne.0) 748ccx 1 THEN 749 if(ierrcode1.ne.0) then 750 write(6,8154)ierrcode1 751 write(6,8155)ga_nodeid(),key_4af,offset_4af,size_4a 752 call util_flush(6) 753 call errquit('zones put: sf problem2x1',1,DISK_ERR) 754 end if 755 ierrcode2=sf_wait(request) 756ccx if (sf_wait(request).ne.0) 757 if(ierrcode2.ne.0) then 758 write(6,8153)ierrcode2 759 call util_flush(6) 760 call errquit('zones put: sf problem3x1',2,DISK_ERR) 761 end if 762 else 763 call ga_put(i_to_x,offset_4af+1,offset_4af+size_4a,1,1, 764 1 dbl_mb(k_4a),size_4a) 765 end if !---- 766c closing l_4a file 767 if (.not.ma_pop_stack(l_4a)) 768 1 call errquit('tce_mo2e_4af2: l_4a',15,MA_ERR) 769c --------------------------- 770 next = NXTASK(nprocs, 1) 771 END IF 772 count = count + 1 773 ENDDO !azone4 774 ENDDO !azone3 775 ENDDO !azone2 776 ENDDO !azone1 777c 778c 779 call ga_sync() 780 next = nxtask(-nprocs,1) 781c 782 cpu = cpu + util_cpusec() 783 wall = wall + util_wallsec() 784 if(nodezero) then 785 write(6,*)'4A integrals cpu,wall ',cpu,wall 786 call util_flush(6) 787 end if 788c 789 if (.not.ma_pop_stack(l_work2)) 790 1 call errquit('tce_ao2e: MA problem',14,MA_ERR) 791 if (.not.ma_pop_stack(l_work1)) 792 1 call errquit('tce_ao2e: MA problem',15,MA_ERR) 793c 794c 795 if(nodezero) then 796 write(6,*)'STEP2 4index' 797 call util_flush(6) 798 end if 799c 800c 801c 802c 803c 804c DISK CHANGES =============== 3A1M 805c closing/reopening handle_4a_m files 806c opening handle_3a1m_m files 807 if(idiskl) then 808c 809 do i=1,n_4a_files 810 if(sf_rwtor(handle_4a_m(i)).ne.0) 811 2 call errquit('4-index: sf_rwtor 4a',0,DISK_ERR) 812 enddo 813c 814 do i=1,n_3a1m_files 815ccx call tce_filenameindexed(i,'3a1mf',filename_aux) 816ccx call util_file_name(filename_aux,.false.,.false.,filename) 817 call tce_filename_4ind(i,'3a1mf',filename) 818 if (sf_create(filename,dble(bytes)*dble(size_3a1m_m(i)), 819 1 dble(bytes)*dble(size_3a1m_m(i)),chunk_max1, 820 1 handle_3a1m_m(i)).ne.0) 821 2 call errquit('4-index: sf problem opening 3a1mf',0,DISK_ERR) 822 enddo 823c 824 end if ! idiskl 825c ============================ 826c 827 cpu = - util_cpusec() 828 wall = - util_wallsec() 829c 830c 3A1M part here 831c 832 nprocs = GA_NNODES() 833 count = 0 834 next = NXTASK(nprocs, 1) 835c 836c changed ordering 837c from: 838c azone1 azone2 g4b azone3 839c to: 840c g4b azone3 azone1 azone2 841c 842c DO azone1 = 1,atpart !nu 843c DO azone2 = azone1,atpart !mu 844 DO g4b = 1,noa+nva !k 845 DO azone3 = 1,atpart !sigma 846 DO azone1 = 1,atpart !nu 847 DO azone2 = azone1,atpart !mu 848ccx DO g4b = 1,noa+nva !k 849c 850 IF (next.eq.count) THEN 851c 852 my_file_to_read=azone1 853c(atpart*(atpart+1))/2- 854c 1 ((atpart-azone1+1)*(atpart-azone1))/2- 855c 1 (atpart-azone2+1)+1 856 my_file_to_write=azone1 857c(atpart*(atpart+1))/2- 858c 1 ((atpart-azone1+1)*(atpart-azone1))/2- 859c 1 (atpart-azone2+1)+1 860c 861 size_3a1m=int_mb(k_range_alpha+g4b-1) 862 1 *nalength(azone1)*nalength(azone2)*nalength(azone3) 863 if (.not.ma_push_get(mt_dbl,size_3a1m,'3a1m',l_3a1m,k_3a1m)) 864 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 865 call dfill(size_3a1m, 0.0d0, dbl_mb(k_3a1m), 1) 866c 867c routine for offset 868c 869 call a4_offset(azone1,azone2,azone3,size_ic, 870 & l_a4_offset,k_a4_offset) 871c 872 length_a4=int_mb(k_a4_offset) 873 DO ii=1,length_a4 874 a4_ini = int_mb(k_a4_offset+ii) 875 a4_fin = int_mb(k_a4_offset+length_a4+ii) 876 key_ini=a4_ini - 1 + atpart * (azone3 - 1 + 877 & atpart * (azone2 - 1 + atpart * (azone1 - 1))) 878 call tce_hash(int_mb(k_offset_4a_m(my_file_to_read)), 879 & key_ini,offset_bl4a) 880c 881 size_bl4a = int_mb(k_a4_offset+2*length_a4+ii) 882 if(idiskl) then !--------- 883 ierrcode1=sf_read(handle_4a_m(my_file_to_read), 884 1 dble(bytes)*dble(offset_bl4a), 885 1 dble(bytes)*dble(size_bl4a),dbl_mb(k_integral), 886 1 request) 887ccx if (sf_read(i_from_x,dble(bytes)*dble(offset_bl4a), 888ccx 1 dble(bytes)*dble(size_bl4a),dbl_mb(k_integral), 889ccx 1 request).ne.0) THEN 890 if(ierrcode1.ne.0) THEN 891 write(6,*)'STEP2_step1' 892 write(6,8153)ierrcode1 893 write(6,8155)ga_nodeid(),key_ini,offset_bl4a,size_bl4a 894 write(6,*)'length_a4',length_a4 895 write(6,*)'ii=',ii 896 write(6,*)'i_from_x',i_from_x 897 call util_flush(6) 898 call errquit('zones put: sf problem2x2',1,DISK_ERR) 899 end if 900 ierrcode2=sf_wait(request) 901ccx if (sf_wait(request).ne.0) 902 if (ierrcode2.ne.0) then 903 write(6,8154)ierrcode2 904 call util_flush(6) 905 call errquit('zones put: sf problem3x2',2,DISK_ERR) 906 end if 907 else 908 call ga_get(i_from_x,offset_bl4a+1,offset_bl4a+size_bl4a,1,1, 909 1 dbl_mb(k_integral),1) 910 end if !-------------- 911c 912 offset_ismall=0 913 do i=a4_ini,a4_fin ! over small i ------------------ 914 tot_azone4_sh=tot_zone(i) 915 j=0 916 do irho1 = 1,nalength(i) 917 do igi4=1,int_mb(k_range_alpha+g4b-1) 918 j=j+1 919 ipos1=(int_mb(k_offset_alpha+g4b-1)+igi4-1)*nbf+tot_azone4_sh 920 & +irho1 921 dbl_mb(k_coeff+j-1)=dbl_mb(k_movecs_orb+ipos1-1) 922 enddo 923 enddo 924c C(g4b irho)* v(irho,isigma,imu,inu) 925 call dgemm('N','N', 926 & int_mb(k_range_alpha+g4b-1), 927 & nalength(azone1)*nalength(azone2)*nalength(azone3), 928 & nalength(i), 929 & 1.0d0,dbl_mb(k_coeff),int_mb(k_range_alpha+g4b-1), 930 & dbl_mb(k_integral+offset_ismall),nalength(i),1.0d0, 931 & dbl_mb(k_3a1m),int_mb(k_range_alpha+g4b-1)) 932c 933 offset_ismall=offset_ismall+nalength(azone1)*nalength(azone2)* 934 1 nalength(azone3)*nalength(i) 935 enddo ! over small i ---------------------- 936c 937 ENDDO ! over ii 938 if (.not.ma_pop_stack(l_a4_offset)) 939 1 call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR) 940c 941c 942c 943c 944 DO azone4 = 1, azone3-1 ! second part ---- 945c getting piece of 4a 946 size_4a = nalength(azone1)*nalength(azone2)* 947 1 nalength(azone3)*nalength(azone4) 948 if(azone3.le.azone4) then 949 key_4af=azone4 - 1 + atpart * (azone3 - 1 + 950 & atpart * (azone2 - 1 + atpart * (azone1 - 1))) 951 else 952 key_4af=azone3 - 1 + atpart * (azone4 - 1 + 953 & atpart * (azone2 - 1 + atpart * (azone1 - 1))) 954 end if 955 call tce_hash(int_mb(k_offset_4a_m(my_file_to_read)), 956 1 key_4af,offset_4af) 957 if(idiskl) then !--------- 958 ierrcode1=sf_read(handle_4a_m(my_file_to_read), 959 1 dble(bytes)*dble(offset_4af), 960 1 dble(bytes)*dble(size_4a),dbl_mb(k_integral),request) 961ccx if (sf_read(i_from_x,dble(bytes)*dble(offset_4af), 962ccx 1 dble(bytes)*dble(size_4a),dbl_mb(k_integral),request).ne.0) 963ccx 1 THEN 964 if(ierrcode1.ne.0) then 965 write(6,*)'STEP2-step1b' 966 write(6,8153)ierrcode1 967 write(6,8155)ga_nodeid(),key_4af,offset_4af,size_4a 968 call errquit('zones put: sf problem2x3',1,DISK_ERR) 969 end if 970 ierrcode2=sf_wait(request) 971ccx if (sf_wait(request).ne.0) 972 if(ierrcode2.ne.0) then 973 write(6,8154)ierrcode2 974 call util_flush(6) 975 call errquit('zones put: sf problem3x3',2,DISK_ERR) 976 end if 977 else 978 call ga_get(i_from_x,offset_4af+1,offset_4af+size_4a,1,1, 979 1 dbl_mb(k_integral),1) 980 end if !-------------- 981c 982 if(azone4.lt.azone3) then 983 if(.not.ma_push_get(mt_dbl,size_4a,'4a_s',l_4a_sort,k_4a_sort)) 984 1 call errquit('tce_4af_zones1: MA problem',0,MA_ERR) 985 CALL TCE_SORT_4KG_(dbl_mb(k_integral),dbl_mb(k_4a_sort), 986 & nalength(azone3),nalength(azone4), 987 & nalength(azone2),nalength(azone1), 988 &2,1,3,4,1.0d0) 989 do i=1,size_4a 990 dbl_mb(k_integral+i-1)=dbl_mb(k_4a_sort+i-1) 991 enddo 992 if (.not.ma_pop_stack(l_4a_sort)) 993 1 call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR) 994 end if 995c 996c C(g4b irho) ==> l_2g2z 997c 998 size_amc=int_mb(k_range_alpha+g4b-1) * 999 1 nalength(azone4) 1000 i=0 1001 tot_azone4_sh=tot_zone(azone4) 1002 do irho1 = 1,nalength(azone4) 1003 do igi4=1,int_mb(k_range_alpha+g4b-1) 1004 i=i+1 1005 ipos1=(int_mb(k_offset_alpha+g4b-1)+igi4-1)*nbf+tot_azone4_sh 1006 & +irho1 1007 dbl_mb(k_coeff+i-1)=dbl_mb(k_movecs_orb+ipos1-1) 1008 enddo 1009 enddo 1010c C(g4b irho)* v(irho,isigma,imu,inu) 1011 call dgemm('N','N', 1012 & int_mb(k_range_alpha+g4b-1), 1013 & nalength(azone1)*nalength(azone2)*nalength(azone3), 1014 & nalength(azone4), 1015 & 1.0d0,dbl_mb(k_coeff),int_mb(k_range_alpha+g4b-1), 1016 & dbl_mb(k_integral),nalength(azone4),1.0d0, 1017 & dbl_mb(k_3a1m),int_mb(k_range_alpha+g4b-1)) 1018c 1019 ENDDO 1020c write to file 1021 key_3a1m = azone3-1+atpart*(g4b-1+(noa+nva)* 1022 & (azone2 - 1 + atpart * (azone1 - 1))) 1023 call tce_hash(int_mb(k_offset_3a1m_m(my_file_to_write)), 1024 & key_3a1m,offset_3a1m) 1025 if(idiskl) then ! -------- 1026c *** debug *** 1027c xmax=0.0d0 1028c do i=1,size_3a1m 1029c xmax=xmax+dbl_mb(k_3a1m+i-1) 1030c enddo 1031c write(6,201) azone3,g4b,azone2,azone1,xmax 1032c 201 format('3A1M ',4i5,3x,f19.8) 1033c call util_flush(6) 1034c ************* 1035 ierrcode1=sf_write(handle_3a1m_m(my_file_to_write), 1036 1 dble(bytes)*dble(offset_3a1m), 1037 1 dble(bytes)*dble(size_3a1m),dbl_mb(k_3a1m),request) 1038 if (ierrcode1.ne.0) then 1039 write(6,*)'WRITE STEP3' 1040 write(6,8156) ierrcode1 1041 write(6,*)'offset_3a1m=',offset_3a1m 1042 write(6,*)'size_3a1m=',size_3a1m 1043 write(6,*)'i_to_x',i_to_x 1044 call util_flush(6) 1045 call errquit('zones put: sf problem21-b',1,DISK_ERR) 1046 end if 1047 ierrcode2=sf_wait(request) 1048ccx if (sf_wait(request).ne.0) 1049 if(ierrcode2.ne.0) then 1050 write(6,8157)ierrcode2 1051 call errquit('zones put: sf problem31-b',2,DISK_ERR) 1052 end if 1053 else 1054 call ga_put(i_to_x,offset_3a1m+1,offset_3a1m+size_3a1m,1,1, 1055 1 dbl_mb(k_3a1m),size_3a1m) 1056 end if ! --------- 1057c 1058 if (.not.ma_pop_stack(l_3a1m)) 1059 1 call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR) 1060c 1061 next = NXTASK(nprocs, 1) 1062 END IF 1063 count = count + 1 1064 ENDDO 1065 ENDDO 1066 ENDDO 1067 ENDDO 1068c 3A1P fully done here 1069 call ga_sync() 1070 next = nxtask(-nprocs,1) 1071c 1072 cpu = cpu + util_cpusec() 1073 wall = wall + util_wallsec() 1074 if(nodezero) then 1075 write(6,*)'3A1M integrals cpu wall',cpu,wall 1076 call util_flush(6) 1077 end if 1078c 1079c Destroying all l_offset_4a_m(n_4a_files) 1080c 1081 if(idiskl) then 1082 do i=n_4a_files,1,-1 1083 if (.not.ma_pop_stack(l_offset_4a_m(i))) 1084 1 call errquit('4-ind n5: l_offset_4a_m err.',15,MA_ERR) 1085 enddo 1086 endif 1087c 1088c 1089 if(nodezero) then 1090 write(6,*)'STEP3 4index' 1091 call util_flush(6) 1092 end if 1093c 1094c 1095c 1096c 1097c 1098c 2A2M part here 1099c 1100c DISK CHANGES =============== 2A2M 1101c destroying handle_4a 1102c closing/reopening handle_3a1m file 1103c opening handle_2a2m file 1104 if(idiskl) then 1105c 1106 do i=1,n_4a_files 1107 if (sf_destroy(handle_4a_m(i)).ne.0) 1108 1 call errquit('tce_sf_destroy: sf problem handle_4a',15,MA_ERR) 1109 enddo 1110c 1111 do i=1,n_3a1m_files 1112 if(sf_rwtor(handle_3a1m_m(i)).ne.0) 1113 2 call errquit('4-index: sf_rwtor 3a1m',0,DISK_ERR) 1114 enddo 1115c 1116 do i=1,n_2a2m_files 1117ccx call tce_filenameindexed(i,'2a2mf',filename_aux) 1118ccx call util_file_name(filename_aux,.false.,.false.,filename) 1119 call tce_filename_4ind(i,'2a2mf',filename) 1120 if (sf_create(filename,dble(bytes)*dble(size_2a2m_m(i)), 1121 1 dble(bytes)*dble(size_2a2m_m(i)),chunk_max1, 1122 1 handle_2a2m_m(i)).ne.0) 1123 2 call errquit('4-index: sf problem opening 2a2mf',0,DISK_ERR) 1124 enddo 1125c 1126 end if ! idiskl true 1127c ============================ 1128c 1129 cpu = - util_cpusec() 1130 wall = - util_wallsec() 1131c 1132 nprocs = GA_NNODES() 1133 count = 0 1134 next = NXTASK(nprocs, 1) 1135c 1136 DO g3b = 1,noa+nva !k 1137 DO g4b = g3b,noa+nva !l 1138 DO azone1 = 1,atpart !nu 1139 DO azone2 = azone1,atpart !mu 1140ccx DO g3b = 1,noa+nva !k 1141ccx DO g4b = g3b,noa+nva !l 1142c 1143 IF (next.eq.count) THEN 1144c 1145 my_file_to_read=azone1 1146c(atpart*(atpart+1))/2- 1147c 1 ((atpart-azone1+1)*(atpart-azone1))/2- 1148c 1 (atpart-azone2+1)+1 1149 my_file_to_write=g3b 1150c((noa+nva)*(noa+nva+1))/2- 1151c 1 ((noa+nva-g3b+1)*(noa+nva-g3b))/2- 1152c 1 (noa+nva-g4b+1)+1 1153c 1154 size_2a2m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1) 1155 1 *nalength(azone1)*nalength(azone2) 1156 if (.not.ma_push_get(mt_dbl,size_2a2m,'2a2m',l_2a2m,k_2a2m)) 1157 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 1158 call dfill(size_2a2m, 0.0d0, dbl_mb(k_2a2m), 1) 1159c 1160 call a3_offset(azone1,azone2,g3b,size_ic, 1161 & l_a3_offset,k_a3_offset) 1162 length_a3=int_mb(k_a3_offset) 1163c 1164 DO ii=1,length_a3 ! ii---loop 1165 1166 a3_ini = int_mb(k_a3_offset+ii) 1167 a3_fin = int_mb(k_a3_offset+length_a3+ii) 1168 key_ini = a3_ini-1+atpart*(g3b-1+(noa+nva)* 1169 & (azone2 - 1 + atpart * (azone1 - 1))) 1170 call tce_hash(int_mb(k_offset_3a1m_m(my_file_to_read)), 1171 & key_ini,offset_bl3a1m) 1172c 1173 size_bl3a1m = int_mb(k_a3_offset+2*length_a3+ii) 1174c 1175c 1176 if(idiskl) then ! ------- 1177 ierrcode1=sf_read(handle_3a1m_m(my_file_to_read), 1178 2 dble(bytes)*dble(offset_bl3a1m), 1179 2 dble(bytes)*dble(size_bl3a1m), 1180 2 dbl_mb(k_integral),request) 1181 if(ierrcode1.ne.0) then 1182 write(6,*)'STEP3-step1a' 1183 write(6,8153) ierrcode1 1184 write(6,*)'offset_bl3a1m=',offset_bl3a1m 1185 write(6,*)'size_bl3a1m=',size_bl3a1m 1186 write(6,*)'ii=',ii 1187 write(6,*)'length_a3=',length_a3 1188 call util_flush(6) 1189 call errquit('zones put: sf problem21-b',1,DISK_ERR) 1190 end if 1191 ierrcode2=sf_wait(request) 1192 if(ierrcode2.ne.0) then 1193 write(6,*)'STEP3-step1a' 1194 write(6,8154) ierrcode2 1195 call util_flush(6) 1196 call errquit('zones put: sf problem31-b',2,DISK_ERR) 1197 end if 1198 else 1199 call ga_get(i_from_x,offset_bl3a1m+1,offset_bl3a1m+size_bl3a1m, 1200 1 1,1,dbl_mb(k_integral),1) 1201 end if ! ------- 1202 offset_ismall=0 1203 do i=a3_ini,a3_fin ! over small i ------------------ 1204 size_3a1mi=nalength(azone1)*nalength(azone2)* 1205 1 nalength(i)*int_mb(k_range_alpha+g3b-1) 1206 if (.not.ma_push_get(mt_dbl,size_3a1mi,'3a1m', 1207 1 l_3a1m_sort,k_3a1m_sort)) 1208 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 1209 CALL TCE_SORT_4KG_(dbl_mb(k_integral+offset_ismall), 1210 & dbl_mb(k_3a1m_sort), 1211 & int_mb(k_range_alpha+g3b-1),nalength(i), 1212 & nalength(azone2),nalength(azone1), 1213 &2,1,3,4,1.0d0) 1214 do j=1,size_3a1mi 1215 dbl_mb(k_integral+offset_ismall+j-1)=dbl_mb(k_3a1m_sort+j-1) 1216 enddo 1217 if (.not.ma_pop_stack(l_3a1m_sort)) 1218 1 call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR) 1219c C(g4b isigma) 1220 j=0 1221 tot_azone3_sh=tot_zone(i) 1222 do isigma1 = 1,nalength(i) 1223 do igi4=1,int_mb(k_range_alpha+g4b-1) 1224 j=j+1 1225 ipos1=(int_mb(k_offset_alpha+g4b-1)+igi4-1)*nbf+tot_azone3_sh 1226 & +isigma1 1227 dbl_mb(k_coeff+j-1)=dbl_mb(k_movecs_orb+ipos1-1) 1228 enddo 1229 enddo 1230c C(g4b isigma)* v(isigma,g3b,imu,inu) 1231 call dgemm('N','N', 1232 & int_mb(k_range_alpha+g4b-1), 1233 & nalength(azone1)*nalength(azone2)*int_mb(k_range_alpha+g3b-1), 1234 & nalength(i), 1235 & 1.0d0,dbl_mb(k_coeff),int_mb(k_range_alpha+g4b-1), 1236 & dbl_mb(k_integral+offset_ismall),nalength(i),1.0d0, 1237 & dbl_mb(k_2a2m),int_mb(k_range_alpha+g4b-1)) 1238c 1239 offset_ismall=offset_ismall+nalength(azone1)*nalength(azone2)* 1240 1 nalength(i)*int_mb(k_range_alpha+g3b-1) 1241 enddo ! over small i ---------------------- 1242 ENDDO ! ii---loop 1243c 1244 if (.not.ma_pop_stack(l_a3_offset)) 1245 1 call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR) 1246c write to file 1247 key_2a2m= azone2 - 1 + atpart*( azone1 - 1 + 1248 & atpart*(g4b - 1 + (noa+nva) * (g3b-1))) 1249 call tce_hash(int_mb(k_offset_2a2m_m(my_file_to_write)), 1250 & key_2a2m,offset_2a2m) 1251 if(idiskl) then ! ------- 1252c *** debug *** 1253c xmax=0.0d0 1254c do i=1,size_2a2m 1255c xmax=xmax+dbl_mb(k_2a2m+i-1) 1256c enddo 1257c write(6,202) azone2,azone1,g4b,g3b,xmax, 1258c & my_file_to_write,ga_nodeid(),key_2a2m, 1259c & offset_2a2m 1260c 202 format('2A2M ',4i5,3x,f19.8,2x,2i6,2x,2i8) 1261c call util_flush(6) 1262c ************* 1263 ierrcode1=sf_write(handle_2a2m_m(my_file_to_write), 1264 2 dble(bytes)*dble(offset_2a2m), 1265 2 dble(bytes)*dble(size_2a2m),dbl_mb(k_2a2m),request) 1266 if(ierrcode1.ne.0) then 1267 write(6,*)'STEP3 write' 1268 write(6,8156) ierrcode1 1269 write(6,*)'offset_2a2m=',offset_2a2m 1270 write(6,*)'size_2a2m=',size_2a2m 1271 write(6,*)'key_2a2m=',key_2a2m 1272 write(6,*)'i_to_x=',i_to_x 1273 call util_flush(6) 1274 call errquit('zones put: sf problem21-b',1,DISK_ERR) 1275 end if 1276 ierrcode2=sf_wait(request) 1277 if(ierrcode2.ne.0) then 1278 call errquit('zones put: sf problem31-b',2,DISK_ERR) 1279 end if 1280 else 1281 call ga_put(i_to_x,offset_2a2m+1,offset_2a2m+size_2a2m,1,1, 1282 1 dbl_mb(k_2a2m),size_2a2m) 1283 end if ! -------- 1284c 1285 if (.not.ma_pop_stack(l_2a2m)) 1286 1 call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR) 1287c 1288 next = NXTASK(nprocs, 1) 1289 END IF 1290 count = count + 1 1291 ENDDO 1292 ENDDO 1293 ENDDO 1294 ENDDO 1295c 2A2P fully done here 1296 call ga_sync() 1297 next = nxtask(-nprocs,1) 1298c 1299 cpu = cpu + util_cpusec() 1300 wall = wall + util_wallsec() 1301 if(nodezero) then 1302 write(6,*)'2A2M integrals cpu wall',cpu,wall 1303 call util_flush(6) 1304 end if 1305c 1306c 1307c Destroying all l_offset_3a1m_m(n_3a1m_files) 1308c 1309 if(idiskl) then 1310 do i=n_3a1m_files,1,-1 1311 if (.not.ma_pop_stack(l_offset_3a1m_m(i))) 1312 1 call errquit('4-ind n5: l_offset_3a1m_m err.',15,MA_ERR) 1313 enddo 1314 end if 1315c 1316c 1317c 1318 if(nodezero) then 1319 write(6,*)'STEP4 4index' 1320 call util_flush(6) 1321 end if 1322c 1323c 1324c 1325c 1326c 1327c 1328c 1A3M part here ([g4b][g3b]|[mu][nu]) =>([g4b][g3b]|[g2b][nu]) 1329c [mu]>[nu] (azone2>=azone1) 1330c 1331c 1332c 1333c DISK CHANGES =============== 1A3M 1334c destroying handle_3a1m 1335c closing/reopening handle_2a2m file 1336c opening handle_1a3m file 1337 if(idiskl) then 1338c 1339 do i=1,n_3a1m_files 1340 if (sf_destroy(handle_3a1m_m(i)).ne.0) 1341 1 call errquit('tce_sf_destroy: sf problem handle_3a1m',15,MA_ERR) 1342 enddo 1343c 1344 do i=1,n_2a2m_files 1345 if(sf_rwtor(handle_2a2m_m(i)).ne.0) 1346 2 call errquit('4-index: sf_rwtor 2a2m',0,DISK_ERR) 1347 enddo 1348c 1349 do i=1,n_1a3m_files 1350ccx call tce_filenameindexed(i,'1a3mf',filename_aux) 1351ccx call util_file_name(filename_aux,.false.,.false.,filename) 1352 call tce_filename_4ind(i,'1a3mf',filename) 1353 if (sf_create(filename,dble(bytes)*dble(size_1a3m_m(i)), 1354 1 dble(bytes)*dble(size_1a3m_m(i)),chunk_max1, 1355 1 handle_1a3m_m(i)).ne.0) 1356 2 call errquit('4-index: sf problem opening 1a3mf',0,DISK_ERR) 1357 enddo 1358c 1359 end if !idiskl 1360c ============================ 1361c 1362 cpu = - util_cpusec() 1363 wall = - util_wallsec() 1364c 1365c 1366 nprocs = GA_NNODES() 1367 count = 0 1368 next = NXTASK(nprocs, 1) 1369 1370 DO g2b = 1,noa+nva ! 1371 DO azone1 = 1,atpart !nu 1372 DO g3b = 1,noa+nva !k 1373 DO g4b = g3b,noa+nva !l 1374c 1375 IF (next.eq.count) THEN 1376 my_file_to_read=g3b 1377c((noa+nva)*(noa+nva+1))/2- 1378c 1 ((noa+nva-g3b+1)*(noa+nva-g3b))/2- 1379c 1 (noa+nva-g4b+1)+1 1380 my_file_to_write=g3b 1381c((noa+nva)*(noa+nva+1))/2- 1382c 1 ((noa+nva-g3b+1)*(noa+nva-g3b))/2- 1383c 1 (noa+nva-g4b+1)+1 1384 size_1a3m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1) 1385 1 *int_mb(k_range_alpha+g2b-1)*nalength(azone1) 1386 if (.not.ma_push_get(mt_dbl,size_1a3m,'1a3m',l_1a3m,k_1a3m)) 1387 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 1388 call dfill(size_1a3m, 0.0d0, dbl_mb(k_1a3m), 1) 1389c 1390 DO azone2 = 1,atpart ! two cases here 1391 size_2a2m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1) 1392 1 *nalength(azone1)*nalength(azone2) 1393 if (.not.ma_push_get(mt_dbl,size_2a2m,'2a2m',l_2a2m,k_2a2m)) 1394 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 1395 if(azone2.ge.azone1) then !----------------------------------------- 1396 key_2a2m=azone2 - 1 + atpart*( azone1 - 1 + 1397 & atpart*(g4b - 1 + (noa+nva) * (g3b-1))) 1398 call tce_hash(int_mb(k_offset_2a2m_m(my_file_to_read)), 1399 & key_2a2m,offset_2a2m) 1400 if(idiskl) then !------ 1401 if (sf_read(handle_2a2m_m(my_file_to_read), 1402 & dble(bytes)*dble(offset_2a2m), 1403 & dble(bytes)*dble(size_2a2m),dbl_mb(k_2a2m),request).ne.0) 1404 & call errquit('zones put: sf problem21-b',1,DISK_ERR) 1405 if (sf_wait(request).ne.0) 1406 1 call errquit('zones put: sf problem31-b',2,DISK_ERR) 1407 else 1408 call ga_get(i_from_x,offset_2a2m+1,offset_2a2m+size_2a2m,1,1, 1409 1 dbl_mb(k_2a2m),1) 1410 end if !----- 1411 else ! ------------------------------------------------------------ 1412 key_2a2m=azone1 - 1 + atpart*( azone2 - 1 + 1413 & atpart*(g4b - 1 + (noa+nva) * (g3b-1))) 1414 call tce_hash(int_mb(k_offset_2a2m_m(my_file_to_read)), 1415 & key_2a2m,offset_2a2m) 1416 if(idiskl) then ! ------ 1417 if (sf_read(handle_2a2m_m(my_file_to_read), 1418 & dble(bytes)*dble(offset_2a2m), 1419 & dble(bytes)*dble(size_2a2m),dbl_mb(k_2a2m),request).ne.0) 1420 & call errquit('zones put: sf problem21-b',1,DISK_ERR) 1421 if (sf_wait(request).ne.0) 1422 1 call errquit('zones put: sf problem31-b',2,DISK_ERR) 1423 else 1424 call ga_get(i_from_x,offset_2a2m+1,offset_2a2m+size_2a2m,1,1, 1425 1 dbl_mb(k_2a2m),1) 1426 end if ! ------ 1427 end if ! --------------------------------------------------------- 1428 if(azone2.ge.azone1) then 1429ccc TRANSPOZYCJA 1430 if (.not.ma_push_get(mt_dbl,size_2a2m,'2a2m_sort', 1431 1 l_2a2m_aux,k_2a2m_aux)) 1432 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 1433 CALL TCE_SORT_4KG_(dbl_mb(k_2a2m),dbl_mb(k_2a2m_aux), 1434 & int_mb(k_range_alpha+g4b-1),int_mb(k_range_alpha+g3b-1), 1435 & nalength(azone2),nalength(azone1), 1436 & 1,2,4,3,1.0d0) 1437 do i=1,size_2a2m 1438 dbl_mb(k_2a2m+i-1)=dbl_mb(k_2a2m_aux+i-1) 1439 enddo 1440 if (.not.ma_pop_stack(l_2a2m_aux)) 1441 1 call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR) 1442 end if 1443c 1444c C(imu g2b) ==> l_2g2z 1445c 1446 size_amc=int_mb(k_range_alpha+g2b-1) * 1447 1 nalength(azone2) 1448 if (.not.ma_push_get(mt_dbl,size_amc,'2g2z',l_2g2z,k_2g2z)) 1449 1 call errquit('tce_r2_divide3: xx-MA problem',0,MA_ERR) 1450 i=0 1451 tot_azone2_sh=tot_zone(azone2) 1452 do igi2=1,int_mb(k_range_alpha+g2b-1) 1453 do imu1 = 1,nalength(azone2) 1454 i=i+1 1455c ipos1=(int_mb(k_offset_alpha+g2b-1)+igi2-1)*nbf+tot_azone1_sh 1456c & +inu1 1457 ipos1=(int_mb(k_offset_alpha+g2b-1)+igi2-1)*nbf+tot_azone2_sh 1458 & +imu1 1459 dbl_mb(k_2g2z+i-1)=dbl_mb(k_movecs_orb+ipos1-1) 1460 enddo 1461 enddo 1462c v(g4b,g3b,inu,imu) C(imu,g2b) 1463 if (.not.ma_push_get(mt_dbl,size_1a3m,'1a3m', 1464 1 l_1a3m_sort,k_1a3m_sort)) 1465 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 1466c dgemm 1467 call dgemm('N','N', 1468 & int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1) 1469 & *nalength(azone1), 1470 & int_mb(k_range_alpha+g2b-1), 1471 & nalength(azone2), 1472 & 1.0d0,dbl_mb(k_2a2m), 1473 & int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1) 1474 & *nalength(azone1), 1475 & dbl_mb(k_2g2z),nalength(azone2),0.0d0, 1476 & dbl_mb(k_1a3m_sort), 1477 & int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1) 1478 & *nalength(azone1)) 1479c 1480 i=0 1481 do inu1=1,nalength(azone1) 1482 do igi2=1,int_mb(k_range_alpha+g2b-1) 1483 do igi3=1,int_mb(k_range_alpha+g3b-1) 1484 do igi4=1,int_mb(k_range_alpha+g4b-1) 1485 i=i+1 1486 ipos1=igi4+int_mb(k_range_alpha+g4b-1)*( 1487 & igi3-1+int_mb(k_range_alpha+g3b-1)*( 1488 & inu1-1+nalength(azone1)*(igi2-1))) 1489 dbl_mb(k_1a3m+i-1)=dbl_mb(k_1a3m+i-1)+ 1490 & dbl_mb(k_1a3m_sort+ipos1-1) 1491 enddo 1492 enddo 1493 enddo 1494 enddo 1495c 1496 if (.not.ma_pop_stack(l_1a3m_sort)) 1497 1 call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR) 1498 if (.not.ma_pop_stack(l_2g2z)) 1499 1 call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR) 1500 if (.not.ma_pop_stack(l_2a2m)) 1501 1 call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR) 1502 ENDDO 1503c write to file 1504 key_1a3m= azone1-1+atpart*(g2b-1+(noa+nva)* 1505 & (g4b-1+(noa+nva)*(g3b-1))) 1506 call tce_hash(int_mb(k_offset_1a3m_m(my_file_to_write)), 1507 & key_1a3m,offset_1a3m) 1508c 1509 if(idiskl) then !--------- 1510c *** debug *** 1511c xmax=0.0d0 1512c do i=1,size_1a3m 1513c xmax=xmax+dbl_mb(k_1a3m+i-1) 1514c enddo 1515c write(6,203) azone1,g2b,g4b,g3b,xmax,my_file_to_write, 1516c & ga_nodeid(),key_1a3m,offset_1a3m 1517c 203 format('1A3M ',4i5,3x,f19.8,2x,i4,2x,i3,2x,2i8) 1518c call util_flush(6) 1519c ************* 1520 if (sf_write(handle_1a3m_m(my_file_to_write), 1521 & dble(bytes)*dble(offset_1a3m), 1522 & dble(bytes)*dble(size_1a3m),dbl_mb(k_1a3m),request).ne.0) 1523 & call errquit('zones put: sf problem21-b',1,DISK_ERR) 1524 if (sf_wait(request).ne.0) 1525 1 call errquit('zones put: sf problem31-b',2,DISK_ERR) 1526 else 1527 call ga_put(i_to_x,offset_1a3m+1,offset_1a3m+size_1a3m,1,1, 1528 1 dbl_mb(k_1a3m),size_1a3m) 1529 end if ! ------------- 1530c 1531 if (.not.ma_pop_stack(l_1a3m)) 1532 1 call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR) 1533c 1534 next = NXTASK(nprocs, 1) 1535 END IF 1536 count = count + 1 1537 ENDDO 1538 ENDDO 1539 ENDDO 1540 ENDDO 1541c 1A3P fully done here 1542 call ga_sync() 1543 next = nxtask(-nprocs,1) 1544c 1545 cpu = cpu + util_cpusec() 1546 wall = wall + util_wallsec() 1547 if(nodezero) then 1548 write(6,*)'1A3M integrals cpu wall',cpu,wall 1549 call util_flush(6) 1550 end if 1551c 1552c Destroying all l_offset_2a2m_m(n_2a2m_files) 1553c 1554 if(idiskl) then 1555 do i=n_2a2m_files,1,-1 1556 if (.not.ma_pop_stack(l_offset_2a2m_m(i))) 1557 1 call errquit('4-ind n5: l_offset_2a2m_m err.',15,MA_ERR) 1558 enddo 1559 end if 1560c 1561c 1562 if(nodezero) then 1563 write(6,*)'STEP5 4index' 1564 call util_flush(6) 1565 end if 1566c 1567c 1568c 1569c 1570c 4M starts here 1571c 1572c 1573c DISK CHANGES =============== 4M 1574c destroying handle_2a2m 1575c closing/reopening handle_1a3m file 1576c opening handle_4m file 1577 if(idiskl) then 1578c 1579 do i=1,n_2a2m_files 1580 if (sf_destroy(handle_2a2m_m(i)).ne.0) 1581 1 call errquit('tce_sf_destroy: sf problem handle_2a2m',15,MA_ERR) 1582 enddo 1583c 1584 do i=1,n_1a3m_files 1585 if(sf_rwtor(handle_1a3m_m(i)).ne.0) 1586 2 call errquit('4-index: sf_rwtor 1a3m',0,DISK_ERR) 1587 enddo 1588c 1589 end if 1590c ============================ 1591c 1592 cpu = - util_cpusec() 1593 wall = - util_wallsec() 1594c 1595 nprocs = GA_NNODES() 1596 count = 0 1597 next = NXTASK(nprocs, 1) 1598c 1599c 1600c Ordering of the do-loops has been changed from: 1601c g1b g2b g3b g4b 1602c to : 1603c g3b g4b g1b g2b (g1b,g2b are used to define file's number) 1604c 1605cx DO g1b = 1,noa+nva !nu 1606cx DO g2b = g1b,noa+nva ! 1607 DO g3b = 1,noa+nva !k 1608 DO g4b = g3b,noa+nva !l 1609 DO g1b = 1,noa+nva !nu 1610 DO g2b = g1b,noa+nva ! 1611 IF (next.eq.count) THEN 1612 my_file_to_read=g1b 1613c((noa+nva)*(noa+nva+1))/2- 1614c 1 ((noa+nva-g1b+1)*(noa+nva-g1b))/2- 1615c 1 (noa+nva-g2b+1)+1 1616 IF (int_mb(k_spin_alpha+g3b-1)+int_mb(k_spin_alpha+g4b-1).eq. 1617 &int_mb(k_spin_alpha+g1b-1)+int_mb(k_spin_alpha+g2b-1)) THEN 1618 IF (ieor(int_mb(k_sym_alpha+g3b-1),ieor(int_mb(k_sym_alpha+g4b-1), 1619 & ieor(int_mb(k_sym_alpha+g1b-1),int_mb(k_sym_alpha+g2b-1)))) 1620 & .eq. irrep_v) THEN 1621c reversed order 1622 ICOL=INDEX_PAIR(g4b,g3b) 1623 IROW=INDEX_PAIR(g2b,g1b) 1624 IF(IROW.GE.ICOL) THEN 1625 IRES=INDEX_PAIR(IROW,ICOL) 1626 size_4m=int_mb(k_range_alpha+g4b-1)*int_mb(k_range_alpha+g3b-1) 1627 1 *int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1) 1628 if (.not.ma_push_get(mt_dbl,size_4m,'4m',l_4m,k_4m)) 1629 1 call errquit('tce_4ind: step1_1',0,MA_ERR) 1630 call dfill(size_4m, 0.0d0, dbl_mb(k_4m), 1) 1631c 1632 call a1_offset(g1b,g2b,g4b,size_ic, 1633 & l_a1_offset,k_a1_offset) 1634 length_a1=int_mb(k_a1_offset) 1635 DO ii=1,length_a1 ! ii---loop 1636 a1_ini = int_mb(k_a1_offset+ii) 1637 a1_fin = int_mb(k_a1_offset+length_a1+ii) 1638 key_ini = a1_ini-1+atpart*(g4b-1+(noa+nva)* 1639 & (g2b-1+(noa+nva)*(g1b-1))) 1640 call tce_hash(int_mb(k_offset_1a3m_m(my_file_to_read)), 1641 & key_ini,offset_bl1a3m) 1642c 1643 size_bl1a3m = int_mb(k_a1_offset+2*length_a1+ii) 1644 if(idiskl) then ! ------- 1645 if (sf_read(handle_1a3m_m(my_file_to_read), 1646 & dble(bytes)*dble(offset_bl1a3m), 1647 2 dble(bytes)*dble(size_bl1a3m), 1648 2 dbl_mb(k_integral),request).ne.0) 1649 2 call errquit('zones put: sf problem21-b',1,DISK_ERR) 1650 if (sf_wait(request).ne.0) 1651 1 call errquit('zones put: sf problem31-b',2,DISK_ERR) 1652 else 1653 call ga_get(i_from_x,offset_bl1a3m+1,offset_bl1a3m+size_bl1a3m, 1654 1 1,1,dbl_mb(k_integral),size_bl1a3m) 1655 end if ! ------- 1656 offset_ismall=0 1657 do i=a1_ini,a1_fin ! over small i ------------------ 1658c C(azone1 g3b) 1659 j=0 1660 tot_azone1_sh=tot_zone(i) 1661 do igi3=1,int_mb(k_range_alpha+g3b-1) 1662 do inu1 = 1,nalength(i) 1663 j=j+1 1664 ipos1=(int_mb(k_offset_alpha+g3b-1)+igi3-1)*nbf+tot_azone1_sh 1665 & +inu1 1666 dbl_mb(k_coeff+j-1)=dbl_mb(k_movecs_orb+ipos1-1) 1667 enddo 1668 enddo 1669c v(g2b,g1b,g4b,inu)*C(inu g3b) 1670 call dgemm('N','N', 1671 & int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1) 1672 & *int_mb(k_range_alpha+g4b-1), 1673 & int_mb(k_range_alpha+g3b-1), 1674 & nalength(i), 1675 & 1.0d0,dbl_mb(k_integral+offset_ismall), 1676 & int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1) 1677 & *int_mb(k_range_alpha+g4b-1), 1678 & dbl_mb(k_coeff),nalength(i),1.0d0, 1679 & dbl_mb(k_4m), 1680 & int_mb(k_range_alpha+g2b-1)*int_mb(k_range_alpha+g1b-1) 1681 & *int_mb(k_range_alpha+g4b-1)) 1682c 1683 offset_ismall=offset_ismall+nalength(i) 1684 1 *int_mb(k_range_alpha+g4b-1) 1685 1 *int_mb(k_range_alpha+g1b-1)*int_mb(k_range_alpha+g2b-1) 1686c 1687 enddo ! over small i ---------------------- 1688 ENDDO ! ii---loop 1689 if (.not.ma_pop_stack(l_a1_offset)) 1690 1 call errquit('tce_mo2e_trans_zones: uu l_2g2z',15,MA_ERR) 1691c 1692c zapis 1693c 1694c *** debug *** 1695c xmax=0.0d0 1696c do i=1,size_4m 1697c xmax=xmax+dbl_mb(k_4m+i-1) 1698c enddo 1699c write(6,204) ires,xmax 1700c 204 format('4M ',i5,3x,f19.8) 1701c call util_flush(6) 1702c ************* 1703 key_4m=ires 1704 call tce_hash_n(int_mb(kax_v2_alpha_offset),key_4m,offset_4m) 1705c 1706 if ((g3b.gt.noa).and.(g4b.gt.noa).and. 1707 1 (g1b.gt.noa).and.(g2b.gt.noa)) then 1708c Put 4-virtual pieces only in SF 1709 call put_block_sf(d_v2sf,dbl_mb(k_4m),size_4m, 1710 & offset_4m) 1711 else 1712c Put non-4-virtual pieces in GA and SF 1713 call put_block(d_v2ga,dbl_mb(k_4m),size_4m, 1714 & offset_4m) 1715 call put_block_sf(d_v2sf,dbl_mb(k_4m),size_4m, 1716 & offset_4m) 1717 endif 1718c 1719 if (.not.ma_pop_stack(l_4m)) 1720 1 call errquit('tce_mo2e_trans_zones: abc-MA problem',15,MA_ERR) 1721 1722 END IF 1723 END IF 1724 END IF 1725 next = NXTASK(nprocs, 1) 1726 END IF 1727 count = count + 1 1728 ENDDO 1729 ENDDO 1730 ENDDO 1731 ENDDO 1732c 1733 call ga_sync() 1734 next = nxtask(-nprocs,1) 1735c 1736c 1737 cpu = cpu + util_cpusec() 1738 wall = wall + util_wallsec() 1739 if(nodezero) then 1740 write(6,*)'4M integrals cpu wall',cpu,wall 1741 call util_flush(6) 1742 end if 1743c 1744c 1745c 1746c 1747c 1748c 1749c 1750 if(nodezero) then 1751 write(6,*)'DONE --- DONE ---- DONE ---- DONE' 1752 end if 1753c 1754ccx if (.not.ma_pop_stack(l_work2)) 1755ccx 1 call errquit('tce_ao2e: MA problem',14,MA_ERR) 1756ccx if (.not.ma_pop_stack(l_work1)) 1757ccx 1 call errquit('tce_ao2e: MA problem',15,MA_ERR) 1758c 1759c 1760c Destroying all l_offset_1a3m_m(n_1a3m_files) 1761c 1762c 1763 do i=n_1a3m_files,1,-1 1764 if (.not.ma_pop_stack(l_offset_1a3m_m(i))) 1765 1 call errquit('4-ind n5: l_offset_1a3m_m err.',15,MA_ERR) 1766 enddo 1767c 1768 if (.not.ma_pop_stack(l_movecs_orb)) 1769 1 call errquit('tce_ao2e: MA problem',15,MA_ERR) 1770c 1771c 1772c DISK CHANGES =============== AFTER 4M 1773c destroying handle_1a3m_m files 1774c 1775 if(idiskl) then 1776 do i=1,n_1a3m_files 1777 if (sf_destroy(handle_1a3m_m(i)).ne.0) 1778 1 call errquit('tce_sf_destroy: sf problem handle_1a3m',15,MA_ERR) 1779 enddo 1780 end if 1781c ============================ 1782c 1783c 1784 if(idiskl) then 1785c 1786c dummy part 1787c 1788 else 1789 call deletefile(i_from_x) 1790 call ga_sync() 1791cccx call deletefile(d_4af) 1792cccx call ga_sync() 1793 end if 1794c 1795ccx if (.not.ma_pop_stack(l_1a3m_offset)) 1796ccx 1 call errquit('tce_off_1a3m: MA problem',15,MA_ERR) 1797c 1798ccx if (.not.ma_pop_stack(l_2a2m_offset)) 1799ccx 1 call errquit('tce_off_2a2m: MA problem',15,MA_ERR) 1800c 1801ccx if (.not.ma_pop_stack(l_3a1m_offset)) 1802ccx 1 call errquit('tce_off_3a1m: MA problem',15,MA_ERR) 1803c 1804ccx if (.not.ma_pop_stack(l_4af_offset)) 1805ccx 1 call errquit('tce_off_4a: MA problem',15,MA_ERR) 1806c 1807c 1808c closing two large local files 1809c 1810 if (.not.ma_pop_stack(l_coeff)) 1811 1 call errquit('tce_off_4a: MA problem',15,MA_ERR) 1812c 1813 if (.not.ma_pop_stack(l_integral)) 1814 1 call errquit('tce_off_4a: MA problem',15,MA_ERR) 1815c 1816 1817c 1818 call ga_sync() 1819c *** debug *** 1820c 800 format('DGEMM1 MAX',i5,2x,3f15.5) 1821c 801 format('DGEMM2 ',i5,2x,3f15.5) 1822 8153 format('SF_READ ERROR CODE = ',2x,i10) 1823 8154 format('SF_READ_WAIT ERROR CODE = ',2x,i10) 1824 8156 format('SF_WRITE ERROR CODE = ',2x,i10) 1825 8157 format('SF_WRITE_WAIT ERROR CODE = ',2x,i10) 1826 8155 format('FU',i6,2x,3i20) 1827 9000 format('PART1',i4,1x,'Cpu wall ',2(f17.12,1x),3x,'g4b g3b',2i5) 1828c 9001 format('PART2',i4,1x,'Cpu wall ',2(f17.12,1x),3x,'g4b g3b',2i5) 1829c 9003 format('PART1-4a',i4,1x,'Cpu wall ',2(f17.12,1x)) 1830c 9004 format('PART1-2g2z',i4,1x,'Cpu wall ',2(f17.12,1x)) 1831c 9005 format('PART1-dgemm',i4,1x,'Cpu wall ',2(f17.12,1x)) 1832c 9010 format(' P1-mnrs',i3,1x,2i5,1x,2i5,1x,'Cpu wall ',2(f17.12,1x)) 1833 555 format('atom loop ',2x,i5,3x,2i5,3x,2i5,i12) 1834 556 format('atom time',2x,i5,3x,2i5,3x,2i5,'Cpu wall ',2(f12.7,1x)) 1835 777 format('main do loop ',2x,i5,3x,2i5,3x,2i5) 1836 775 format('main loop step1 ',2x,i5,3x,2i5,3x,2i5) 1837 776 format('main loop step2 ',2x,i5,3x,2i5,3x,2i5) 1838 778 format('PART1',2x,i5,3x,2i5,3x,2i5,2x,'Cpu wall ',2(f17.12,1x)) 1839 779 format('PART2',2x,i5,3x,2i5,3x,2i5,2x,'Cpu wall ',2(f17.12,1x)) 1840 780 format('ADD BLOCK',2x,i5,3x,2i5,3x,2i5,2x,'Cpu wall ', 1841 & 2(f17.12,1x)) 1842c ************* 1843c 1844 RETURN 1845 END 1846c 1847c 1848c 1849