1 SUBROUTINE ccsdt_lr_beta_4_4_7_1_1(d_a,k_a_offset,d_b,k_b_offset,d 2 &_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 h8 h12 p9 )_ytra + = 1 * Sum ( h3 p1 p2 ) * tra ( p1 p2 h3 h12 )_tra * y ( h3 h7 h8 p1 p2 p9 )_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 h8b 25 INTEGER h12b 26 INTEGER p9b 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 h8b_2 39 INTEGER h3b_2 40 INTEGER p9b_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 h8b = h7b,noab 68 DO h12b = 1,noab 69 DO p9b = 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+h8b-1 72 &)+int_mb(k_spin+h12b-1)+int_mb(k_spin+p9b-1).ne.8)) THEN 73 IF (int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+h 74 &12b-1)+int_mb(k_spin+p9b-1)) THEN 75 IF (ieor(int_mb(k_sym+h7b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb( 76 &k_sym+h12b-1),int_mb(k_sym+p9b-1)))) .eq. ieor(irrep_y,irrep_tra)) 77 & THEN 78 dimc = int_mb(k_range+h7b-1) * int_mb(k_range+h8b-1) * int_mb(k_ra 79 &nge+h12b-1) * int_mb(k_range+p9b-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_7_1_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,h8b,h3b,p9b,p1b,p2b,h7b_2,h8b_2,h3b_2,p9 92 &b_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+h8b-1) * int_mb 98 &(k_range+p9b-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_7_1_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_7_1_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_7_1_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_7_1_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_7_1_1',5,MA_ERR) 127 IF ((h3b .le. h7b) .and. (p2b .le. p9b)) THEN 128 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 129 & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 130 &+ nvab * (h8b_2 - 1 + noab * (h7b_2 - 1 + noab * (h3b_2 - 1))))))) 131 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 132 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+p1b-1) 133 &,int_mb(k_range+p2b-1),int_mb(k_range+p9b-1),6,3,2,1,5,4,1.0d0) 134 END IF 135 IF ((h3b .le. h7b) .and. (p1b .le. p9b) .and. (p9b .lt. p2b)) THEN 136 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 137 & - noab - 1 + nvab * (p9b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 138 &+ nvab * (h8b_2 - 1 + noab * (h7b_2 - 1 + noab * (h3b_2 - 1))))))) 139 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 140 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+p1b-1) 141 &,int_mb(k_range+p9b-1),int_mb(k_range+p2b-1),5,3,2,1,6,4,-1.0d0) 142 END IF 143 IF ((h3b .le. h7b) .and. (p9b .lt. p1b)) THEN 144 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 145 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p9b_2 - noab - 1 146 &+ nvab * (h8b_2 - 1 + noab * (h7b_2 - 1 + noab * (h3b_2 - 1))))))) 147 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 148 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+p9b-1) 149 &,int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),4,3,2,1,6,5,1.0d0) 150 END IF 151 IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p2b .le. p9b)) THEN 152 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 153 & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 154 &+ nvab * (h8b_2 - 1 + noab * (h3b_2 - 1 + noab * (h7b_2 - 1))))))) 155 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 156 &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p1b-1) 157 &,int_mb(k_range+p2b-1),int_mb(k_range+p9b-1),6,3,1,2,5,4,-1.0d0) 158 END IF 159 IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p1b .le. p9b) .and. 160 & (p9b .lt. p2b)) THEN 161 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 162 & - noab - 1 + nvab * (p9b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 163 &+ nvab * (h8b_2 - 1 + noab * (h3b_2 - 1 + noab * (h7b_2 - 1))))))) 164 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 165 &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p1b-1) 166 &,int_mb(k_range+p9b-1),int_mb(k_range+p2b-1),5,3,1,2,6,4,1.0d0) 167 END IF 168 IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p9b .lt. p1b)) THEN 169 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 170 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p9b_2 - noab - 1 171 &+ nvab * (h8b_2 - 1 + noab * (h3b_2 - 1 + noab * (h7b_2 - 1))))))) 172 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 173 &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p9b-1) 174 &,int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),4,3,1,2,6,5,-1.0d0) 175 END IF 176 IF ((h8b .lt. h3b) .and. (p2b .le. p9b)) THEN 177 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 178 & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 179 &+ nvab * (h3b_2 - 1 + noab * (h8b_2 - 1 + noab * (h7b_2 - 1))))))) 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+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+p1b-1) 182 &,int_mb(k_range+p2b-1),int_mb(k_range+p9b-1),6,2,1,3,5,4,1.0d0) 183 END IF 184 IF ((h8b .lt. h3b) .and. (p1b .le. p9b) .and. (p9b .lt. p2b)) THEN 185 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 186 & - noab - 1 + nvab * (p9b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 187 &+ nvab * (h3b_2 - 1 + noab * (h8b_2 - 1 + noab * (h7b_2 - 1))))))) 188 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 189 &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+p1b-1) 190 &,int_mb(k_range+p9b-1),int_mb(k_range+p2b-1),5,2,1,3,6,4,-1.0d0) 191 END IF 192 IF ((h8b .lt. h3b) .and. (p9b .lt. p1b)) THEN 193 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 194 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p9b_2 - noab - 1 195 &+ nvab * (h3b_2 - 1 + noab * (h8b_2 - 1 + noab * (h7b_2 - 1))))))) 196 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 197 &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+p9b-1) 198 &,int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),4,2,1,3,6,5,1.0d0) 199 END IF 200 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_lr_beta_4_4_7_1_1' 201 &,6,MA_ERR) 202 nsuperp(1) = 1 203 nsuperp(2) = 1 204 isuperp = 1 205 IF (p1b .eq. p2b) THEN 206 nsuperp(isuperp) = nsuperp(isuperp) + 1 207 ELSE 208 isuperp = isuperp + 1 209 END IF 210 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 211 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 212 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 213 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_lr_beta_4_4_7 214 &_1_1',7,MA_ERR) 215 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lr_beta_4_4_7 216 &_1_1',8,MA_ERR) 217 END IF 218 END IF 219 END IF 220 END DO 221 END DO 222 END DO 223 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 224 &ccsdt_lr_beta_4_4_7_1_1',9,MA_ERR) 225 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p9b-1) 226 &,int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+h12b-1 227 &),3,2,4,1,1.0d0) 228 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p9b - 229 & noab - 1 + nvab * (h12b - 1 + noab * (h8b - 1 + noab * (h7b - 1)) 230 &))) 231 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lr_beta_4_4_7_1_1' 232 &,10,MA_ERR) 233 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_lr_beta_4_4_7 234 &_1_1',11,MA_ERR) 235 END IF 236 END IF 237 END IF 238 next = nxtask(nprocs,1) 239 END IF 240 count = count + 1 241 END DO 242 END DO 243 END DO 244 END DO 245 next = nxtask(-nprocs,1) 246 call GA_SYNC() 247 RETURN 248 END 249