1 SUBROUTINE ccsdt_lr_beta_4_4_13_4_1(d_a,k_a_offset,d_b,k_b_offset, 2 &d_c,k_c_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 i3 ( h7 h10 h12 p5 )_ytra + = -1 * Sum ( h3 p1 p2 ) * tra ( p1 p2 h3 h12 )_tra * y ( h3 h7 h10 p1 p2 p5 )_y 7 IMPLICIT NONE 8#include "global.fh" 9#include "mafdecls.fh" 10#include "sym.fh" 11#include "errquit.fh" 12#include "tce.fh" 13 INTEGER d_a 14 INTEGER k_a_offset 15 INTEGER d_b 16 INTEGER k_b_offset 17 INTEGER d_c 18 INTEGER k_c_offset 19 INTEGER nxtask 20 INTEGER next 21 INTEGER nprocs 22 INTEGER count 23 INTEGER h7b 24 INTEGER h10b 25 INTEGER h12b 26 INTEGER p5b 27 INTEGER dimc 28 INTEGER l_c_sort 29 INTEGER k_c_sort 30 INTEGER p1b 31 INTEGER p2b 32 INTEGER h3b 33 INTEGER p1b_1 34 INTEGER p2b_1 35 INTEGER h12b_1 36 INTEGER h3b_1 37 INTEGER h7b_2 38 INTEGER h10b_2 39 INTEGER h3b_2 40 INTEGER p5b_2 41 INTEGER p1b_2 42 INTEGER p2b_2 43 INTEGER dim_common 44 INTEGER dima_sort 45 INTEGER dima 46 INTEGER dimb_sort 47 INTEGER dimb 48 INTEGER l_a_sort 49 INTEGER k_a_sort 50 INTEGER l_a 51 INTEGER k_a 52 INTEGER l_b_sort 53 INTEGER k_b_sort 54 INTEGER l_b 55 INTEGER k_b 56 INTEGER nsuperp(2) 57 INTEGER isuperp 58 INTEGER l_c 59 INTEGER k_c 60 DOUBLE PRECISION FACTORIAL 61 EXTERNAL nxtask 62 EXTERNAL FACTORIAL 63 nprocs = GA_NNODES() 64 count = 0 65 next = nxtask(nprocs,1) 66 DO h7b = 1,noab 67 DO h10b = h7b,noab 68 DO h12b = 1,noab 69 DO p5b = noab+1,noab+nvab 70 IF (next.eq.count) THEN 71 IF ((.not.restricted).or.(int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b- 72 &1)+int_mb(k_spin+h12b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN 73 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h10b-1) .eq. int_mb(k_spin+ 74 &h12b-1)+int_mb(k_spin+p5b-1)) THEN 75 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 76 &(k_sym+h12b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_y,irrep_tra) 77 &) THEN 78 dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 79 &ange+h12b-1) * int_mb(k_range+p5b-1) 80 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 81 & ERRQUIT('ccsdt_lr_beta_4_4_13_4_1',0,MA_ERR) 82 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 83 DO p1b = noab+1,noab+nvab 84 DO p2b = p1b,noab+nvab 85 DO h3b = 1,noab 86 IF (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h 87 &12b-1)+int_mb(k_spin+h3b-1)) THEN 88 IF (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),ieor(int_mb( 89 &k_sym+h12b-1),int_mb(k_sym+h3b-1)))) .eq. irrep_tra) THEN 90 CALL TCE_RESTRICTED_4(p1b,p2b,h12b,h3b,p1b_1,p2b_1,h12b_1,h3b_1) 91 CALL TCE_RESTRICTED_6(h7b,h10b,h3b,p5b,p1b,p2b,h7b_2,h10b_2,h3b_2, 92 &p5b_2,p1b_2,p2b_2) 93 dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m 94 &b(k_range+h3b-1) 95 dima_sort = int_mb(k_range+h12b-1) 96 dima = dim_common * dima_sort 97 dimb_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h10b-1) * int_m 98 &b(k_range+p5b-1) 99 dimb = dim_common * dimb_sort 100 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 101 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 102 & ERRQUIT('ccsdt_lr_beta_4_4_13_4_1',1,MA_ERR) 103 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 104 &ccsdt_lr_beta_4_4_13_4_1',2,MA_ERR) 105 IF ((h3b .le. h12b)) THEN 106 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 107 &1 - 1 + noab * (h3b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p1b 108 &_1 - noab - 1))))) 109 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 110 &,int_mb(k_range+p2b-1),int_mb(k_range+h3b-1),int_mb(k_range+h12b-1 111 &),4,3,2,1,1.0d0) 112 END IF 113 IF ((h12b .lt. h3b)) THEN 114 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 115 & - 1 + noab * (h12b_1 - 1 + noab * (p2b_1 - noab - 1 + nvab * (p1b 116 &_1 - noab - 1))))) 117 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 118 &,int_mb(k_range+p2b-1),int_mb(k_range+h12b-1),int_mb(k_range+h3b-1 119 &),3,4,2,1,-1.0d0) 120 END IF 121 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_lr_beta_4_4_13_4_1 122 &',3,MA_ERR) 123 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 124 & ERRQUIT('ccsdt_lr_beta_4_4_13_4_1',4,MA_ERR) 125 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 126 &ccsdt_lr_beta_4_4_13_4_1',5,MA_ERR) 127 IF ((h3b .le. h7b) .and. (p2b .le. p5b)) THEN 128 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 129 & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 130 &+ nvab * (h10b_2 - 1 + noab * (h7b_2 - 1 + noab * (h3b_2 - 1)))))) 131 &) 132 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 133 &,int_mb(k_range+h7b-1),int_mb(k_range+h10b-1),int_mb(k_range+p1b-1 134 &),int_mb(k_range+p2b-1),int_mb(k_range+p5b-1),6,3,2,1,5,4,1.0d0) 135 END IF 136 IF ((h3b .le. h7b) .and. (p1b .le. p5b) .and. (p5b .lt. p2b)) THEN 137 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 138 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 139 &+ nvab * (h10b_2 - 1 + noab * (h7b_2 - 1 + noab * (h3b_2 - 1)))))) 140 &) 141 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 142 &,int_mb(k_range+h7b-1),int_mb(k_range+h10b-1),int_mb(k_range+p1b-1 143 &),int_mb(k_range+p5b-1),int_mb(k_range+p2b-1),5,3,2,1,6,4,-1.0d0) 144 END IF 145 IF ((h3b .le. h7b) .and. (p5b .lt. p1b)) THEN 146 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 147 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 148 &+ nvab * (h10b_2 - 1 + noab * (h7b_2 - 1 + noab * (h3b_2 - 1)))))) 149 &) 150 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 151 &,int_mb(k_range+h7b-1),int_mb(k_range+h10b-1),int_mb(k_range+p5b-1 152 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),4,3,2,1,6,5,1.0d0) 153 END IF 154 IF ((h7b .lt. h3b) .and. (h3b .le. h10b) .and. (p2b .le. p5b)) THE 155 &N 156 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 157 & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 158 &+ nvab * (h10b_2 - 1 + noab * (h3b_2 - 1 + noab * (h7b_2 - 1)))))) 159 &) 160 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 161 &,int_mb(k_range+h3b-1),int_mb(k_range+h10b-1),int_mb(k_range+p1b-1 162 &),int_mb(k_range+p2b-1),int_mb(k_range+p5b-1),6,3,1,2,5,4,-1.0d0) 163 END IF 164 IF ((h7b .lt. h3b) .and. (h3b .le. h10b) .and. (p1b .le. p5b) .and 165 &. (p5b .lt. p2b)) THEN 166 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 167 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 168 &+ nvab * (h10b_2 - 1 + noab * (h3b_2 - 1 + noab * (h7b_2 - 1)))))) 169 &) 170 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 171 &,int_mb(k_range+h3b-1),int_mb(k_range+h10b-1),int_mb(k_range+p1b-1 172 &),int_mb(k_range+p5b-1),int_mb(k_range+p2b-1),5,3,1,2,6,4,1.0d0) 173 END IF 174 IF ((h7b .lt. h3b) .and. (h3b .le. h10b) .and. (p5b .lt. p1b)) THE 175 &N 176 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 177 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 178 &+ nvab * (h10b_2 - 1 + noab * (h3b_2 - 1 + noab * (h7b_2 - 1)))))) 179 &) 180 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 181 &,int_mb(k_range+h3b-1),int_mb(k_range+h10b-1),int_mb(k_range+p5b-1 182 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),4,3,1,2,6,5,-1.0d0) 183 END IF 184 IF ((h10b .lt. h3b) .and. (p2b .le. p5b)) THEN 185 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 186 & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 187 &+ nvab * (h3b_2 - 1 + noab * (h10b_2 - 1 + noab * (h7b_2 - 1)))))) 188 &) 189 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 190 &,int_mb(k_range+h10b-1),int_mb(k_range+h3b-1),int_mb(k_range+p1b-1 191 &),int_mb(k_range+p2b-1),int_mb(k_range+p5b-1),6,2,1,3,5,4,1.0d0) 192 END IF 193 IF ((h10b .lt. h3b) .and. (p1b .le. p5b) .and. (p5b .lt. p2b)) THE 194 &N 195 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 196 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 197 &+ nvab * (h3b_2 - 1 + noab * (h10b_2 - 1 + noab * (h7b_2 - 1)))))) 198 &) 199 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 200 &,int_mb(k_range+h10b-1),int_mb(k_range+h3b-1),int_mb(k_range+p1b-1 201 &),int_mb(k_range+p5b-1),int_mb(k_range+p2b-1),5,2,1,3,6,4,-1.0d0) 202 END IF 203 IF ((h10b .lt. h3b) .and. (p5b .lt. p1b)) THEN 204 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 205 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 206 &+ nvab * (h3b_2 - 1 + noab * (h10b_2 - 1 + noab * (h7b_2 - 1)))))) 207 &) 208 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 209 &,int_mb(k_range+h10b-1),int_mb(k_range+h3b-1),int_mb(k_range+p5b-1 210 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),4,2,1,3,6,5,1.0d0) 211 END IF 212 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_lr_beta_4_4_13_4_1 213 &',6,MA_ERR) 214 nsuperp(1) = 1 215 nsuperp(2) = 1 216 isuperp = 1 217 IF (p1b .eq. p2b) THEN 218 nsuperp(isuperp) = nsuperp(isuperp) + 1 219 ELSE 220 isuperp = isuperp + 1 221 END IF 222 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 223 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 224 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 225 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_lr_beta_4_4_1 226 &3_4_1',7,MA_ERR) 227 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lr_beta_4_4_1 228 &3_4_1',8,MA_ERR) 229 END IF 230 END IF 231 END IF 232 END DO 233 END DO 234 END DO 235 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 236 &ccsdt_lr_beta_4_4_13_4_1',9,MA_ERR) 237 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 238 &,int_mb(k_range+h10b-1),int_mb(k_range+h7b-1),int_mb(k_range+h12b- 239 &1),3,2,4,1,-1.0d0) 240 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 241 & noab - 1 + nvab * (h12b - 1 + noab * (h10b - 1 + noab * (h7b - 1) 242 &)))) 243 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lr_beta_4_4_13_4_1 244 &',10,MA_ERR) 245 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_lr_beta_4_4_1 246 &3_4_1',11,MA_ERR) 247 END IF 248 END IF 249 END IF 250 next = nxtask(nprocs,1) 251 END IF 252 count = count + 1 253 END DO 254 END DO 255 END DO 256 END DO 257 next = nxtask(-nprocs,1) 258 call GA_SYNC() 259 RETURN 260 END 261