1 subroutine tce_uss_offdiagonal_1(d_r1m,d_r2m,k_r1_offsetm, 2 1 k_r2_offsetm,iref,jref,d_c1,d_c2) 3! Routine for off diagonal correction 4 implicit none 5#include "tce.fh" 6#include "mafdecls.fh" 7#include "stdio.fh" 8#include "rtdb.fh" 9#include "errquit.fh" 10#include "sym.fh" 11#include "tce_mrcc.fh" 12#include "global.fh" 13#include "tce_main.fh" 14 15 integer rtdb 16 logical nodezero 17 integer k_r2_offsetm(maxref),k_r2a_offsetm(maxref) 18 integer k_r1_offsetm(maxref) 19 integer d_r2m(maxref),d_r2a(maxref),d_r1m(maxref) 20 integer d_r3u(maxref),k_r3u_offsetm(maxref) 21 integer iref,jref,iexclevel 22 integer i,j,p1,h2,k,p2,h3,h4,i1,k2 23 integer size,l,m,n,o 24 integer l_r2,k_r2,l_r2a,k_r2a,l_r1a,k_r1a 25 integer p1b,h1b 26 integer orbindex(8),aorbindex(8),orbindexnew(8) 27 integer t, p1new,p2new, h1new, h2new,p3new,h3new 28 integer p1new1,p2new1, h1new1, h2new1,p3new1,h3new1 29 integer orbspin(8),aorbspin(8) 30 integer ioccnew(maxorb,2),iocc0(maxorb,2) 31 integer ioffset(6),ihash,oldhash 32 integer p1off,p2off,h1off,h2off,p3off,h3off 33 integer p1off1,p2off1,h1off1,h2off1,p3off1,h3off1 34 integer ispinfrom,ispinto 35 integer iu,is,ifrom,ito,is1 36 integer totaloff,hs,ilength 37 integer l_tmp,k_tmp,size1,k_tmp1,l_tmp1,l_d_c2,k_d_c2 38 integer sizenew,ihashold,ioff,sizenew1,ioff1,ioff2 39 integer noabn,nvabn,counter,iactive,counter1 40 integer d_c,d_c1,d_c2 41! 42 integer iexfrom,iexto,iexspin,wtp,wth 43 integer noper,erank,optyp,eoper,k1,signfact,noper2,eoper2,espin 44 double precision dsmult,fact 45 dimension eoper(4*maxexcit),optyp(4*maxexcit),eoper2(4*maxexcit), 46 1 espin(4*maxexcit) 47 dimension iexfrom(8),iexto(8),iexspin(8) 48! 49 logical ap1,ah2,ap2,ah1 50 EXTERNAL NXTASKsub 51 EXTERNAL NXTASK 52 INTEGER NXTASKsub 53 INTEGER NXTASK 54 INTEGER nxt 55 INTEGER nprocs 56 INTEGER count,next 57 58 if(lusesub) then 59 60 call ga_pgroup_sync(mypgid) 61 nprocs = GA_pgroup_NNODES(mypgid) 62 count = 0 63 next = NXTASKsub(nprocs, 1,mypgid) 64 65 else 66 67 call ga_sync() 68 nprocs = GA_NNODES() 69 count = 0 70 next = NXTASK(nprocs, 1) 71 72 endif 73 74 75 nodezero = (ga_nodeid().eq.0) 76! 77 noa = nblcks(1,iref) 78 nob = nblcks(2,iref) 79 nva = nblcks(3,iref) 80 nvb = nblcks(4,iref) 81 82 noab = noa+nob 83 nvab = nva+nvb 84 85 noabn = nblcks(1,jref)+nblcks(2,jref) 86 nvabn = nblcks(3,jref)+nblcks(4,jref) 87 88c------- 89! Generating R1(j,b) from diagonal r1(i,a) 90! 91 DO p1b = noab+1,noab+nvab 92 DO h1b = 1,noab 93 94! 95 if(count.eq.next) then 96! 97 IF (int_mb(k_spinm(iref)+p1b-1) .eq. int_mb(k_spinm(iref)+ 98 1h1b-1)) THEN 99 IF (ieor(int_mb(k_symm(iref)+p1b-1),int_mb(k_symm(iref)+ 100 1h1b-1)) .eq. irrep_t) THEN 101 IF ((.not.restricted).or.(int_mb(k_spinm(iref)+p1b-1)+ 102 1int_mb(k_spinm(iref)+h1b-1).ne.4)) THEN 103 104 size = int_mb(k_rangem(iref)+p1b-1) * 105 1 int_mb(k_rangem(iref)+h1b-1) 106! 107 oldhash = h1b-1+noab*(p1b-noab-1) 108! 109 if (.not.ma_push_get(mt_dbl,size,'c2',l_r1a,k_r1a)) 110 1 call errquit('tce_uss: MA problem',10,MA_ERR) 111! 112 CALL DFILL(size,0.0d0,dbl_mb(k_r1a),1) 113 114 call get_hash_block(d_r1m(iref),dbl_mb(k_r1a),size, 115 1 int_mb(k_r1_offsetm(iref)),oldhash) 116 117!-------------------- 118! 119 counter = 0 120 ihash =-1 121 ihashold = -1 122 do i=1,int_mb(k_rangem(iref)+p1b-1) 123 do m=1,int_mb(k_rangem(iref)+h1b-1) 124 125 counter = counter + 1 126 127 128 orbspin(1) = int_mb(k_spinm(iref)+p1b-1) -1 129 orbspin(2) = int_mb(k_spinm(iref)+h1b-1) -1 130 131 orbindex(1) = (1 - orbspin(1)+ 132 1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+p1b-1)+i-1))/2 133 134 orbindex(2) = (1 - orbspin(2)+ 135 1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+h1b-1)+m-1))/2 136! 137 iexto(1) = moindexes(orbindex(1),orbspin(1)+1,iref) 138 iexfrom(1) = moindexes(orbindex(2),orbspin(2)+1,iref) 139 iexspin(1) = orbspin(1)+1 140! 141 signfact=0 142 dsmult=1.0d0 143 call perfexcit(erank,eoper,iref,jref, 144 & 1,iexfrom,iexto,iexspin, 145 & signfact,espin,wtp,wth) 146 147 if(erank.eq.0) goto 111 148 if(erank.eq.2) then 149 150 signfact=mod(signfact,2) 151 if(signfact.ne.0) then 152 dsmult = -1.0d0 153 endif 154 155 orbindex(1)=moindexes(eoper(1),espin(1),jref) 156 orbindex(2)=moindexes(eoper(2),espin(2),jref) 157 p1new = orbinblck(orbindex(1),espin(1),jref) 158 h1new = orbinblck(orbindex(2),espin(2),jref) 159 160 p1off = offsetinblck(orbindex(1),espin(1),jref) 161 h1off = offsetinblck(orbindex(2),espin(2),jref) 162 163 ihash = h1new-1+noabn*(p1new-noabn-1) 164 165 ilength = int_mb(k_r1_offsetm(jref)) 166 totaloff = -1 167 168 do k = 1, ilength 169 if(int_mb(k_r1_offsetm(jref)+k).eq.ihash) then 170 totaloff = 1 171 goto 112 172 endif 173 enddo 174 112 continue 175 176 177 if((p1new.le.noabn).or. 178 2 (h1new.gt.noabn))then 179 totaloff=-1 180 endif 181 182 if(totaloff.ne.-1)then 183 184 ioff = p1off*int_mb(k_rangem(jref)+h1new-1)+h1off 185 186 sizenew = int_mb(k_rangem(jref)+h1new-1)* 187 1 int_mb(k_rangem(jref)+p1new-1) 188 189 if (.not.ma_push_get(mt_dbl,sizenew,'tmp',l_tmp1,k_tmp1)) 190 1 call errquit('tce_uss: MA problem',3,MA_ERR) 191 192 CALL DFILL(sizenew,0.0d0,dbl_mb(k_tmp1),1) 193 194 dbl_mb(k_tmp1+ioff)=dbl_mb(k_r1a+counter-1)*dsmult 195 196 197 call add_hash_block(d_c1,dbl_mb(k_tmp1),sizenew, 198 1 int_mb(k_r1_offsetm(jref)),ihash) 199 200 if (.not.ma_pop_stack(l_tmp1)) 201 1 call errquit('tce_uss: MA problem',4,MA_ERR) 202 203 endif !totaloff 204 205 endif!erank=2 206! 207 if(erank.eq.4) then 208 209 210 orbindex(1)=moindexes(eoper(1),espin(1),jref) 211 orbindex(2)=moindexes(eoper(2),espin(2),jref) 212 orbindex(4)=moindexes(eoper(3),espin(3),jref) 213 orbindex(3)=moindexes(eoper(4),espin(4),jref) 214 215 signfact=mod(signfact,2) 216 if(signfact.ne.0) then 217 dsmult = -1.0d0 218 endif 219 220 p1new = orbinblck(orbindex(1),espin(1),jref) 221 p2new = orbinblck(orbindex(2),espin(2),jref) 222 223 h1new = orbinblck(orbindex(3),espin(4),jref) 224 h2new = orbinblck(orbindex(4),espin(3),jref) 225 226 p1off = offsetinblck(orbindex(1),espin(1),jref) 227 p2off = offsetinblck(orbindex(2),espin(2),jref) 228 h1off = offsetinblck(orbindex(3),espin(4),jref) 229 h2off = offsetinblck(orbindex(4),espin(3),jref) 230c 231 if(p1new.gt.p2new) then 232 t = p1new 233 p1new = p2new 234 p2new = t 235 t = p1off 236 p1off = p2off 237 p2off = t 238 dsmult=-1.0d0*dsmult 239 end if 240 241 if(h1new.gt.h2new) then 242 t = h1new 243 h1new = h2new 244 h2new = t 245 t = h1off 246 h1off = h2off 247 h2off = t 248 dsmult=-1.0d0*dsmult 249 end if 250 251 if((p1new.le.noabn).or. 252 1 (p2new.le.noabn).or. 253 2 (h1new.gt.noabn).or. 254 3 (h2new.gt.noabn)) then !goto 111 255 totaloff=-1 256c ihash=-1 257 endif 258 259 ihash = h2new-1+noabn*(h1new-1+noabn *(p2new-noabn-1+nvabn 260 1 *(p1new-noabn-1))) 261 262 ilength = int_mb(k_r2_offsetm(jref)) 263 totaloff = -1 264 265 do k = 1, ilength 266 if(int_mb(k_r2_offsetm(jref)+k).eq.ihash) then 267 totaloff = 1 268 goto 113 269 endif 270 enddo 271 113 continue 272 273c if(totaloff.eq.-1) goto 111 274 if(totaloff.ne.-1)then 275 ioff = p1off*int_mb(k_rangem(jref)+h2new-1)* 276 1 int_mb(k_rangem(jref)+h1new-1)* 277 2 int_mb(k_rangem(jref)+p2new-1)+ 278 2 p2off*int_mb(k_rangem(jref)+h2new-1)* 279 3 int_mb(k_rangem(jref)+h1new-1)+ 280 4 h1off*int_mb(k_rangem(jref)+h2new-1)+h2off 281 282 283 sizenew = int_mb(k_rangem(jref)+p1new-1)* 284 1 int_mb(k_rangem(jref)+p2new-1)* 285 2 int_mb(k_rangem(jref)+h1new-1)* 286 3 int_mb(k_rangem(jref)+h2new-1) 287 288 if (.not.ma_push_get(mt_dbl,sizenew,'tmp1',l_tmp1,k_tmp1)) 289 1 call errquit('tce_uss: MA problem',3,MA_ERR) 290 291 CALL DFILL(sizenew,0.0d0,dbl_mb(k_tmp1),1) 292 293 dbl_mb(k_tmp1+ioff)=dbl_mb(k_r1a+counter-1)*dsmult 294 295 call add_hash_block(d_c2,dbl_mb(k_tmp1),sizenew, 296 1 int_mb(k_r2_offsetm(jref)),ihash) 297 298 if (.not.ma_pop_stack(l_tmp1)) 299 1 call errquit('tce_uss: MA problem',4,MA_ERR) 300 endif !totaloff 301cccc 302 if(((espin(1).eq.espin(2)).and.(espin(3).eq.espin(4))) 303 1 .and.(((wtp.ge.0).and.(p1new.eq.p2new)).or.((wth.ge.0).and. 304 1 (h1new.eq.h2new)))) then 305 fact=1.d0 306 else 307 fact=1.d0 308 endif 309 dsmult=-1.0d0*dsmult 310 if(wtp.ge.0) then 311 312 p1new1=p2new 313 p2new1=p1new 314 h1new1=h1new 315 h2new1=h2new 316 p1off1=p2off 317 p2off1=p1off 318 h1off1=h1off 319 h2off1=h2off 320 321 if(p1new1.gt.p2new1) then 322 t = p1new1 323 p1new1 = p2new1 324 p2new1 = t 325 t = p1off1 326 p1off1 = p2off1 327 p2off1 = t 328 end if 329 330 if(h1new1.gt.h2new1) then 331 t = h1new1 332 h1new1 = h2new1 333 h2new1 = t 334 t = h1off1 335 h1off1 = h2off1 336 h2off1 = t 337 end if 338 ihashold = h2new1-1+noabn*(h1new1-1+noabn *(p2new1-noabn-1+nvabn 339 1 *(p1new1-noabn-1))) 340 341 ilength = int_mb(k_r2_offsetm(jref)) 342 totaloff = -1 343 344 do k = 1, ilength 345 if(int_mb(k_r2_offsetm(jref)+k).eq.ihashold) then 346 totaloff = 1 347 goto 114 348 endif 349 enddo 350 114 continue 351 352 353 if((p1new1.le.noabn).or. 354 1 (p2new1.le.noabn).or. 355 2 (h1new1.gt.noabn).or. 356 3 (h2new1.gt.noabn)) then !goto 111 357 totaloff=-1 358 endif 359 360 if(totaloff.ne.-1)then 361 362 ioff1 = p1off1*int_mb(k_rangem(jref)+h2new1-1)* 363 1 int_mb(k_rangem(jref)+h1new1-1)* 364 2 int_mb(k_rangem(jref)+p2new1-1)+ 365 2 p2off1*int_mb(k_rangem(jref)+h2new1-1)* 366 3 int_mb(k_rangem(jref)+h1new1-1)+ 367 4 h1off1*int_mb(k_rangem(jref)+h2new1-1)+h2off1 368 369 sizenew1 = int_mb(k_rangem(jref)+p1new1-1)* 370 1 int_mb(k_rangem(jref)+p2new1-1)* 371 2 int_mb(k_rangem(jref)+h1new1-1)* 372 3 int_mb(k_rangem(jref)+h2new1-1) 373 374 l_tmp1=0 375 376 if(ioff1.ne.ioff) then 377 if (.not.ma_push_get(mt_dbl,sizenew1,'tmp1',l_tmp1,k_tmp1)) 378 1 call errquit('tce_uss: MA problem',3,MA_ERR) 379 380 381 CALL DFILL(sizenew1,0.0d0,dbl_mb(k_tmp1),1) 382 383 dbl_mb(k_tmp1+ioff1)=dbl_mb(k_r1a+counter-1)*dsmult/fact 384 385 call add_hash_block(d_c2,dbl_mb(k_tmp1),sizenew1, 386 1 int_mb(k_r2_offsetm(jref)),h2new1-1+noabn*(h1new1-1+noabn * 387 1 (p2new1-noabn-1+nvabn*(p1new1-noabn-1)))) 388 389 if (.not.ma_pop_stack(l_tmp1)) 390 1 call errquit('tce_uss: MA problem',4,MA_ERR) 391 endif 392 endif !totaloff 393 endif 394 395 if(wth.ge.0) then 396 p1new1=p1new 397 p2new1=p2new 398 h1new1=h2new 399 h2new1=h1new 400 p1off1=p1off 401 p2off1=p2off 402 h1off1=h2off 403 h2off1=h1off 404 405 if(p1new1.gt.p2new1) then 406 t = p1new1 407 p1new1 = p2new1 408 p2new1 = t 409 t = p1off1 410 p1off1 = p2off1 411 p2off1 = t 412 end if 413 414 if(h1new1.gt.h2new1) then 415 t = h1new1 416 h1new1 = h2new1 417 h2new1 = t 418 t = h1off1 419 h1off1 = h2off1 420 h2off1 = t 421 end if 422 423 ihashold = h2new1-1+noabn*(h1new1-1+noabn *(p2new1-noabn-1+nvabn 424 1 *(p1new1-noabn-1))) 425 426 ilength = int_mb(k_r2_offsetm(jref)) 427 totaloff = -1 428 429 do k = 1, ilength 430 if(int_mb(k_r2_offsetm(jref)+k).eq.ihashold) then 431 totaloff = 1 432 goto 115 433 endif 434 enddo 435 115 continue 436 437 if((p1new1.le.noabn).or. 438 1 (p2new1.le.noabn).or. 439 2 (h1new1.gt.noabn).or. 440 3 (h2new1.gt.noabn))then ! goto 111 441 totaloff=-1 442 endif 443 444 445 if(totaloff.ne.-1)then 446 447 ioff2 = p1off1*int_mb(k_rangem(jref)+h2new1-1)* 448 1 int_mb(k_rangem(jref)+h1new1-1)* 449 2 int_mb(k_rangem(jref)+p2new1-1)+ 450 2 p2off1*int_mb(k_rangem(jref)+h2new1-1)* 451 3 int_mb(k_rangem(jref)+h1new1-1)+ 452 4 h1off1*int_mb(k_rangem(jref)+h2new1-1)+h2off1 453 454 sizenew1 = int_mb(k_rangem(jref)+p1new1-1)* 455 1 int_mb(k_rangem(jref)+p2new1-1)* 456 2 int_mb(k_rangem(jref)+h1new1-1)* 457 3 int_mb(k_rangem(jref)+h2new1-1) 458 459 l_tmp1=0 460 461 if(ioff2.ne.ioff) then 462 if (.not.ma_push_get(mt_dbl,sizenew1,'tmp1',l_tmp1,k_tmp1)) 463 1 call errquit('tce_uss: MA problem',3,MA_ERR) 464 465 466 CALL DFILL(sizenew1,0.0d0,dbl_mb(k_tmp1),1) 467 468 dbl_mb(k_tmp1+ioff2)=dbl_mb(k_r1a+counter-1)*dsmult/fact 469 470 call add_hash_block(d_c2,dbl_mb(k_tmp1),sizenew1, 471 1 int_mb(k_r2_offsetm(jref)),h2new1-1+noabn*(h1new1-1+noabn * 472 1 (p2new1-noabn-1+nvabn*(p1new1-noabn-1)))) 473 474 if (.not.ma_pop_stack(l_tmp1)) 475 1 call errquit('tce_uss: MA problem',4,MA_ERR) 476 endif 477 endif !totaloff 478 endif 479c 480 481 endif 482cc endif!all same spin 483ccccc 484! 485111 continue 486 end do 487 end do 488! 489 if (.not.ma_pop_stack(l_r1a)) 490 1 call errquit('tce_uss: MA problem',2,MA_ERR) 491 492 493 end if 494 end if 495 end if 496 if(lusesub) then 497 next = NXTASKsub(nprocs,1,mypgid) 498 else 499 next = NXTASK(nprocs, 1) 500 endif 501 END IF 502 count = count + 1 503! 504 END DO 505 END DO 506! 507 if(lusesub) then 508 next = NXTASKsub(-nprocs,1,mypgid) 509 call GA_pgroup_SYNC(mypgid) 510 else 511 next = NXTASK(-nprocs, 1) 512 call GA_SYNC() 513 endif 514 515 return 516 end 517c 518