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