1 subroutine tce_loc_j2(d_r2,k_r2_offset,d_t2,k_t2_offset) 2c 3c $Id$ 4c 5c TO DO - initial 1.0-ing of the d_t2 file 6c 7c 8c 9c 10 implicit none 11#include "global.fh" 12#include "mafdecls.fh" 13#include "sym.fh" 14#include "util.fh" 15#include "stdio.fh" 16#include "errquit.fh" 17#include "tce.fh" 18#include "tce_main.fh" 19 integer d_r2 20 integer p1b 21 integer p2b 22 integer h3b 23 integer h4b 24 integer p1 25 integer p2 26 integer h3 27 integer h4 28 integer k_r2_offset 29 integer size 30 integer l_r2,k_r2 31 integer i 32 integer nprocs 33 integer count 34 integer next 35 integer nxtask 36c --- t2 scan --- 37 integer d_t2 38 integer k_t2_offset 39 integer l_t2,k_t2 40 integer pp1b,pp2b 41 integer hh3b,hh4b 42 integer tsize 43 integer ii 44 integer pp1,pp2,hh3,hh4 45 integer ipa1,ipa2,iha3,iha4 46 integer ip1,ip2,ih3,ih4 47 integer spin_sum,spin_suml 48 integer p2alpha 49 integer h4alpha 50 integer ip2alpha 51 integer ih4alpha 52c --------------- 53 external nxtask 54 logical nodezero 55 logical noloadbalance 56c 57 nodezero = (ga_nodeid().eq.0) 58 noloadbalance = ((ioalg.eq.4).or. 59 1 ((ioalg.eq.6).and.(.not.fileisga(d_r2)))) 60 nprocs = ga_nnodes() 61 count = 0 62 next = nxtask(nprocs,1) 63 do p1b = noab+1,noab+nvab 64 do p2b = p1b,noab+nvab 65 do h3b = 1,noab 66 do h4b = h3b,noab 67 if (noloadbalance.or.(next.eq.count)) then 68 if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) 69 1 .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then 70 if ((.not.restricted).or. 71 1 (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+ 72 2 int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then 73 if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1), 74 1 ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1)))) 75 2 .eq. irrep_x) then 76 size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 77 1 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 78 if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2)) 79 1 call errquit('tce_jacobi_x2: MA problem',0,MA_ERR) 80 call get_hash_block(d_r2,dbl_mb(k_r2),size, 81 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 82 2 *noab+h3b-1)*noab+h4b-1)) 83c 84 if(restricted) then 85 spin_sum=int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+ 86 1 int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1) 87 if(spin_sum.eq.6) then 88 p2alpha=int_mb(k_alpha+p2b-1) 89 h4alpha=int_mb(k_alpha+h4b-1) 90 end if 91 end if 92 i = 0 93 do p1 = 1,int_mb(k_range+p1b-1) 94 do p2 = 1,int_mb(k_range+p2b-1) 95 do h3 = 1,int_mb(k_range+h3b-1) 96 do h4 = 1,int_mb(k_range+h4b-1) 97 i = i + 1 98 ip1=int_mb(k_offset+p1b-1)+p1 99 ip2=int_mb(k_offset+p2b-1)+p2 100 ih3=int_mb(k_offset+h3b-1)+h3 101 ih4=int_mb(k_offset+h4b-1)+h4 102 if(restricted.and.(spin_sum.eq.6)) then 103 ip2alpha=int_mb(k_offset+p2alpha-1)+p2 104 ih4alpha=int_mb(k_offset+h4alpha-1)+h4 105 end if 106c dbl_mb(k_r2+i-1) = dbl_mb(k_r2+i-1) 107c 1 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1) 108c 2 -dbl_mb(k_evl_sorted+int_mb(k_offset+p2b-1)+p2-1) 109c 3 +dbl_mb(k_evl_sorted+int_mb(k_offset+h3b-1)+h3-1) 110c 4 +dbl_mb(k_evl_sorted+int_mb(k_offset+h4b-1)+h4-1)) 111c --- loop over t2 ----------- 112 do pp1b = noab+1,noab+nvab 113 do pp2b = pp1b,noab+nvab 114 do hh3b = 1,noab 115 do hh4b = hh3b,noab 116 if (int_mb(k_spin+pp1b-1)+int_mb(k_spin+pp2b-1) 117 1 .eq. int_mb(k_spin+hh3b-1)+int_mb(k_spin+hh4b-1)) then 118 if ((.not.restricted).or. 119 1 (int_mb(k_spin+pp1b-1)+int_mb(k_spin+pp2b-1)+ 120 2 int_mb(k_spin+hh3b-1)+int_mb(k_spin+hh4b-1).ne.8)) then 121 if (ieor(int_mb(k_sym+pp1b-1),ieor(int_mb(k_sym+pp2b-1), 122 1 ieor(int_mb(k_sym+hh3b-1),int_mb(k_sym+hh4b-1)))) 123 2 .eq. 0) then 124 tsize = int_mb(k_range+pp1b-1) * int_mb(k_range+pp2b-1) 125 1 * int_mb(k_range+hh3b-1) * int_mb(k_range+hh4b-1) 126 if (.not.ma_push_get(mt_dbl,tsize,'t2',l_t2,k_t2)) 127 1 call errquit('tce_jacobi_t2: MA problem',0,MA_ERR) 128 call get_hash_block(d_t2,dbl_mb(k_t2),tsize, 129 1 int_mb(k_t2_offset), 130 2 ((((pp1b-noab-1)*nvab+pp2b-noab-1) 131 2 *noab+hh3b-1)*noab+hh4b-1)) 132 if(restricted) then 133 spin_suml=int_mb(k_spin+pp1b-1)+int_mb(k_spin+pp2b-1)+ 134 1 int_mb(k_spin+hh3b-1)+int_mb(k_spin+hh4b-1) 135 end if 136 ii = 0 137 do pp1 = 1,int_mb(k_range+pp1b-1) 138 do pp2 = 1,int_mb(k_range+pp2b-1) 139 do hh3 = 1,int_mb(k_range+hh3b-1) 140 do hh4 = 1,int_mb(k_range+hh4b-1) 141 ii = ii + 1 142c 143 ipa1=int_mb(k_offset+pp1b-1)+pp1 144 ipa2=int_mb(k_offset+pp2b-1)+pp2 145 iha3=int_mb(k_offset+hh3b-1)+hh3 146 iha4=int_mb(k_offset+hh4b-1)+hh4 147c 148 if (ipa1.lt.ipa2.AND.iha3.lt.iha4) THEN 149 if ((ip1.eq.ipa1).or.(ip1.eq.ipa2).or. 150 1 (ip2.eq.ipa1).or.(ip2.eq.ipa2).or. 151 2 (ih3.eq.iha3).or.(ih3.eq.iha4).or. 152 3 (ih4.eq.iha3).or.(ih4.eq.iha4)) then 153 dbl_mb(k_r2+i-1)=dbl_mb(k_r2+i-1)+ 154 1 dbl_mb(k_t2+ii-1)*dbl_mb(k_t2+ii-1) 155 end if 156 if (restricted.and.(spin_sum.eq.6).and.(spin_suml.eq.4)) 157 1 then 158 if ((ip2alpha.eq.ipa1).or.(ip2alpha.eq.ipa2).or. 159 1 (ih4alpha.eq.iha3).or.(ih4alpha.eq.iha4)) THEN 160 dbl_mb(k_r2+i-1)=dbl_mb(k_r2+i-1)+ 161 1 dbl_mb(k_t2+ii-1)*dbl_mb(k_t2+ii-1) 162 end if 163 end if 164 end if 165c 166c dbl_mb(k_t2+ii-1) = dbl_mb(k_t2+ii-1) 167c 1 / (-dbl_mb(k_evl_sorted+int_mb(k_offset+pp1b-1)+pp1-1) 168c 2 -dbl_mb(k_evl_sorted+int_mb(k_offset+pp2b-1)+pp2-1) 169c 3 +dbl_mb(k_evl_sorted+int_mb(k_offset+hh3b-1)+hh3-1) 170c 4 +dbl_mb(k_evl_sorted+int_mb(k_offset+hh4b-1)+hh4-1)) 171 enddo 172 enddo 173 enddo 174 enddo 175 if (.not.ma_pop_stack(l_t2)) 176 1 call errquit('tce_jacobi_t2: MA problem',1,MA_ERR) 177 endif 178 endif 179 endif 180 enddo 181 enddo 182 enddo 183 enddo 184c --- end of t2 loop ----- 185 186 enddo 187 enddo 188 enddo 189 enddo 190 call put_hash_block(d_r2,dbl_mb(k_r2),size, 191 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 192 2 *noab+h3b-1)*noab+h4b-1)) 193 if (.not.ma_pop_stack(l_r2)) 194 1 call errquit('tce_jacobi_x2: MA problem',1,MA_ERR) 195 endif 196 endif 197 endif 198 next = nxtask(nprocs,1) 199 endif 200 count = count + 1 201 enddo 202 enddo 203 enddo 204 enddo 205 next = nxtask(-nprocs,1) 206 call ga_sync() 207 return 208 end 209c 210c 211c 212c 213c 214 subroutine tce_loc_j2_one(d_r2,k_r2_offset) 215c 216c $Id$ 217c 218 implicit none 219#include "global.fh" 220#include "mafdecls.fh" 221#include "sym.fh" 222#include "util.fh" 223#include "stdio.fh" 224#include "errquit.fh" 225#include "tce.fh" 226#include "tce_main.fh" 227 integer d_r2 228 integer p1b 229 integer p2b 230 integer h3b 231 integer h4b 232 integer p1 233 integer p2 234 integer h3 235 integer h4 236 integer k_r2_offset 237 integer size 238 integer l_r2,k_r2 239 integer i 240 integer nprocs 241 integer count 242 integer next 243 integer nxtask 244 external nxtask 245 logical nodezero 246 logical noloadbalance 247c 248 nodezero = (ga_nodeid().eq.0) 249 noloadbalance = ((ioalg.eq.4).or. 250 1 ((ioalg.eq.6).and.(.not.fileisga(d_r2)))) 251 nprocs = ga_nnodes() 252 count = 0 253 next = nxtask(nprocs,1) 254 do p1b = noab+1,noab+nvab 255 do p2b = p1b,noab+nvab 256 do h3b = 1,noab 257 do h4b = h3b,noab 258 if (noloadbalance.or.(next.eq.count)) then 259 if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) 260 1 .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then 261 if ((.not.restricted).or. 262 1 (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+ 263 2 int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then 264 if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1), 265 1 ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1)))) 266 2 .eq. irrep_x) then 267 size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 268 1 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 269 if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2)) 270 1 call errquit('tce_jacobi_x2: MA problem',0,MA_ERR) 271 call get_hash_block(d_r2,dbl_mb(k_r2),size, 272 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 273 2 *noab+h3b-1)*noab+h4b-1)) 274 i = 0 275 do p1 = 1,int_mb(k_range+p1b-1) 276 do p2 = 1,int_mb(k_range+p2b-1) 277 do h3 = 1,int_mb(k_range+h3b-1) 278 do h4 = 1,int_mb(k_range+h4b-1) 279 i = i + 1 280 dbl_mb(k_r2+i-1) = 1.0d0 281 enddo 282 enddo 283 enddo 284 enddo 285 call put_hash_block(d_r2,dbl_mb(k_r2),size, 286 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 287 2 *noab+h3b-1)*noab+h4b-1)) 288 if (.not.ma_pop_stack(l_r2)) 289 1 call errquit('tce_jacobi_x2: MA problem',1,MA_ERR) 290 endif 291 endif 292 endif 293 next = nxtask(nprocs,1) 294 endif 295 count = count + 1 296 enddo 297 enddo 298 enddo 299 enddo 300 next = nxtask(-nprocs,1) 301 call ga_sync() 302 return 303 end 304c 305c 306c 307c 308c 309 subroutine tce_loc_j2_inv(d_r2,k_r2_offset) 310c 311c $Id$ 312c 313 implicit none 314#include "global.fh" 315#include "mafdecls.fh" 316#include "sym.fh" 317#include "util.fh" 318#include "stdio.fh" 319#include "errquit.fh" 320#include "tce.fh" 321#include "tce_main.fh" 322 integer d_r2 323 integer p1b 324 integer p2b 325 integer h3b 326 integer h4b 327 integer p1 328 integer p2 329 integer h3 330 integer h4 331 integer k_r2_offset 332 integer size 333 integer l_r2,k_r2 334 integer i 335 integer nprocs 336 integer count 337 integer next 338 integer nxtask 339 external nxtask 340 logical nodezero 341 logical noloadbalance 342c 343 nodezero = (ga_nodeid().eq.0) 344 noloadbalance = ((ioalg.eq.4).or. 345 1 ((ioalg.eq.6).and.(.not.fileisga(d_r2)))) 346 nprocs = ga_nnodes() 347 count = 0 348 next = nxtask(nprocs,1) 349 do p1b = noab+1,noab+nvab 350 do p2b = p1b,noab+nvab 351 do h3b = 1,noab 352 do h4b = h3b,noab 353 if (noloadbalance.or.(next.eq.count)) then 354 if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) 355 1 .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then 356 if ((.not.restricted).or. 357 1 (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+ 358 2 int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then 359 if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1), 360 1 ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1)))) 361 2 .eq. irrep_x) then 362 size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 363 1 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 364 if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2)) 365 1 call errquit('tce_jacobi_x2: MA problem',0,MA_ERR) 366 call get_hash_block(d_r2,dbl_mb(k_r2),size, 367 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 368 2 *noab+h3b-1)*noab+h4b-1)) 369 i = 0 370 do p1 = 1,int_mb(k_range+p1b-1) 371 do p2 = 1,int_mb(k_range+p2b-1) 372 do h3 = 1,int_mb(k_range+h3b-1) 373 do h4 = 1,int_mb(k_range+h4b-1) 374 i = i + 1 375 dbl_mb(k_r2+i-1) = 1.0d0/dbl_mb(k_r2+i-1) 376 enddo 377 enddo 378 enddo 379 enddo 380 call put_hash_block(d_r2,dbl_mb(k_r2),size, 381 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 382 2 *noab+h3b-1)*noab+h4b-1)) 383 if (.not.ma_pop_stack(l_r2)) 384 1 call errquit('tce_jacobi_x2: MA problem',1,MA_ERR) 385 endif 386 endif 387 endif 388 next = nxtask(nprocs,1) 389 endif 390 count = count + 1 391 enddo 392 enddo 393 enddo 394 enddo 395 next = nxtask(-nprocs,1) 396 call ga_sync() 397 return 398 end 399c 400c 401c 402c 403c 404c 405 subroutine tce_j2_x2_scaling(d_r2,k_r2_offset,d_j2,k_j2_offset) 406c 407c $Id$ 408c 409 implicit none 410#include "global.fh" 411#include "mafdecls.fh" 412#include "sym.fh" 413#include "util.fh" 414#include "stdio.fh" 415#include "errquit.fh" 416#include "tce.fh" 417#include "tce_main.fh" 418 integer d_r2 419 integer p1b 420 integer p2b 421 integer h3b 422 integer h4b 423 integer p1 424 integer p2 425 integer h3 426 integer h4 427 integer k_r2_offset 428 integer size 429 integer l_r2,k_r2 430 integer i 431c --- 432 integer d_j2 433 integer k_j2_offset 434 integer l_j2,k_j2 435c --- 436 integer nprocs 437 integer count 438 integer next 439 integer nxtask 440 external nxtask 441 logical nodezero 442 logical noloadbalance 443c 444 nodezero = (ga_nodeid().eq.0) 445 noloadbalance = ((ioalg.eq.4).or. 446 1 ((ioalg.eq.6).and.(.not.fileisga(d_r2)))) 447 nprocs = ga_nnodes() 448 count = 0 449 next = nxtask(nprocs,1) 450 do p1b = noab+1,noab+nvab 451 do p2b = p1b,noab+nvab 452 do h3b = 1,noab 453 do h4b = h3b,noab 454 if (noloadbalance.or.(next.eq.count)) then 455 if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) 456 1 .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then 457 if ((.not.restricted).or. 458 1 (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+ 459 2 int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then 460 if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1), 461 1 ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1)))) 462 2 .eq. irrep_x) then 463 size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 464 1 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) 465 if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2)) 466 1 call errquit('tce_jacobi_x2: MA problem',0,MA_ERR) 467 if (.not.ma_push_get(mt_dbl,size,'r2',l_j2,k_j2)) 468 1 call errquit('tce_jacobi_x2: MA problem',0,MA_ERR) 469 call get_hash_block(d_r2,dbl_mb(k_r2),size, 470 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 471 2 *noab+h3b-1)*noab+h4b-1)) 472 call get_hash_block(d_j2,dbl_mb(k_j2),size, 473 1 int_mb(k_j2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 474 2 *noab+h3b-1)*noab+h4b-1)) 475 i = 0 476 do p1 = 1,int_mb(k_range+p1b-1) 477 do p2 = 1,int_mb(k_range+p2b-1) 478 do h3 = 1,int_mb(k_range+h3b-1) 479 do h4 = 1,int_mb(k_range+h4b-1) 480 i = i + 1 481 dbl_mb(k_r2+i-1) = dbl_mb(k_r2+i-1)*dbl_mb(k_j2+i-1) 482 enddo 483 enddo 484 enddo 485 enddo 486 call put_hash_block(d_r2,dbl_mb(k_r2),size, 487 1 int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1) 488 2 *noab+h3b-1)*noab+h4b-1)) 489 if (.not.ma_pop_stack(l_j2)) 490 1 call errquit('tce_jacobi_x2: MA problem',1,MA_ERR) 491 if (.not.ma_pop_stack(l_r2)) 492 1 call errquit('tce_jacobi_x2: MA problem',1,MA_ERR) 493 endif 494 endif 495 endif 496 next = nxtask(nprocs,1) 497 endif 498 count = count + 1 499 enddo 500 enddo 501 enddo 502 enddo 503 next = nxtask(-nprocs,1) 504 call ga_sync() 505 return 506 end 507