1 SUBROUTINE cis_x1(d_f1,d_i0,d_v2,d_x1,k_f1_offset,k_i0_offset,k_v2 2 &_offset,k_x1_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 i0 ( p2 h1 )_xf + = -1 * Sum ( h3 ) * x ( p2 h3 )_x * f ( h3 h1 )_f 7C i0 ( p2 h1 )_xf + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * f ( p2 p3 )_f 8C i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v 9 IMPLICIT NONE 10#include "global.fh" 11#include "mafdecls.fh" 12#include "util.fh" 13#include "errquit.fh" 14#include "tce.fh" 15 INTEGER d_i0 16 INTEGER k_i0_offset 17 INTEGER d_x1 18 INTEGER k_x1_offset 19 INTEGER d_f1 20 INTEGER k_f1_offset 21 INTEGER d_v2 22 INTEGER k_v2_offset 23 CALL cis_x1_1(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset) 24 CALL cis_x1_2(d_x1,k_x1_offset,d_f1,k_f1_offset,d_i0,k_i0_offset) 25 CALL cis_x1_3(d_x1,k_x1_offset,d_v2,k_v2_offset,d_i0,k_i0_offset) 26 RETURN 27 END 28 SUBROUTINE cis_x1_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 29C $Id$ 30C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 31C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 32C i0 ( p2 h1 )_xf + = -1 * Sum ( h3 ) * x ( p2 h3 )_x * f ( h3 h1 )_f 33 IMPLICIT NONE 34#include "global.fh" 35#include "mafdecls.fh" 36#include "sym.fh" 37#include "errquit.fh" 38#include "tce.fh" 39 INTEGER d_a 40 INTEGER k_a_offset 41 INTEGER d_b 42 INTEGER k_b_offset 43 INTEGER d_c 44 INTEGER k_c_offset 45 INTEGER nxtask 46 INTEGER next 47 INTEGER nprocs 48 INTEGER count 49 INTEGER p2b 50 INTEGER h1b 51 INTEGER dimc 52 INTEGER l_c_sort 53 INTEGER k_c_sort 54 INTEGER h3b 55 INTEGER p2b_1 56 INTEGER h3b_1 57 INTEGER h3b_2 58 INTEGER h1b_2 59 INTEGER dim_common 60 INTEGER dima_sort 61 INTEGER dima 62 INTEGER dimb_sort 63 INTEGER dimb 64 INTEGER l_a_sort 65 INTEGER k_a_sort 66 INTEGER l_a 67 INTEGER k_a 68 INTEGER l_b_sort 69 INTEGER k_b_sort 70 INTEGER l_b 71 INTEGER k_b 72 INTEGER l_c 73 INTEGER k_c 74 EXTERNAL nxtask 75 nprocs = GA_NNODES() 76 count = 0 77 next = nxtask(nprocs,1) 78 DO p2b = noab+1,noab+nvab 79 DO h1b = 1,noab 80 IF (next.eq.count) THEN 81 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 82 &).ne.4)) THEN 83 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 84 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 85 &x,irrep_f)) THEN 86 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 87 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 88 & ERRQUIT('cis_x1_1',0,MA_ERR) 89 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 90 DO h3b = 1,noab 91 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h3b-1)) THEN 92 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH 93 &EN 94 CALL TCE_RESTRICTED_2(p2b,h3b,p2b_1,h3b_1) 95 CALL TCE_RESTRICTED_2(h3b,h1b,h3b_2,h1b_2) 96 dim_common = int_mb(k_range+h3b-1) 97 dima_sort = int_mb(k_range+p2b-1) 98 dima = dim_common * dima_sort 99 dimb_sort = int_mb(k_range+h1b-1) 100 dimb = dim_common * dimb_sort 101 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 102 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 103 & ERRQUIT('cis_x1_1',1,MA_ERR) 104 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 105 &cis_x1_1',2,MA_ERR) 106 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 107 & - 1 + noab * (p2b_1 - noab - 1))) 108 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 109 &,int_mb(k_range+h3b-1),1,2,1.0d0) 110 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cis_x1_1',3,MA_ERR) 111 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 112 & ERRQUIT('cis_x1_1',4,MA_ERR) 113 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 114 &cis_x1_1',5,MA_ERR) 115 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h1b_2 116 & - 1 + (noab+nvab) * (h3b_2 - 1))) 117 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 118 &,int_mb(k_range+h1b-1),2,1,1.0d0) 119 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cis_x1_1',6,MA_ERR) 120 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 121 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 122 &t),dima_sort) 123 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cis_x1_1',7,MA_ERR) 124 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cis_x1_1',8,MA_ERR) 125 END IF 126 END IF 127 END IF 128 END DO 129 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 130 &cis_x1_1',9,MA_ERR) 131 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 132 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 133 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 134 & 1 + noab * (p2b - noab - 1))) 135 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cis_x1_1',10,MA_ERR) 136 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cis_x1_1',11,MA_ERR 137 &) 138 END IF 139 END IF 140 END IF 141 next = nxtask(nprocs,1) 142 END IF 143 count = count + 1 144 END DO 145 END DO 146 next = nxtask(-nprocs,1) 147 call GA_SYNC() 148 RETURN 149 END 150 SUBROUTINE cis_x1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 151C $Id$ 152C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 153C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 154C i0 ( p2 h1 )_xf + = 1 * Sum ( p3 ) * x ( p3 h1 )_x * f ( p2 p3 )_f 155 IMPLICIT NONE 156#include "global.fh" 157#include "mafdecls.fh" 158#include "sym.fh" 159#include "errquit.fh" 160#include "tce.fh" 161 INTEGER d_a 162 INTEGER k_a_offset 163 INTEGER d_b 164 INTEGER k_b_offset 165 INTEGER d_c 166 INTEGER k_c_offset 167 INTEGER nxtask 168 INTEGER next 169 INTEGER nprocs 170 INTEGER count 171 INTEGER p2b 172 INTEGER h1b 173 INTEGER dimc 174 INTEGER l_c_sort 175 INTEGER k_c_sort 176 INTEGER p3b 177 INTEGER p3b_1 178 INTEGER h1b_1 179 INTEGER p2b_2 180 INTEGER p3b_2 181 INTEGER dim_common 182 INTEGER dima_sort 183 INTEGER dima 184 INTEGER dimb_sort 185 INTEGER dimb 186 INTEGER l_a_sort 187 INTEGER k_a_sort 188 INTEGER l_a 189 INTEGER k_a 190 INTEGER l_b_sort 191 INTEGER k_b_sort 192 INTEGER l_b 193 INTEGER k_b 194 INTEGER l_c 195 INTEGER k_c 196 EXTERNAL nxtask 197 nprocs = GA_NNODES() 198 count = 0 199 next = nxtask(nprocs,1) 200 DO p2b = noab+1,noab+nvab 201 DO h1b = 1,noab 202 IF (next.eq.count) THEN 203 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 204 &).ne.4)) THEN 205 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 206 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 207 &x,irrep_f)) THEN 208 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 209 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 210 & ERRQUIT('cis_x1_2',0,MA_ERR) 211 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 212 DO p3b = noab+1,noab+nvab 213 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 214 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_x) TH 215 &EN 216 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 217 CALL TCE_RESTRICTED_2(p2b,p3b,p2b_2,p3b_2) 218 dim_common = int_mb(k_range+p3b-1) 219 dima_sort = int_mb(k_range+h1b-1) 220 dima = dim_common * dima_sort 221 dimb_sort = int_mb(k_range+p2b-1) 222 dimb = dim_common * dimb_sort 223 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 224 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 225 & ERRQUIT('cis_x1_2',1,MA_ERR) 226 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 227 &cis_x1_2',2,MA_ERR) 228 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 229 & - 1 + noab * (p3b_1 - noab - 1))) 230 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 231 &,int_mb(k_range+h1b-1),2,1,1.0d0) 232 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cis_x1_2',3,MA_ERR) 233 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 234 & ERRQUIT('cis_x1_2',4,MA_ERR) 235 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 236 &cis_x1_2',5,MA_ERR) 237 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 238 & - 1 + (noab+nvab) * (p2b_2 - 1))) 239 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+p2b-1) 240 &,int_mb(k_range+p3b-1),1,2,1.0d0) 241 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cis_x1_2',6,MA_ERR) 242 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 243 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 244 &t),dima_sort) 245 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cis_x1_2',7,MA_ERR) 246 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cis_x1_2',8,MA_ERR) 247 END IF 248 END IF 249 END IF 250 END DO 251 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 252 &cis_x1_2',9,MA_ERR) 253 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 254 &,int_mb(k_range+h1b-1),1,2,1.0d0) 255 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 256 & 1 + noab * (p2b - noab - 1))) 257 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cis_x1_2',10,MA_ERR) 258 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cis_x1_2',11,MA_ERR 259 &) 260 END IF 261 END IF 262 END IF 263 next = nxtask(nprocs,1) 264 END IF 265 count = count + 1 266 END DO 267 END DO 268 next = nxtask(-nprocs,1) 269 call GA_SYNC() 270 RETURN 271 END 272 SUBROUTINE cis_x1_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 273C $Id$ 274C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 275C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 276C i0 ( p2 h1 )_xv + = -1 * Sum ( p4 h3 ) * x ( p4 h3 )_x * v ( h3 p2 h1 p4 )_v 277 IMPLICIT NONE 278#include "global.fh" 279#include "mafdecls.fh" 280#include "sym.fh" 281#include "errquit.fh" 282#include "tce.fh" 283 INTEGER d_a 284 INTEGER k_a_offset 285 INTEGER d_b 286 INTEGER k_b_offset 287 INTEGER d_c 288 INTEGER k_c_offset 289 INTEGER nxtask 290 INTEGER next 291 INTEGER nprocs 292 INTEGER count 293 INTEGER p2b 294 INTEGER h1b 295 INTEGER dimc 296 INTEGER l_c_sort 297 INTEGER k_c_sort 298 INTEGER p4b 299 INTEGER h3b 300 INTEGER p4b_1 301 INTEGER h3b_1 302 INTEGER p2b_2 303 INTEGER h3b_2 304 INTEGER h1b_2 305 INTEGER p4b_2 306 INTEGER dim_common 307 INTEGER dima_sort 308 INTEGER dima 309 INTEGER dimb_sort 310 INTEGER dimb 311 INTEGER l_a_sort 312 INTEGER k_a_sort 313 INTEGER l_a 314 INTEGER k_a 315 INTEGER l_b_sort 316 INTEGER k_b_sort 317 INTEGER l_b 318 INTEGER k_b 319 INTEGER l_c 320 INTEGER k_c 321 EXTERNAL nxtask 322 nprocs = GA_NNODES() 323 count = 0 324 next = nxtask(nprocs,1) 325 DO p2b = noab+1,noab+nvab 326 DO h1b = 1,noab 327 IF (next.eq.count) THEN 328 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 329 &).ne.4)) THEN 330 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 331 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 332 &x,irrep_v)) THEN 333 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 334 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 335 & ERRQUIT('cis_x1_3',0,MA_ERR) 336 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 337 DO p4b = noab+1,noab+nvab 338 DO h3b = 1,noab 339 IF (int_mb(k_spin+p4b-1) .eq. int_mb(k_spin+h3b-1)) THEN 340 IF (ieor(int_mb(k_sym+p4b-1),int_mb(k_sym+h3b-1)) .eq. irrep_x) TH 341 &EN 342 CALL TCE_RESTRICTED_2(p4b,h3b,p4b_1,h3b_1) 343 CALL TCE_RESTRICTED_4(p2b,h3b,h1b,p4b,p2b_2,h3b_2,h1b_2,p4b_2) 344 dim_common = int_mb(k_range+p4b-1) * int_mb(k_range+h3b-1) 345 dima_sort = 1 346 dima = dim_common * dima_sort 347 dimb_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 348 dimb = dim_common * dimb_sort 349 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 350 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 351 & ERRQUIT('cis_x1_3',1,MA_ERR) 352 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 353 &cis_x1_3',2,MA_ERR) 354 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 355 & - 1 + noab * (p4b_1 - noab - 1))) 356 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 357 &,int_mb(k_range+h3b-1),2,1,1.0d0) 358 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('cis_x1_3',3,MA_ERR) 359 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 360 & ERRQUIT('cis_x1_3',4,MA_ERR) 361 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 362 &cis_x1_3',5,MA_ERR) 363 IF ((h3b .le. p2b) .and. (h1b .le. p4b)) THEN 364 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 365 & - 1 + (noab+nvab) * (h1b_2 - 1 + (noab+nvab) * (p2b_2 - 1 + (noab 366 &+nvab) * (h3b_2 - 1))))) 367 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 368 &,int_mb(k_range+p2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p4b-1) 369 &,3,2,1,4,1.0d0) 370 END IF 371 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('cis_x1_3',6,MA_ERR) 372 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 373 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 374 &t),dima_sort) 375 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('cis_x1_3',7,MA_ERR) 376 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('cis_x1_3',8,MA_ERR) 377 END IF 378 END IF 379 END IF 380 END DO 381 END DO 382 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 383 &cis_x1_3',9,MA_ERR) 384 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 385 &,int_mb(k_range+p2b-1),2,1,-1.0d0) 386 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 387 & 1 + noab * (p2b - noab - 1))) 388 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('cis_x1_3',10,MA_ERR) 389 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('cis_x1_3',11,MA_ERR 390 &) 391 END IF 392 END IF 393 END IF 394 next = nxtask(nprocs,1) 395 END IF 396 count = count + 1 397 END DO 398 END DO 399 next = nxtask(-nprocs,1) 400 call GA_SYNC() 401 RETURN 402 END 403