1 SUBROUTINE ccsd_2pdm_hphh_mo(d_i0,d_t1,d_t2,d_y1,d_y2,k_i0_offset, 2 &k_t1_offset,k_t2_offset,k_y1_offset,k_y2_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 ( h4 p3 h1 h2 )_yt + = -1/2 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * y ( h4 p5 )_y 7C i0 ( h2 p3 h1 h4 )_ytt + = -1/2 * P( 4 ) * t ( p3 h1 )_t * i1 ( h2 h4 )_yt 8C i1 ( h2 h1 )_yt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * y ( h2 p5 )_y 9C i1 ( h2 h1 )_yt + = 1/2 * Sum ( h7 p5 p6 ) * t ( p5 p6 h1 h7 )_t * y ( h2 h7 p5 p6 )_y 10C i0 ( h1 p3 h2 h4 )_ytt + = 1/4 * P( 2 ) * Sum ( h7 ) * t ( p3 h7 )_t * i1 ( h1 h7 h2 h4 )_yt 11C i1 ( h4 h7 h1 h2 )_yt + = -1 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * y ( h4 h7 p5 p6 )_y 12C i1 ( h2 h7 h1 h4 )_ytt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h2 h7 h4 p5 )_yt 13C i2 ( h2 h7 h1 p5 )_yt + = 1 * Sum ( p6 ) * t ( p6 h1 )_t * y ( h2 h7 p5 p6 )_y 14C i0 ( h2 p3 h1 h4 )_ytt + = 1/2 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h2 h6 h4 p5 )_yt 15C i1 ( h2 h6 h1 p5 )_yt + = 1 * Sum ( p7 ) * t ( p7 h1 )_t * y ( h2 h6 p5 p7 )_y 16 IMPLICIT NONE 17#include "global.fh" 18#include "mafdecls.fh" 19#include "util.fh" 20#include "errquit.fh" 21#include "tce.fh" 22 INTEGER d_i0 23 INTEGER k_i0_offset 24 INTEGER d_t2 25 INTEGER k_t2_offset 26 INTEGER d_y1 27 INTEGER k_y1_offset 28 INTEGER d_t1 29 INTEGER k_t1_offset 30 INTEGER d_i1 31 INTEGER k_i1_offset 32 INTEGER l_i1_offset 33 INTEGER size_i1 34 INTEGER d_y2 35 INTEGER k_y2_offset 36 INTEGER d_i2 37 INTEGER k_i2_offset 38 INTEGER l_i2_offset 39 INTEGER size_i2 40 CHARACTER*255 filename 41 CALL ccsd_2pdm_hphh_mo_1(d_t2,k_t2_offset,d_y1,k_y1_offset,d_i0,k_ 42 &i0_offset) 43 CALL OFFSET_ccsd_2pdm_hphh_mo_2_1(l_i1_offset,k_i1_offset,size_i1) 44 CALL TCE_FILENAME('ccsd_2pdm_hphh_mo_2_1_i1',filename) 45 CALL CREATEFILE(filename,d_i1,size_i1) 46 CALL ccsd_2pdm_hphh_mo_2_1(d_t1,k_t1_offset,d_y1,k_y1_offset,d_i1, 47 &k_i1_offset) 48 CALL ccsd_2pdm_hphh_mo_2_2(d_t2,k_t2_offset,d_y2,k_y2_offset,d_i1, 49 &k_i1_offset) 50 CALL RECONCILEFILE(d_i1,size_i1) 51 CALL ccsd_2pdm_hphh_mo_2(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_ 52 &i0_offset) 53 CALL DELETEFILE(d_i1) 54 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsd_2pdm_hphh_m 55 &o',-1,MA_ERR) 56 CALL OFFSET_ccsd_2pdm_hphh_mo_3_1(l_i1_offset,k_i1_offset,size_i1) 57 CALL TCE_FILENAME('ccsd_2pdm_hphh_mo_3_1_i1',filename) 58 CALL CREATEFILE(filename,d_i1,size_i1) 59 CALL ccsd_2pdm_hphh_mo_3_1(d_t2,k_t2_offset,d_y2,k_y2_offset,d_i1, 60 &k_i1_offset) 61 CALL OFFSET_ccsd_2pdm_hphh_mo_3_2_1(l_i2_offset,k_i2_offset,size_i 62 &2) 63 CALL TCE_FILENAME('ccsd_2pdm_hphh_mo_3_2_1_i2',filename) 64 CALL CREATEFILE(filename,d_i2,size_i2) 65 CALL ccsd_2pdm_hphh_mo_3_2_1(d_t1,k_t1_offset,d_y2,k_y2_offset,d_i 66 &2,k_i2_offset) 67 CALL RECONCILEFILE(d_i2,size_i2) 68 CALL ccsd_2pdm_hphh_mo_3_2(d_t1,k_t1_offset,d_i2,k_i2_offset,d_i1, 69 &k_i1_offset) 70 CALL DELETEFILE(d_i2) 71 IF (.not.MA_POP_STACK(l_i2_offset)) CALL ERRQUIT('ccsd_2pdm_hphh_m 72 &o',-1,MA_ERR) 73 CALL RECONCILEFILE(d_i1,size_i1) 74 CALL ccsd_2pdm_hphh_mo_3(d_t1,k_t1_offset,d_i1,k_i1_offset,d_i0,k_ 75 &i0_offset) 76 CALL DELETEFILE(d_i1) 77 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsd_2pdm_hphh_m 78 &o',-1,MA_ERR) 79 CALL OFFSET_ccsd_2pdm_hphh_mo_4_1(l_i1_offset,k_i1_offset,size_i1) 80 CALL TCE_FILENAME('ccsd_2pdm_hphh_mo_4_1_i1',filename) 81 CALL CREATEFILE(filename,d_i1,size_i1) 82 CALL ccsd_2pdm_hphh_mo_4_1(d_t1,k_t1_offset,d_y2,k_y2_offset,d_i1, 83 &k_i1_offset) 84 CALL RECONCILEFILE(d_i1,size_i1) 85 CALL ccsd_2pdm_hphh_mo_4(d_t2,k_t2_offset,d_i1,k_i1_offset,d_i0,k_ 86 &i0_offset) 87 CALL DELETEFILE(d_i1) 88 IF (.not.MA_POP_STACK(l_i1_offset)) CALL ERRQUIT('ccsd_2pdm_hphh_m 89 &o',-1,MA_ERR) 90 RETURN 91 END 92 SUBROUTINE ccsd_2pdm_hphh_mo_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k 93 &_c_offset) 94C $Id$ 95C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 96C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 97C i0 ( h4 p3 h1 h2 )_yt + = -1/2 * P( 2 ) * Sum ( p5 ) * t ( p3 p5 h1 h2 )_t * y ( h4 p5 )_y 98 IMPLICIT NONE 99#include "global.fh" 100#include "mafdecls.fh" 101#include "sym.fh" 102#include "errquit.fh" 103#include "tce.fh" 104 INTEGER d_a 105 INTEGER k_a_offset 106 INTEGER d_b 107 INTEGER k_b_offset 108 INTEGER d_c 109 INTEGER k_c_offset 110 INTEGER nxtask 111 INTEGER next 112 INTEGER nprocs 113 INTEGER count 114 INTEGER p3b 115 INTEGER h4b 116 INTEGER h1b 117 INTEGER h2b 118 INTEGER dimc 119 INTEGER l_c_sort 120 INTEGER k_c_sort 121 INTEGER p5b 122 INTEGER p3b_1 123 INTEGER p5b_1 124 INTEGER h1b_1 125 INTEGER h2b_1 126 INTEGER h4b_2 127 INTEGER p5b_2 128 INTEGER dim_common 129 INTEGER dima_sort 130 INTEGER dima 131 INTEGER dimb_sort 132 INTEGER dimb 133 INTEGER l_a_sort 134 INTEGER k_a_sort 135 INTEGER l_a 136 INTEGER k_a 137 INTEGER l_b_sort 138 INTEGER k_b_sort 139 INTEGER l_b 140 INTEGER k_b 141 INTEGER l_c 142 INTEGER k_c 143 EXTERNAL nxtask 144 nprocs = GA_NNODES() 145 count = 0 146 next = nxtask(nprocs,1) 147 DO h4b = 1,noab 148 DO p3b = noab+1,noab+nvab 149 DO h1b = 1,noab 150 DO h2b = h1b,noab 151 IF (next.eq.count) THEN 152 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1 153 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 154 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 155 &1b-1)+int_mb(k_spin+h2b-1)) THEN 156 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 157 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 158 &EN 159 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+p3b-1) * int_mb(k_ra 160 &nge+h1b-1) * int_mb(k_range+h2b-1) 161 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 162 & ERRQUIT('ccsd_2pdm_hphh_mo_1',0,MA_ERR) 163 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 164 DO p5b = noab+1,noab+nvab 165 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 166 &1b-1)+int_mb(k_spin+h2b-1)) THEN 167 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 168 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 169 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h2b,p3b_1,p5b_1,h1b_1,h2b_1) 170 CALL TCE_RESTRICTED_2(h4b,p5b,h4b_2,p5b_2) 171 dim_common = int_mb(k_range+p5b-1) 172 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) * int_mb 173 &(k_range+h2b-1) 174 dima = dim_common * dima_sort 175 dimb_sort = int_mb(k_range+h4b-1) 176 dimb = dim_common * dimb_sort 177 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 178 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 179 & ERRQUIT('ccsd_2pdm_hphh_mo_1',1,MA_ERR) 180 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 181 &ccsd_2pdm_hphh_mo_1',2,MA_ERR) 182 IF ((p5b .lt. p3b)) THEN 183 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 184 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 185 &1 - noab - 1))))) 186 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 187 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 188 &,4,3,2,1,-1.0d0) 189 END IF 190 IF ((p3b .le. p5b)) THEN 191 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 192 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 193 &1 - noab - 1))))) 194 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 195 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 196 &,4,3,1,2,1.0d0) 197 END IF 198 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_1',3,M 199 &A_ERR) 200 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 201 & ERRQUIT('ccsd_2pdm_hphh_mo_1',4,MA_ERR) 202 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 203 &ccsd_2pdm_hphh_mo_1',5,MA_ERR) 204 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 205 & - noab - 1 + nvab * (h4b_2 - 1))) 206 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 207 &,int_mb(k_range+p5b-1),1,2,1.0d0) 208 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_1',6,M 209 &A_ERR) 210 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 211 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 212 &t),dima_sort) 213 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_1 214 &',7,MA_ERR) 215 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_1 216 &',8,MA_ERR) 217 END IF 218 END IF 219 END IF 220 END DO 221 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 222 &ccsd_2pdm_hphh_mo_1',9,MA_ERR) 223c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 224c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 225c &,1,4,3,2,-1.0d0/2.0d0) 226 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 227 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 228 &,1,4,3,2,1.0d0) 229 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 230 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (h4b - 1))) 231 &)) 232c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 233c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 234c &,4,1,3,2,1.0d0/2.0d0) 235c CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 236c & 1 + noab * (h1b - 1 + noab * (h4b - 1 + noab * (p3b - noab - 1))) 237c &)) 238 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_1',10, 239 &MA_ERR) 240 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_1 241 &',11,MA_ERR) 242 END IF 243 END IF 244 END IF 245 next = nxtask(nprocs,1) 246 END IF 247 count = count + 1 248 END DO 249 END DO 250 END DO 251 END DO 252 next = nxtask(-nprocs,1) 253 call GA_SYNC() 254 RETURN 255 END 256 SUBROUTINE ccsd_2pdm_hphh_mo_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k 257 &_c_offset) 258C $Id$ 259C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 260C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 261C i0 ( h2 p3 h1 h4 )_ytt + = -1/2 * P( 4 ) * t ( p3 h1 )_t * i1 ( h2 h4 )_yt 262 IMPLICIT NONE 263#include "global.fh" 264#include "mafdecls.fh" 265#include "sym.fh" 266#include "errquit.fh" 267#include "tce.fh" 268 INTEGER d_a 269 INTEGER k_a_offset 270 INTEGER d_b 271 INTEGER k_b_offset 272 INTEGER d_c 273 INTEGER k_c_offset 274 INTEGER nxtask 275 INTEGER next 276 INTEGER nprocs 277 INTEGER count 278 INTEGER p3b 279 INTEGER h2b 280 INTEGER h1b 281 INTEGER h4b 282 INTEGER dimc 283 INTEGER l_c_sort 284 INTEGER k_c_sort 285 INTEGER p3b_1 286 INTEGER h1b_1 287 INTEGER h2b_2 288 INTEGER h4b_2 289 INTEGER dim_common 290 INTEGER dima_sort 291 INTEGER dima 292 INTEGER dimb_sort 293 INTEGER dimb 294 INTEGER l_a_sort 295 INTEGER k_a_sort 296 INTEGER l_a 297 INTEGER k_a 298 INTEGER l_b_sort 299 INTEGER k_b_sort 300 INTEGER l_b 301 INTEGER k_b 302 INTEGER l_c 303 INTEGER k_c 304 EXTERNAL nxtask 305 nprocs = GA_NNODES() 306 count = 0 307 next = nxtask(nprocs,1) 308 DO h2b = 1,noab 309 DO p3b = noab+1,noab+nvab 310 DO h1b = 1,noab 311 DO h4b = 1,noab 312 IF (next.eq.count) THEN 313 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p3b-1 314 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h4b-1).ne.8)) THEN 315 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 316 &1b-1)+int_mb(k_spin+h4b-1)) THEN 317 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 318 &k_sym+h1b-1),int_mb(k_sym+h4b-1)))) .eq. ieor(irrep_y,ieor(irrep_t 319 &,irrep_t))) THEN 320 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p3b-1) * int_mb(k_ra 321 &nge+h1b-1) * int_mb(k_range+h4b-1) 322 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 323 & ERRQUIT('ccsd_2pdm_hphh_mo_2',0,MA_ERR) 324 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 325 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h1b-1)) THEN 326 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 327 &EN 328 CALL TCE_RESTRICTED_2(p3b,h1b,p3b_1,h1b_1) 329 CALL TCE_RESTRICTED_2(h2b,h4b,h2b_2,h4b_2) 330 dim_common = 1 331 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 332 dima = dim_common * dima_sort 333 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h4b-1) 334 dimb = dim_common * dimb_sort 335 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 336 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 337 & ERRQUIT('ccsd_2pdm_hphh_mo_2',1,MA_ERR) 338 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 339 &ccsd_2pdm_hphh_mo_2',2,MA_ERR) 340 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 341 & - 1 + noab * (p3b_1 - noab - 1))) 342 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 343 &,int_mb(k_range+h1b-1),2,1,1.0d0) 344 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2',3,M 345 &A_ERR) 346 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 347 & ERRQUIT('ccsd_2pdm_hphh_mo_2',4,MA_ERR) 348 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 349 &ccsd_2pdm_hphh_mo_2',5,MA_ERR) 350 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 351 & - 1 + noab * (h2b_2 - 1))) 352 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 353 &,int_mb(k_range+h4b-1),2,1,1.0d0) 354 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2',6,M 355 &A_ERR) 356 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 357 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 358 &t),dima_sort) 359 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 360 &',7,MA_ERR) 361 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 362 &',8,MA_ERR) 363 END IF 364 END IF 365 END IF 366 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 367 &ccsd_2pdm_hphh_mo_2',9,MA_ERR) 368 IF ((h1b .le. h4b)) THEN 369c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 370c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 371c &,2,4,3,1,-1.0d0/2.0d0) 372 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 373 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 374 &,2,4,3,1,1.0d0) 375 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 376 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (h2b - 1))) 377 &)) 378 END IF 379 IF ((h4b .le. h1b)) THEN 380c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 381c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 382c &,2,4,1,3,1.0d0/2.0d0) 383 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 384 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 385 &,2,4,1,3,-1.0d0) 386 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 387 & 1 + noab * (h4b - 1 + noab * (p3b - noab - 1 + nvab * (h2b - 1))) 388 &)) 389 END IF 390c IF ((h1b .le. h4b)) THEN 391c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 392c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 393c &,4,2,3,1,1.0d0/2.0d0) 394c CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 395c & 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * (p3b - noab - 1))) 396c &)) 397c END IF 398c IF ((h4b .le. h1b)) THEN 399c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 400c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 401c &,4,2,1,3,-1.0d0/2.0d0) 402c CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 403c & 1 + noab * (h4b - 1 + noab * (h2b - 1 + noab * (p3b - noab - 1))) 404c &)) 405c END IF 406 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2',10, 407 &MA_ERR) 408 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 409 &',11,MA_ERR) 410 END IF 411 END IF 412 END IF 413 next = nxtask(nprocs,1) 414 END IF 415 count = count + 1 416 END DO 417 END DO 418 END DO 419 END DO 420 next = nxtask(-nprocs,1) 421 call GA_SYNC() 422 RETURN 423 END 424 SUBROUTINE ccsd_2pdm_hphh_mo_2_1(d_a,k_a_offset,d_b,k_b_offset,d_c 425 &,k_c_offset) 426C $Id$ 427C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 428C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 429C i1 ( h2 h1 )_yt + = 1 * Sum ( p5 ) * t ( p5 h1 )_t * y ( h2 p5 )_y 430 IMPLICIT NONE 431#include "global.fh" 432#include "mafdecls.fh" 433#include "sym.fh" 434#include "errquit.fh" 435#include "tce.fh" 436 INTEGER d_a 437 INTEGER k_a_offset 438 INTEGER d_b 439 INTEGER k_b_offset 440 INTEGER d_c 441 INTEGER k_c_offset 442 INTEGER nxtask 443 INTEGER next 444 INTEGER nprocs 445 INTEGER count 446 INTEGER h2b 447 INTEGER h1b 448 INTEGER dimc 449 INTEGER l_c_sort 450 INTEGER k_c_sort 451 INTEGER p5b 452 INTEGER p5b_1 453 INTEGER h1b_1 454 INTEGER h2b_2 455 INTEGER p5b_2 456 INTEGER dim_common 457 INTEGER dima_sort 458 INTEGER dima 459 INTEGER dimb_sort 460 INTEGER dimb 461 INTEGER l_a_sort 462 INTEGER k_a_sort 463 INTEGER l_a 464 INTEGER k_a 465 INTEGER l_b_sort 466 INTEGER k_b_sort 467 INTEGER l_b 468 INTEGER k_b 469 INTEGER l_c 470 INTEGER k_c 471 EXTERNAL nxtask 472 nprocs = GA_NNODES() 473 count = 0 474 next = nxtask(nprocs,1) 475 DO h2b = 1,noab 476 DO h1b = 1,noab 477 IF (next.eq.count) THEN 478 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 479 &).ne.4)) THEN 480 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 481 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 482 &y,irrep_t)) THEN 483 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 484 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 485 & ERRQUIT('ccsd_2pdm_hphh_mo_2_1',0,MA_ERR) 486 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 487 DO p5b = noab+1,noab+nvab 488 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 489 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 490 &EN 491 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 492 CALL TCE_RESTRICTED_2(h2b,p5b,h2b_2,p5b_2) 493 dim_common = int_mb(k_range+p5b-1) 494 dima_sort = int_mb(k_range+h1b-1) 495 dima = dim_common * dima_sort 496 dimb_sort = int_mb(k_range+h2b-1) 497 dimb = dim_common * dimb_sort 498 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 499 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 500 & ERRQUIT('ccsd_2pdm_hphh_mo_2_1',1,MA_ERR) 501 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 502 &ccsd_2pdm_hphh_mo_2_1',2,MA_ERR) 503 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 504 & - 1 + noab * (p5b_1 - noab - 1))) 505 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 506 &,int_mb(k_range+h1b-1),2,1,1.0d0) 507 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2_1',3 508 &,MA_ERR) 509 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 510 & ERRQUIT('ccsd_2pdm_hphh_mo_2_1',4,MA_ERR) 511 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 512 &ccsd_2pdm_hphh_mo_2_1',5,MA_ERR) 513 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 514 & - noab - 1 + nvab * (h2b_2 - 1))) 515 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 516 &,int_mb(k_range+p5b-1),1,2,1.0d0) 517 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2_1',6 518 &,MA_ERR) 519 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 520 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 521 &t),dima_sort) 522 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 523 &_1',7,MA_ERR) 524 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 525 &_1',8,MA_ERR) 526 END IF 527 END IF 528 END IF 529 END DO 530 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 531 &ccsd_2pdm_hphh_mo_2_1',9,MA_ERR) 532 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 533 &,int_mb(k_range+h1b-1),1,2,1.0d0) 534 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 535 & 1 + noab * (h2b - 1))) 536 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2_1',1 537 &0,MA_ERR) 538 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 539 &_1',11,MA_ERR) 540 END IF 541 END IF 542 END IF 543 next = nxtask(nprocs,1) 544 END IF 545 count = count + 1 546 END DO 547 END DO 548 next = nxtask(-nprocs,1) 549 call GA_SYNC() 550 RETURN 551 END 552 SUBROUTINE OFFSET_ccsd_2pdm_hphh_mo_2_1(l_a_offset,k_a_offset,size 553 &) 554C $Id$ 555C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 556C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 557C i1 ( h2 h1 )_yt 558 IMPLICIT NONE 559#include "global.fh" 560#include "mafdecls.fh" 561#include "sym.fh" 562#include "errquit.fh" 563#include "tce.fh" 564 INTEGER l_a_offset 565 INTEGER k_a_offset 566 INTEGER size 567 INTEGER length 568 INTEGER addr 569 INTEGER h2b 570 INTEGER h1b 571 length = 0 572 DO h2b = 1,noab 573 DO h1b = 1,noab 574 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 575 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 576 &y,irrep_t)) THEN 577 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 578 &).ne.4)) THEN 579 length = length + 1 580 END IF 581 END IF 582 END IF 583 END DO 584 END DO 585 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 586 &set)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2_1',0,MA_ERR) 587 int_mb(k_a_offset) = length 588 addr = 0 589 size = 0 590 DO h2b = 1,noab 591 DO h1b = 1,noab 592 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 593 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 594 &y,irrep_t)) THEN 595 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 596 &).ne.4)) THEN 597 addr = addr + 1 598 int_mb(k_a_offset+addr) = h1b - 1 + noab * (h2b - 1) 599 int_mb(k_a_offset+length+addr) = size 600 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 601 END IF 602 END IF 603 END IF 604 END DO 605 END DO 606 RETURN 607 END 608 SUBROUTINE ccsd_2pdm_hphh_mo_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c 609 &,k_c_offset) 610C $Id$ 611C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 612C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 613C i1 ( h2 h1 )_yt + = 1/2 * Sum ( h7 p5 p6 ) * t ( p5 p6 h1 h7 )_t * y ( h2 h7 p5 p6 )_y 614 IMPLICIT NONE 615#include "global.fh" 616#include "mafdecls.fh" 617#include "sym.fh" 618#include "errquit.fh" 619#include "tce.fh" 620 INTEGER d_a 621 INTEGER k_a_offset 622 INTEGER d_b 623 INTEGER k_b_offset 624 INTEGER d_c 625 INTEGER k_c_offset 626 INTEGER nxtask 627 INTEGER next 628 INTEGER nprocs 629 INTEGER count 630 INTEGER h2b 631 INTEGER h1b 632 INTEGER dimc 633 INTEGER l_c_sort 634 INTEGER k_c_sort 635 INTEGER p5b 636 INTEGER p6b 637 INTEGER h7b 638 INTEGER p5b_1 639 INTEGER p6b_1 640 INTEGER h1b_1 641 INTEGER h7b_1 642 INTEGER h2b_2 643 INTEGER h7b_2 644 INTEGER p5b_2 645 INTEGER p6b_2 646 INTEGER dim_common 647 INTEGER dima_sort 648 INTEGER dima 649 INTEGER dimb_sort 650 INTEGER dimb 651 INTEGER l_a_sort 652 INTEGER k_a_sort 653 INTEGER l_a 654 INTEGER k_a 655 INTEGER l_b_sort 656 INTEGER k_b_sort 657 INTEGER l_b 658 INTEGER k_b 659 INTEGER nsuperp(2) 660 INTEGER isuperp 661 INTEGER l_c 662 INTEGER k_c 663 DOUBLE PRECISION FACTORIAL 664 EXTERNAL nxtask 665 EXTERNAL FACTORIAL 666 nprocs = GA_NNODES() 667 count = 0 668 next = nxtask(nprocs,1) 669 DO h2b = 1,noab 670 DO h1b = 1,noab 671 IF (next.eq.count) THEN 672 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h1b-1 673 &).ne.4)) THEN 674 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 675 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h1b-1)) .eq. ieor(irrep_ 676 &y,irrep_t)) THEN 677 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h1b-1) 678 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 679 & ERRQUIT('ccsd_2pdm_hphh_mo_2_2',0,MA_ERR) 680 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 681 DO p5b = noab+1,noab+nvab 682 DO p6b = p5b,noab+nvab 683 DO h7b = 1,noab 684 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 685 &1b-1)+int_mb(k_spin+h7b-1)) THEN 686 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 687 &k_sym+h1b-1),int_mb(k_sym+h7b-1)))) .eq. irrep_t) THEN 688 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h7b,p5b_1,p6b_1,h1b_1,h7b_1) 689 CALL TCE_RESTRICTED_4(h2b,h7b,p5b,p6b,h2b_2,h7b_2,p5b_2,p6b_2) 690 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m 691 &b(k_range+h7b-1) 692 dima_sort = int_mb(k_range+h1b-1) 693 dima = dim_common * dima_sort 694 dimb_sort = int_mb(k_range+h2b-1) 695 dimb = dim_common * dimb_sort 696 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 697 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 698 & ERRQUIT('ccsd_2pdm_hphh_mo_2_2',1,MA_ERR) 699 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 700 &ccsd_2pdm_hphh_mo_2_2',2,MA_ERR) 701 IF ((h7b .lt. h1b)) THEN 702 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 703 & - 1 + noab * (h7b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 704 &1 - noab - 1))))) 705 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 706 &,int_mb(k_range+p6b-1),int_mb(k_range+h7b-1),int_mb(k_range+h1b-1) 707 &,4,3,2,1,-1.0d0) 708 END IF 709 IF ((h1b .le. h7b)) THEN 710 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 711 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 712 &1 - noab - 1))))) 713 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 714 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h7b-1) 715 &,3,4,2,1,1.0d0) 716 END IF 717 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2_2',3 718 &,MA_ERR) 719 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 720 & ERRQUIT('ccsd_2pdm_hphh_mo_2_2',4,MA_ERR) 721 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 722 &ccsd_2pdm_hphh_mo_2_2',5,MA_ERR) 723 IF ((h7b .lt. h2b)) THEN 724 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 725 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 726 &* (h7b_2 - 1))))) 727 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 728 &,int_mb(k_range+h2b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 729 &,2,1,4,3,-1.0d0) 730 END IF 731 IF ((h2b .le. h7b)) THEN 732 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 733 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h7b_2 - 1 + noab 734 &* (h2b_2 - 1))))) 735 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 736 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 737 &,1,2,4,3,1.0d0) 738 END IF 739 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2_2',6 740 &,MA_ERR) 741 nsuperp(1) = 1 742 nsuperp(2) = 1 743 isuperp = 1 744 IF (p5b .eq. p6b) THEN 745 nsuperp(isuperp) = nsuperp(isuperp) + 1 746 ELSE 747 isuperp = isuperp + 1 748 END IF 749 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 750 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 751 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 752 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 753 &_2',7,MA_ERR) 754 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 755 &_2',8,MA_ERR) 756 END IF 757 END IF 758 END IF 759 END DO 760 END DO 761 END DO 762 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 763 &ccsd_2pdm_hphh_mo_2_2',9,MA_ERR) 764 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 765 &,int_mb(k_range+h1b-1),1,2,1.0d0/2.0d0) 766 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 767 & 1 + noab * (h2b - 1))) 768 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2_2',1 769 &0,MA_ERR) 770 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_2 771 &_2',11,MA_ERR) 772 END IF 773 END IF 774 END IF 775 next = nxtask(nprocs,1) 776 END IF 777 count = count + 1 778 END DO 779 END DO 780 next = nxtask(-nprocs,1) 781 call GA_SYNC() 782 RETURN 783 END 784 SUBROUTINE ccsd_2pdm_hphh_mo_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k 785 &_c_offset) 786C $Id$ 787C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 788C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 789C i0 ( h1 p3 h2 h4 )_ytt + = 1/4 * P( 2 ) * Sum ( h7 ) * t ( p3 h7 )_t * i1 ( h1 h7 h2 h4 )_yt 790 IMPLICIT NONE 791#include "global.fh" 792#include "mafdecls.fh" 793#include "sym.fh" 794#include "errquit.fh" 795#include "tce.fh" 796 INTEGER d_a 797 INTEGER k_a_offset 798 INTEGER d_b 799 INTEGER k_b_offset 800 INTEGER d_c 801 INTEGER k_c_offset 802 INTEGER nxtask 803 INTEGER next 804 INTEGER nprocs 805 INTEGER count 806 INTEGER p3b 807 INTEGER h1b 808 INTEGER h2b 809 INTEGER h4b 810 INTEGER dimc 811 INTEGER l_c_sort 812 INTEGER k_c_sort 813 INTEGER h7b 814 INTEGER p3b_1 815 INTEGER h7b_1 816 INTEGER h1b_2 817 INTEGER h7b_2 818 INTEGER h2b_2 819 INTEGER h4b_2 820 INTEGER dim_common 821 INTEGER dima_sort 822 INTEGER dima 823 INTEGER dimb_sort 824 INTEGER dimb 825 INTEGER l_a_sort 826 INTEGER k_a_sort 827 INTEGER l_a 828 INTEGER k_a 829 INTEGER l_b_sort 830 INTEGER k_b_sort 831 INTEGER l_b 832 INTEGER k_b 833 INTEGER l_c 834 INTEGER k_c 835 EXTERNAL nxtask 836 nprocs = GA_NNODES() 837 count = 0 838 next = nxtask(nprocs,1) 839 DO h1b = 1,noab 840 DO p3b = noab+1,noab+nvab 841 DO h2b = 1,noab 842 DO h4b = h2b,noab 843 IF (next.eq.count) THEN 844 IF ((.not.restricted).or.(int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1 845 &)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h4b-1).ne.8)) THEN 846 IF (int_mb(k_spin+h1b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 847 &2b-1)+int_mb(k_spin+h4b-1)) THEN 848 IF (ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 849 &k_sym+h2b-1),int_mb(k_sym+h4b-1)))) .eq. ieor(irrep_y,ieor(irrep_t 850 &,irrep_t))) THEN 851 dimc = int_mb(k_range+h1b-1) * int_mb(k_range+p3b-1) * int_mb(k_ra 852 &nge+h2b-1) * int_mb(k_range+h4b-1) 853 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 854 & ERRQUIT('ccsd_2pdm_hphh_mo_3',0,MA_ERR) 855 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 856 DO h7b = 1,noab 857 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h7b-1)) THEN 858 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h7b-1)) .eq. irrep_t) TH 859 &EN 860 CALL TCE_RESTRICTED_2(p3b,h7b,p3b_1,h7b_1) 861 CALL TCE_RESTRICTED_4(h1b,h7b,h2b,h4b,h1b_2,h7b_2,h2b_2,h4b_2) 862 dim_common = int_mb(k_range+h7b-1) 863 dima_sort = int_mb(k_range+p3b-1) 864 dima = dim_common * dima_sort 865 dimb_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_mb 866 &(k_range+h4b-1) 867 dimb = dim_common * dimb_sort 868 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 869 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 870 & ERRQUIT('ccsd_2pdm_hphh_mo_3',1,MA_ERR) 871 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 872 &ccsd_2pdm_hphh_mo_3',2,MA_ERR) 873 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 874 & - 1 + noab * (p3b_1 - noab - 1))) 875 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 876 &,int_mb(k_range+h7b-1),1,2,1.0d0) 877 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3',3,M 878 &A_ERR) 879 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 880 & ERRQUIT('ccsd_2pdm_hphh_mo_3',4,MA_ERR) 881 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 882 &ccsd_2pdm_hphh_mo_3',5,MA_ERR) 883 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h4b_2 884 & - 1 + noab * (h2b_2 - 1 + noab * (h7b_2 - 1 + noab * (h1b_2 - 1)) 885 &))) 886 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h1b-1) 887 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+h4b-1) 888 &,4,3,1,2,1.0d0) 889 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3',6,M 890 &A_ERR) 891 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 892 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 893 &t),dima_sort) 894 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 895 &',7,MA_ERR) 896 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 897 &',8,MA_ERR) 898 END IF 899 END IF 900 END IF 901 END DO 902 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 903 &ccsd_2pdm_hphh_mo_3',9,MA_ERR) 904c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 905c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 906c &,3,4,2,1,1.0d0/4.0d0) 907 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 908 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 909 &,3,4,2,1,-1.0d0/2.0d0) 910 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 911 & 1 + noab * (h2b - 1 + noab * (p3b - noab - 1 + nvab * (h1b - 1))) 912 &)) 913c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 914c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 915c &,4,3,2,1,-1.0d0/4.0d0) 916c CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 917c & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p3b - noab - 1))) 918c &)) 919 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3',10, 920 &MA_ERR) 921 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 922 &',11,MA_ERR) 923 END IF 924 END IF 925 END IF 926 next = nxtask(nprocs,1) 927 END IF 928 count = count + 1 929 END DO 930 END DO 931 END DO 932 END DO 933 next = nxtask(-nprocs,1) 934 call GA_SYNC() 935 RETURN 936 END 937 SUBROUTINE ccsd_2pdm_hphh_mo_3_1(d_a,k_a_offset,d_b,k_b_offset,d_c 938 &,k_c_offset) 939C $Id$ 940C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 941C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 942C i1 ( h4 h7 h1 h2 )_yt + = -1 * Sum ( p5 p6 ) * t ( p5 p6 h1 h2 )_t * y ( h4 h7 p5 p6 )_y 943 IMPLICIT NONE 944#include "global.fh" 945#include "mafdecls.fh" 946#include "sym.fh" 947#include "errquit.fh" 948#include "tce.fh" 949 INTEGER d_a 950 INTEGER k_a_offset 951 INTEGER d_b 952 INTEGER k_b_offset 953 INTEGER d_c 954 INTEGER k_c_offset 955 INTEGER nxtask 956 INTEGER next 957 INTEGER nprocs 958 INTEGER count 959 INTEGER h4b 960 INTEGER h7b 961 INTEGER h1b 962 INTEGER h2b 963 INTEGER dimc 964 INTEGER l_c_sort 965 INTEGER k_c_sort 966 INTEGER p5b 967 INTEGER p6b 968 INTEGER p5b_1 969 INTEGER p6b_1 970 INTEGER h1b_1 971 INTEGER h2b_1 972 INTEGER h4b_2 973 INTEGER h7b_2 974 INTEGER p5b_2 975 INTEGER p6b_2 976 INTEGER dim_common 977 INTEGER dima_sort 978 INTEGER dima 979 INTEGER dimb_sort 980 INTEGER dimb 981 INTEGER l_a_sort 982 INTEGER k_a_sort 983 INTEGER l_a 984 INTEGER k_a 985 INTEGER l_b_sort 986 INTEGER k_b_sort 987 INTEGER l_b 988 INTEGER k_b 989 INTEGER nsuperp(2) 990 INTEGER isuperp 991 INTEGER l_c 992 INTEGER k_c 993 DOUBLE PRECISION FACTORIAL 994 EXTERNAL nxtask 995 EXTERNAL FACTORIAL 996 nprocs = GA_NNODES() 997 count = 0 998 next = nxtask(nprocs,1) 999 DO h4b = 1,noab 1000 DO h7b = 1,noab 1001 DO h1b = 1,noab 1002 DO h2b = h1b,noab 1003 IF (next.eq.count) THEN 1004 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1 1005 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1006 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 1007 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1008 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 1009 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1010 &EN 1011 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 1012 &nge+h1b-1) * int_mb(k_range+h2b-1) 1013 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1014 & ERRQUIT('ccsd_2pdm_hphh_mo_3_1',0,MA_ERR) 1015 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1016 DO p5b = noab+1,noab+nvab 1017 DO p6b = p5b,noab+nvab 1018 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h 1019 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1020 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 1021 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. irrep_t) THEN 1022 CALL TCE_RESTRICTED_4(p5b,p6b,h1b,h2b,p5b_1,p6b_1,h1b_1,h2b_1) 1023 CALL TCE_RESTRICTED_4(h4b,h7b,p5b,p6b,h4b_2,h7b_2,p5b_2,p6b_2) 1024 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) 1025 dima_sort = int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 1026 dima = dim_common * dima_sort 1027 dimb_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h7b-1) 1028 dimb = dim_common * dimb_sort 1029 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1030 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1031 & ERRQUIT('ccsd_2pdm_hphh_mo_3_1',1,MA_ERR) 1032 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1033 &ccsd_2pdm_hphh_mo_3_1',2,MA_ERR) 1034 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h2b_1 1035 & - 1 + noab * (h1b_1 - 1 + noab * (p6b_1 - noab - 1 + nvab * (p5b_ 1036 &1 - noab - 1))))) 1037 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1038 &,int_mb(k_range+p6b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 1039 &,4,3,2,1,1.0d0) 1040 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_1',3 1041 &,MA_ERR) 1042 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1043 & ERRQUIT('ccsd_2pdm_hphh_mo_3_1',4,MA_ERR) 1044 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1045 &ccsd_2pdm_hphh_mo_3_1',5,MA_ERR) 1046 IF ((h7b .lt. h4b)) THEN 1047 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1048 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h4b_2 - 1 + noab 1049 &* (h7b_2 - 1))))) 1050 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 1051 &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 1052 &,1,2,4,3,-1.0d0) 1053 END IF 1054 IF ((h4b .le. h7b)) THEN 1055 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1056 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h7b_2 - 1 + noab 1057 &* (h4b_2 - 1))))) 1058 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 1059 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 1060 &,2,1,4,3,1.0d0) 1061 END IF 1062 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_1',6 1063 &,MA_ERR) 1064 nsuperp(1) = 1 1065 nsuperp(2) = 1 1066 isuperp = 1 1067 IF (p5b .eq. p6b) THEN 1068 nsuperp(isuperp) = nsuperp(isuperp) + 1 1069 ELSE 1070 isuperp = isuperp + 1 1071 END IF 1072 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 1073 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 1074 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 1075 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1076 &_1',7,MA_ERR) 1077 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1078 &_1',8,MA_ERR) 1079 END IF 1080 END IF 1081 END IF 1082 END DO 1083 END DO 1084 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1085 &ccsd_2pdm_hphh_mo_3_1',9,MA_ERR) 1086 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h7b-1) 1087 &,int_mb(k_range+h4b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1088 &,2,1,4,3,-1.0d0) 1089 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h2b - 1090 & 1 + noab * (h1b - 1 + noab * (h7b - 1 + noab * (h4b - 1))))) 1091 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_1',1 1092 &0,MA_ERR) 1093 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1094 &_1',11,MA_ERR) 1095 END IF 1096 END IF 1097 END IF 1098 next = nxtask(nprocs,1) 1099 END IF 1100 count = count + 1 1101 END DO 1102 END DO 1103 END DO 1104 END DO 1105 next = nxtask(-nprocs,1) 1106 call GA_SYNC() 1107 RETURN 1108 END 1109 SUBROUTINE OFFSET_ccsd_2pdm_hphh_mo_3_1(l_a_offset,k_a_offset,size 1110 &) 1111C $Id$ 1112C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1113C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1114C i1 ( h4 h7 h1 h2 )_yt 1115 IMPLICIT NONE 1116#include "global.fh" 1117#include "mafdecls.fh" 1118#include "sym.fh" 1119#include "errquit.fh" 1120#include "tce.fh" 1121 INTEGER l_a_offset 1122 INTEGER k_a_offset 1123 INTEGER size 1124 INTEGER length 1125 INTEGER addr 1126 INTEGER h4b 1127 INTEGER h7b 1128 INTEGER h1b 1129 INTEGER h2b 1130 length = 0 1131 DO h4b = 1,noab 1132 DO h7b = 1,noab 1133 DO h1b = 1,noab 1134 DO h2b = h1b,noab 1135 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 1136 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1137 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 1138 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1139 &EN 1140 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1 1141 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1142 length = length + 1 1143 END IF 1144 END IF 1145 END IF 1146 END DO 1147 END DO 1148 END DO 1149 END DO 1150 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1151 &set)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_1',0,MA_ERR) 1152 int_mb(k_a_offset) = length 1153 addr = 0 1154 size = 0 1155 DO h4b = 1,noab 1156 DO h7b = 1,noab 1157 DO h1b = 1,noab 1158 DO h2b = h1b,noab 1159 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 1160 &1b-1)+int_mb(k_spin+h2b-1)) THEN 1161 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 1162 &k_sym+h1b-1),int_mb(k_sym+h2b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1163 &EN 1164 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1 1165 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1).ne.8)) THEN 1166 addr = addr + 1 1167 int_mb(k_a_offset+addr) = h2b - 1 + noab * (h1b - 1 + noab * (h7b 1168 &- 1 + noab * (h4b - 1))) 1169 int_mb(k_a_offset+length+addr) = size 1170 size = size + int_mb(k_range+h4b-1) * int_mb(k_range+h7b-1) * int_ 1171 &mb(k_range+h1b-1) * int_mb(k_range+h2b-1) 1172 END IF 1173 END IF 1174 END IF 1175 END DO 1176 END DO 1177 END DO 1178 END DO 1179 RETURN 1180 END 1181 SUBROUTINE ccsd_2pdm_hphh_mo_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c 1182 &,k_c_offset) 1183C $Id$ 1184C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1185C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1186C i1 ( h2 h7 h1 h4 )_ytt + = -1 * P( 2 ) * Sum ( p5 ) * t ( p5 h1 )_t * i2 ( h2 h7 h4 p5 )_yt 1187 IMPLICIT NONE 1188#include "global.fh" 1189#include "mafdecls.fh" 1190#include "sym.fh" 1191#include "errquit.fh" 1192#include "tce.fh" 1193 INTEGER d_a 1194 INTEGER k_a_offset 1195 INTEGER d_b 1196 INTEGER k_b_offset 1197 INTEGER d_c 1198 INTEGER k_c_offset 1199 INTEGER nxtask 1200 INTEGER next 1201 INTEGER nprocs 1202 INTEGER count 1203 INTEGER h2b 1204 INTEGER h7b 1205 INTEGER h1b 1206 INTEGER h4b 1207 INTEGER dimc 1208 INTEGER l_c_sort 1209 INTEGER k_c_sort 1210 INTEGER p5b 1211 INTEGER p5b_1 1212 INTEGER h1b_1 1213 INTEGER h2b_2 1214 INTEGER h7b_2 1215 INTEGER h4b_2 1216 INTEGER p5b_2 1217 INTEGER dim_common 1218 INTEGER dima_sort 1219 INTEGER dima 1220 INTEGER dimb_sort 1221 INTEGER dimb 1222 INTEGER l_a_sort 1223 INTEGER k_a_sort 1224 INTEGER l_a 1225 INTEGER k_a 1226 INTEGER l_b_sort 1227 INTEGER k_b_sort 1228 INTEGER l_b 1229 INTEGER k_b 1230 INTEGER l_c 1231 INTEGER k_c 1232 EXTERNAL nxtask 1233 nprocs = GA_NNODES() 1234 count = 0 1235 next = nxtask(nprocs,1) 1236 DO h2b = 1,noab 1237 DO h7b = 1,noab 1238 DO h1b = 1,noab 1239 DO h4b = 1,noab 1240 IF (next.eq.count) THEN 1241 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1 1242 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h4b-1).ne.8)) THEN 1243 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 1244 &1b-1)+int_mb(k_spin+h4b-1)) THEN 1245 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 1246 &k_sym+h1b-1),int_mb(k_sym+h4b-1)))) .eq. ieor(irrep_y,ieor(irrep_t 1247 &,irrep_t))) THEN 1248 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 1249 &nge+h1b-1) * int_mb(k_range+h4b-1) 1250 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1251 & ERRQUIT('ccsd_2pdm_hphh_mo_3_2',0,MA_ERR) 1252 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1253 DO p5b = noab+1,noab+nvab 1254 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1255 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1256 &EN 1257 CALL TCE_RESTRICTED_2(p5b,h1b,p5b_1,h1b_1) 1258 CALL TCE_RESTRICTED_4(h2b,h7b,h4b,p5b,h2b_2,h7b_2,h4b_2,p5b_2) 1259 dim_common = int_mb(k_range+p5b-1) 1260 dima_sort = int_mb(k_range+h1b-1) 1261 dima = dim_common * dima_sort 1262 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h7b-1) * int_mb 1263 &(k_range+h4b-1) 1264 dimb = dim_common * dimb_sort 1265 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1266 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1267 & ERRQUIT('ccsd_2pdm_hphh_mo_3_2',1,MA_ERR) 1268 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1269 &ccsd_2pdm_hphh_mo_3_2',2,MA_ERR) 1270 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1271 & - 1 + noab * (p5b_1 - noab - 1))) 1272 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1273 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1274 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_2',3 1275 &,MA_ERR) 1276 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1277 & ERRQUIT('ccsd_2pdm_hphh_mo_3_2',4,MA_ERR) 1278 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1279 &ccsd_2pdm_hphh_mo_3_2',5,MA_ERR) 1280 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1281 & - noab - 1 + nvab * (h4b_2 - 1 + noab * (h7b_2 - 1 + noab * (h2b_ 1282 &2 - 1))))) 1283 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1284 &,int_mb(k_range+h7b-1),int_mb(k_range+h4b-1),int_mb(k_range+p5b-1) 1285 &,3,2,1,4,1.0d0) 1286 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_2',6 1287 &,MA_ERR) 1288 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1289 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1290 &t),dima_sort) 1291 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1292 &_2',7,MA_ERR) 1293 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1294 &_2',8,MA_ERR) 1295 END IF 1296 END IF 1297 END IF 1298 END DO 1299 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1300 &ccsd_2pdm_hphh_mo_3_2',9,MA_ERR) 1301 IF ((h1b .le. h4b)) THEN 1302 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1303 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1304 &,3,2,4,1,-1.0d0) 1305 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1306 & 1 + noab * (h1b - 1 + noab * (h7b - 1 + noab * (h2b - 1))))) 1307 END IF 1308 IF ((h4b .le. h1b)) THEN 1309 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1310 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1311 &,3,2,1,4,1.0d0) 1312 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1313 & 1 + noab * (h4b - 1 + noab * (h7b - 1 + noab * (h2b - 1))))) 1314 END IF 1315 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_2',1 1316 &0,MA_ERR) 1317 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1318 &_2',11,MA_ERR) 1319 END IF 1320 END IF 1321 END IF 1322 next = nxtask(nprocs,1) 1323 END IF 1324 count = count + 1 1325 END DO 1326 END DO 1327 END DO 1328 END DO 1329 next = nxtask(-nprocs,1) 1330 call GA_SYNC() 1331 RETURN 1332 END 1333 SUBROUTINE ccsd_2pdm_hphh_mo_3_2_1(d_a,k_a_offset,d_b,k_b_offset,d 1334 &_c,k_c_offset) 1335C $Id$ 1336C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1337C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1338C i2 ( h2 h7 h1 p5 )_yt + = 1 * Sum ( p6 ) * t ( p6 h1 )_t * y ( h2 h7 p5 p6 )_y 1339 IMPLICIT NONE 1340#include "global.fh" 1341#include "mafdecls.fh" 1342#include "sym.fh" 1343#include "errquit.fh" 1344#include "tce.fh" 1345 INTEGER d_a 1346 INTEGER k_a_offset 1347 INTEGER d_b 1348 INTEGER k_b_offset 1349 INTEGER d_c 1350 INTEGER k_c_offset 1351 INTEGER nxtask 1352 INTEGER next 1353 INTEGER nprocs 1354 INTEGER count 1355 INTEGER h2b 1356 INTEGER h7b 1357 INTEGER h1b 1358 INTEGER p5b 1359 INTEGER dimc 1360 INTEGER l_c_sort 1361 INTEGER k_c_sort 1362 INTEGER p6b 1363 INTEGER p6b_1 1364 INTEGER h1b_1 1365 INTEGER h2b_2 1366 INTEGER h7b_2 1367 INTEGER p5b_2 1368 INTEGER p6b_2 1369 INTEGER dim_common 1370 INTEGER dima_sort 1371 INTEGER dima 1372 INTEGER dimb_sort 1373 INTEGER dimb 1374 INTEGER l_a_sort 1375 INTEGER k_a_sort 1376 INTEGER l_a 1377 INTEGER k_a 1378 INTEGER l_b_sort 1379 INTEGER k_b_sort 1380 INTEGER l_b 1381 INTEGER k_b 1382 INTEGER l_c 1383 INTEGER k_c 1384 EXTERNAL nxtask 1385 nprocs = GA_NNODES() 1386 count = 0 1387 next = nxtask(nprocs,1) 1388 DO h2b = 1,noab 1389 DO h7b = 1,noab 1390 DO h1b = 1,noab 1391 DO p5b = noab+1,noab+nvab 1392 IF (next.eq.count) THEN 1393 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1 1394 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1395 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 1396 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1397 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 1398 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1399 &EN 1400 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 1401 &nge+h1b-1) * int_mb(k_range+p5b-1) 1402 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1403 & ERRQUIT('ccsd_2pdm_hphh_mo_3_2_1',0,MA_ERR) 1404 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1405 DO p6b = noab+1,noab+nvab 1406 IF (int_mb(k_spin+p6b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1407 IF (ieor(int_mb(k_sym+p6b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1408 &EN 1409 CALL TCE_RESTRICTED_2(p6b,h1b,p6b_1,h1b_1) 1410 CALL TCE_RESTRICTED_4(h2b,h7b,p5b,p6b,h2b_2,h7b_2,p5b_2,p6b_2) 1411 dim_common = int_mb(k_range+p6b-1) 1412 dima_sort = int_mb(k_range+h1b-1) 1413 dima = dim_common * dima_sort 1414 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h7b-1) * int_mb 1415 &(k_range+p5b-1) 1416 dimb = dim_common * dimb_sort 1417 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1418 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1419 & ERRQUIT('ccsd_2pdm_hphh_mo_3_2_1',1,MA_ERR) 1420 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1421 &ccsd_2pdm_hphh_mo_3_2_1',2,MA_ERR) 1422 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1423 & - 1 + noab * (p6b_1 - noab - 1))) 1424 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p6b-1) 1425 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1426 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_2_1' 1427 &,3,MA_ERR) 1428 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1429 & ERRQUIT('ccsd_2pdm_hphh_mo_3_2_1',4,MA_ERR) 1430 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1431 &ccsd_2pdm_hphh_mo_3_2_1',5,MA_ERR) 1432 IF ((h7b .lt. h2b) .and. (p6b .lt. p5b)) THEN 1433 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1434 & - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 1435 &* (h7b_2 - 1))))) 1436 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 1437 &,int_mb(k_range+h2b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 1438 &,4,1,2,3,1.0d0) 1439 END IF 1440 IF ((h7b .lt. h2b) .and. (p5b .le. p6b)) THEN 1441 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1442 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 1443 &* (h7b_2 - 1))))) 1444 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 1445 &,int_mb(k_range+h2b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 1446 &,3,1,2,4,-1.0d0) 1447 END IF 1448 IF ((h2b .le. h7b) .and. (p6b .lt. p5b)) THEN 1449 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1450 & - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (h7b_2 - 1 + noab 1451 &* (h2b_2 - 1))))) 1452 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1453 &,int_mb(k_range+h7b-1),int_mb(k_range+p6b-1),int_mb(k_range+p5b-1) 1454 &,4,2,1,3,-1.0d0) 1455 END IF 1456 IF ((h2b .le. h7b) .and. (p5b .le. p6b)) THEN 1457 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 1458 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h7b_2 - 1 + noab 1459 &* (h2b_2 - 1))))) 1460 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1461 &,int_mb(k_range+h7b-1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1) 1462 &,3,2,1,4,1.0d0) 1463 END IF 1464 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_2_1' 1465 &,6,MA_ERR) 1466 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1467 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1468 &t),dima_sort) 1469 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1470 &_2_1',7,MA_ERR) 1471 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1472 &_2_1',8,MA_ERR) 1473 END IF 1474 END IF 1475 END IF 1476 END DO 1477 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1478 &ccsd_2pdm_hphh_mo_3_2_1',9,MA_ERR) 1479 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 1480 &,int_mb(k_range+h7b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1481 &,3,2,4,1,1.0d0) 1482 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 1483 & noab - 1 + nvab * (h1b - 1 + noab * (h7b - 1 + noab * (h2b - 1))) 1484 &)) 1485 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_2_1' 1486 &,10,MA_ERR) 1487 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3 1488 &_2_1',11,MA_ERR) 1489 END IF 1490 END IF 1491 END IF 1492 next = nxtask(nprocs,1) 1493 END IF 1494 count = count + 1 1495 END DO 1496 END DO 1497 END DO 1498 END DO 1499 next = nxtask(-nprocs,1) 1500 call GA_SYNC() 1501 RETURN 1502 END 1503 SUBROUTINE OFFSET_ccsd_2pdm_hphh_mo_3_2_1(l_a_offset,k_a_offset,si 1504 &ze) 1505C $Id$ 1506C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1507C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1508C i2 ( h2 h7 h1 p5 )_yt 1509 IMPLICIT NONE 1510#include "global.fh" 1511#include "mafdecls.fh" 1512#include "sym.fh" 1513#include "errquit.fh" 1514#include "tce.fh" 1515 INTEGER l_a_offset 1516 INTEGER k_a_offset 1517 INTEGER size 1518 INTEGER length 1519 INTEGER addr 1520 INTEGER h2b 1521 INTEGER h7b 1522 INTEGER h1b 1523 INTEGER p5b 1524 length = 0 1525 DO h2b = 1,noab 1526 DO h7b = 1,noab 1527 DO h1b = 1,noab 1528 DO p5b = noab+1,noab+nvab 1529 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 1530 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1531 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 1532 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1533 &EN 1534 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1 1535 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1536 length = length + 1 1537 END IF 1538 END IF 1539 END IF 1540 END DO 1541 END DO 1542 END DO 1543 END DO 1544 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1545 &set)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_3_2_1',0,MA_ERR) 1546 int_mb(k_a_offset) = length 1547 addr = 0 1548 size = 0 1549 DO h2b = 1,noab 1550 DO h7b = 1,noab 1551 DO h1b = 1,noab 1552 DO p5b = noab+1,noab+nvab 1553 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+h 1554 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1555 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 1556 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1557 &EN 1558 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h7b-1 1559 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1560 addr = addr + 1 1561 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 1562 &* (h7b - 1 + noab * (h2b - 1))) 1563 int_mb(k_a_offset+length+addr) = size 1564 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+h7b-1) * int_ 1565 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 1566 END IF 1567 END IF 1568 END IF 1569 END DO 1570 END DO 1571 END DO 1572 END DO 1573 RETURN 1574 END 1575 SUBROUTINE ccsd_2pdm_hphh_mo_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k 1576 &_c_offset) 1577C $Id$ 1578C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1579C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1580C i0 ( h2 p3 h1 h4 )_ytt + = 1/2 * P( 4 ) * Sum ( h6 p5 ) * t ( p3 p5 h1 h6 )_t * i1 ( h2 h6 h4 p5 )_yt 1581 IMPLICIT NONE 1582#include "global.fh" 1583#include "mafdecls.fh" 1584#include "sym.fh" 1585#include "errquit.fh" 1586#include "tce.fh" 1587 INTEGER d_a 1588 INTEGER k_a_offset 1589 INTEGER d_b 1590 INTEGER k_b_offset 1591 INTEGER d_c 1592 INTEGER k_c_offset 1593 INTEGER nxtask 1594 INTEGER next 1595 INTEGER nprocs 1596 INTEGER count 1597 INTEGER p3b 1598 INTEGER h2b 1599 INTEGER h1b 1600 INTEGER h4b 1601 INTEGER dimc 1602 INTEGER l_c_sort 1603 INTEGER k_c_sort 1604 INTEGER p5b 1605 INTEGER h6b 1606 INTEGER p3b_1 1607 INTEGER p5b_1 1608 INTEGER h1b_1 1609 INTEGER h6b_1 1610 INTEGER h2b_2 1611 INTEGER h6b_2 1612 INTEGER h4b_2 1613 INTEGER p5b_2 1614 INTEGER dim_common 1615 INTEGER dima_sort 1616 INTEGER dima 1617 INTEGER dimb_sort 1618 INTEGER dimb 1619 INTEGER l_a_sort 1620 INTEGER k_a_sort 1621 INTEGER l_a 1622 INTEGER k_a 1623 INTEGER l_b_sort 1624 INTEGER k_b_sort 1625 INTEGER l_b 1626 INTEGER k_b 1627 INTEGER l_c 1628 INTEGER k_c 1629 EXTERNAL nxtask 1630 nprocs = GA_NNODES() 1631 count = 0 1632 next = nxtask(nprocs,1) 1633 DO h2b = 1,noab 1634 DO p3b = noab+1,noab+nvab 1635 DO h1b = 1,noab 1636 DO h4b = 1,noab 1637 IF (next.eq.count) THEN 1638 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p3b-1 1639 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h4b-1).ne.8)) THEN 1640 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h 1641 &1b-1)+int_mb(k_spin+h4b-1)) THEN 1642 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb( 1643 &k_sym+h1b-1),int_mb(k_sym+h4b-1)))) .eq. ieor(irrep_y,ieor(irrep_t 1644 &,irrep_t))) THEN 1645 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p3b-1) * int_mb(k_ra 1646 &nge+h1b-1) * int_mb(k_range+h4b-1) 1647 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1648 & ERRQUIT('ccsd_2pdm_hphh_mo_4',0,MA_ERR) 1649 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1650 DO p5b = noab+1,noab+nvab 1651 DO h6b = 1,noab 1652 IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 1653 &1b-1)+int_mb(k_spin+h6b-1)) THEN 1654 IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 1655 &k_sym+h1b-1),int_mb(k_sym+h6b-1)))) .eq. irrep_t) THEN 1656 CALL TCE_RESTRICTED_4(p3b,p5b,h1b,h6b,p3b_1,p5b_1,h1b_1,h6b_1) 1657 CALL TCE_RESTRICTED_4(h2b,h6b,h4b,p5b,h2b_2,h6b_2,h4b_2,p5b_2) 1658 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h6b-1) 1659 dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) 1660 dima = dim_common * dima_sort 1661 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h4b-1) 1662 dimb = dim_common * dimb_sort 1663 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1664 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1665 & ERRQUIT('ccsd_2pdm_hphh_mo_4',1,MA_ERR) 1666 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1667 &ccsd_2pdm_hphh_mo_4',2,MA_ERR) 1668 IF ((p5b .lt. p3b) .and. (h6b .lt. h1b)) THEN 1669 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1670 & - 1 + noab * (h6b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 1671 &1 - noab - 1))))) 1672 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1673 &,int_mb(k_range+p3b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 1674 &,4,2,3,1,1.0d0) 1675 END IF 1676 IF ((p5b .lt. p3b) .and. (h1b .le. h6b)) THEN 1677 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 1678 & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p5b_ 1679 &1 - noab - 1))))) 1680 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 1681 &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 1682 &,3,2,4,1,-1.0d0) 1683 END IF 1684 IF ((p3b .le. p5b) .and. (h6b .lt. h1b)) THEN 1685 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1686 & - 1 + noab * (h6b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 1687 &1 - noab - 1))))) 1688 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1689 &,int_mb(k_range+p5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h1b-1) 1690 &,4,1,3,2,-1.0d0) 1691 END IF 1692 IF ((p3b .le. p5b) .and. (h1b .le. h6b)) THEN 1693 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 1694 & - 1 + noab * (h1b_1 - 1 + noab * (p5b_1 - noab - 1 + nvab * (p3b_ 1695 &1 - noab - 1))))) 1696 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 1697 &,int_mb(k_range+p5b-1),int_mb(k_range+h1b-1),int_mb(k_range+h6b-1) 1698 &,3,1,4,2,1.0d0) 1699 END IF 1700 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4',3,M 1701 &A_ERR) 1702 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1703 & ERRQUIT('ccsd_2pdm_hphh_mo_4',4,MA_ERR) 1704 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1705 &ccsd_2pdm_hphh_mo_4',5,MA_ERR) 1706 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1707 & - noab - 1 + nvab * (h4b_2 - 1 + noab * (h6b_2 - 1 + noab * (h2b_ 1708 &2 - 1))))) 1709 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1710 &,int_mb(k_range+h6b-1),int_mb(k_range+h4b-1),int_mb(k_range+p5b-1) 1711 &,3,1,2,4,1.0d0) 1712 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4',6,M 1713 &A_ERR) 1714 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1715 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1716 &t),dima_sort) 1717 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4 1718 &',7,MA_ERR) 1719 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4 1720 &',8,MA_ERR) 1721 END IF 1722 END IF 1723 END IF 1724 END DO 1725 END DO 1726 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1727 &ccsd_2pdm_hphh_mo_4',9,MA_ERR) 1728 IF ((h1b .le. h4b)) THEN 1729c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1730c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1731c &,2,4,3,1,1.0d0/2.0d0) 1732 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1733 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1734 &,2,4,3,1,-1.0d0) 1735 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1736 & 1 + noab * (h1b - 1 + noab * (p3b - noab - 1 + nvab * (h2b - 1))) 1737 &)) 1738 END IF 1739 IF ((h4b .le. h1b)) THEN 1740c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1741c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1742c &,2,4,1,3,-1.0d0/2.0d0) 1743 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1744 &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1745 &,2,4,1,3,1.0d0) 1746 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1747 & 1 + noab * (h4b - 1 + noab * (p3b - noab - 1 + nvab * (h2b - 1))) 1748 &)) 1749 END IF 1750c IF ((h1b .le. h4b)) THEN 1751c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1752c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1753c &,4,2,3,1,-1.0d0/2.0d0) 1754c CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h4b - 1755c & 1 + noab * (h1b - 1 + noab * (h2b - 1 + noab * (p3b - noab - 1))) 1756c &)) 1757c END IF 1758c IF ((h4b .le. h1b)) THEN 1759c CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h4b-1) 1760c &,int_mb(k_range+h2b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) 1761c &,4,2,1,3,1.0d0/2.0d0) 1762c CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 1763c & 1 + noab * (h4b - 1 + noab * (h2b - 1 + noab * (p3b - noab - 1))) 1764c &)) 1765c END IF 1766 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4',10, 1767 &MA_ERR) 1768 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4 1769 &',11,MA_ERR) 1770 END IF 1771 END IF 1772 END IF 1773 next = nxtask(nprocs,1) 1774 END IF 1775 count = count + 1 1776 END DO 1777 END DO 1778 END DO 1779 END DO 1780 next = nxtask(-nprocs,1) 1781 call GA_SYNC() 1782 RETURN 1783 END 1784 SUBROUTINE ccsd_2pdm_hphh_mo_4_1(d_a,k_a_offset,d_b,k_b_offset,d_c 1785 &,k_c_offset) 1786C $Id$ 1787C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1788C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1789C i1 ( h2 h6 h1 p5 )_yt + = 1 * Sum ( p7 ) * t ( p7 h1 )_t * y ( h2 h6 p5 p7 )_y 1790 IMPLICIT NONE 1791#include "global.fh" 1792#include "mafdecls.fh" 1793#include "sym.fh" 1794#include "errquit.fh" 1795#include "tce.fh" 1796 INTEGER d_a 1797 INTEGER k_a_offset 1798 INTEGER d_b 1799 INTEGER k_b_offset 1800 INTEGER d_c 1801 INTEGER k_c_offset 1802 INTEGER nxtask 1803 INTEGER next 1804 INTEGER nprocs 1805 INTEGER count 1806 INTEGER h2b 1807 INTEGER h6b 1808 INTEGER h1b 1809 INTEGER p5b 1810 INTEGER dimc 1811 INTEGER l_c_sort 1812 INTEGER k_c_sort 1813 INTEGER p7b 1814 INTEGER p7b_1 1815 INTEGER h1b_1 1816 INTEGER h2b_2 1817 INTEGER h6b_2 1818 INTEGER p5b_2 1819 INTEGER p7b_2 1820 INTEGER dim_common 1821 INTEGER dima_sort 1822 INTEGER dima 1823 INTEGER dimb_sort 1824 INTEGER dimb 1825 INTEGER l_a_sort 1826 INTEGER k_a_sort 1827 INTEGER l_a 1828 INTEGER k_a 1829 INTEGER l_b_sort 1830 INTEGER k_b_sort 1831 INTEGER l_b 1832 INTEGER k_b 1833 INTEGER l_c 1834 INTEGER k_c 1835 EXTERNAL nxtask 1836 nprocs = GA_NNODES() 1837 count = 0 1838 next = nxtask(nprocs,1) 1839 DO h2b = 1,noab 1840 DO h6b = 1,noab 1841 DO h1b = 1,noab 1842 DO p5b = noab+1,noab+nvab 1843 IF (next.eq.count) THEN 1844 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h6b-1 1845 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1846 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 1847 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1848 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 1849 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1850 &EN 1851 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 1852 &nge+h1b-1) * int_mb(k_range+p5b-1) 1853 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1854 & ERRQUIT('ccsd_2pdm_hphh_mo_4_1',0,MA_ERR) 1855 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1856 DO p7b = noab+1,noab+nvab 1857 IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN 1858 IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH 1859 &EN 1860 CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1) 1861 CALL TCE_RESTRICTED_4(h2b,h6b,p5b,p7b,h2b_2,h6b_2,p5b_2,p7b_2) 1862 dim_common = int_mb(k_range+p7b-1) 1863 dima_sort = int_mb(k_range+h1b-1) 1864 dima = dim_common * dima_sort 1865 dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h6b-1) * int_mb 1866 &(k_range+p5b-1) 1867 dimb = dim_common * dimb_sort 1868 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1869 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1870 & ERRQUIT('ccsd_2pdm_hphh_mo_4_1',1,MA_ERR) 1871 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1872 &ccsd_2pdm_hphh_mo_4_1',2,MA_ERR) 1873 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 1874 & - 1 + noab * (p7b_1 - noab - 1))) 1875 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1) 1876 &,int_mb(k_range+h1b-1),2,1,1.0d0) 1877 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4_1',3 1878 &,MA_ERR) 1879 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1880 & ERRQUIT('ccsd_2pdm_hphh_mo_4_1',4,MA_ERR) 1881 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1882 &ccsd_2pdm_hphh_mo_4_1',5,MA_ERR) 1883 IF ((h6b .lt. h2b) .and. (p7b .lt. p5b)) THEN 1884 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1885 & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 1886 &* (h6b_2 - 1))))) 1887 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 1888 &,int_mb(k_range+h2b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) 1889 &,4,1,2,3,1.0d0) 1890 END IF 1891 IF ((h6b .lt. h2b) .and. (p5b .le. p7b)) THEN 1892 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 1893 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab 1894 &* (h6b_2 - 1))))) 1895 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 1896 &,int_mb(k_range+h2b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) 1897 &,3,1,2,4,-1.0d0) 1898 END IF 1899 IF ((h2b .le. h6b) .and. (p7b .lt. p5b)) THEN 1900 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 1901 & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 1902 &* (h2b_2 - 1))))) 1903 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1904 &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) 1905 &,4,2,1,3,-1.0d0) 1906 END IF 1907 IF ((h2b .le. h6b) .and. (p5b .le. p7b)) THEN 1908 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 1909 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab 1910 &* (h2b_2 - 1))))) 1911 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 1912 &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) 1913 &,3,2,1,4,1.0d0) 1914 END IF 1915 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4_1',6 1916 &,MA_ERR) 1917 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1918 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1919 &t),dima_sort) 1920 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4 1921 &_1',7,MA_ERR) 1922 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4 1923 &_1',8,MA_ERR) 1924 END IF 1925 END IF 1926 END IF 1927 END DO 1928 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1929 &ccsd_2pdm_hphh_mo_4_1',9,MA_ERR) 1930 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 1931 &,int_mb(k_range+h6b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 1932 &,3,2,4,1,1.0d0) 1933 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 1934 & noab - 1 + nvab * (h1b - 1 + noab * (h6b - 1 + noab * (h2b - 1))) 1935 &)) 1936 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4_1',1 1937 &0,MA_ERR) 1938 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4 1939 &_1',11,MA_ERR) 1940 END IF 1941 END IF 1942 END IF 1943 next = nxtask(nprocs,1) 1944 END IF 1945 count = count + 1 1946 END DO 1947 END DO 1948 END DO 1949 END DO 1950 next = nxtask(-nprocs,1) 1951 call GA_SYNC() 1952 RETURN 1953 END 1954 SUBROUTINE OFFSET_ccsd_2pdm_hphh_mo_4_1(l_a_offset,k_a_offset,size 1955 &) 1956C $Id$ 1957C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1958C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1959C i1 ( h2 h6 h1 p5 )_yt 1960 IMPLICIT NONE 1961#include "global.fh" 1962#include "mafdecls.fh" 1963#include "sym.fh" 1964#include "errquit.fh" 1965#include "tce.fh" 1966 INTEGER l_a_offset 1967 INTEGER k_a_offset 1968 INTEGER size 1969 INTEGER length 1970 INTEGER addr 1971 INTEGER h2b 1972 INTEGER h6b 1973 INTEGER h1b 1974 INTEGER p5b 1975 length = 0 1976 DO h2b = 1,noab 1977 DO h6b = 1,noab 1978 DO h1b = 1,noab 1979 DO p5b = noab+1,noab+nvab 1980 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 1981 &1b-1)+int_mb(k_spin+p5b-1)) THEN 1982 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 1983 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 1984 &EN 1985 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h6b-1 1986 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 1987 length = length + 1 1988 END IF 1989 END IF 1990 END IF 1991 END DO 1992 END DO 1993 END DO 1994 END DO 1995 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1996 &set)) CALL ERRQUIT('ccsd_2pdm_hphh_mo_4_1',0,MA_ERR) 1997 int_mb(k_a_offset) = length 1998 addr = 0 1999 size = 0 2000 DO h2b = 1,noab 2001 DO h6b = 1,noab 2002 DO h1b = 1,noab 2003 DO p5b = noab+1,noab+nvab 2004 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 2005 &1b-1)+int_mb(k_spin+p5b-1)) THEN 2006 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 2007 &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_y,irrep_t)) TH 2008 &EN 2009 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h6b-1 2010 &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 2011 addr = addr + 1 2012 int_mb(k_a_offset+addr) = p5b - noab - 1 + nvab * (h1b - 1 + noab 2013 &* (h6b - 1 + noab * (h2b - 1))) 2014 int_mb(k_a_offset+length+addr) = size 2015 size = size + int_mb(k_range+h2b-1) * int_mb(k_range+h6b-1) * int_ 2016 &mb(k_range+h1b-1) * int_mb(k_range+p5b-1) 2017 END IF 2018 END IF 2019 END IF 2020 END DO 2021 END DO 2022 END DO 2023 END DO 2024 RETURN 2025 END 2026