1 SUBROUTINE ccsdtq_lr_alpha_15_32_1_2(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 ( h2 h15 )_yt + = -1/12 * Sum ( h9 h10 h11 p5 p6 p7 p8 ) * t ( p5 p6 p7 p8 h9 h10 h11 h15 )_t * y ( h2 h9 h10 h11 p5 p6 p7 p8 )_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 h2b 24 INTEGER h15b 25 INTEGER dimc 26 INTEGER l_c_sort 27 INTEGER k_c_sort 28 INTEGER p5b 29 INTEGER p6b 30 INTEGER p7b 31 INTEGER p8b 32 INTEGER h9b 33 INTEGER h10b 34 INTEGER h11b 35 INTEGER p5b_1 36 INTEGER p6b_1 37 INTEGER p7b_1 38 INTEGER p8b_1 39 INTEGER h15b_1 40 INTEGER h9b_1 41 INTEGER h10b_1 42 INTEGER h11b_1 43 INTEGER h2b_2 44 INTEGER h9b_2 45 INTEGER h10b_2 46 INTEGER h11b_2 47 INTEGER p5b_2 48 INTEGER p6b_2 49 INTEGER p7b_2 50 INTEGER p8b_2 51 INTEGER dim_common 52 INTEGER dima_sort 53 INTEGER dima 54 INTEGER dimb_sort 55 INTEGER dimb 56 INTEGER l_a_sort 57 INTEGER k_a_sort 58 INTEGER l_a 59 INTEGER k_a 60 INTEGER l_b_sort 61 INTEGER k_b_sort 62 INTEGER l_b 63 INTEGER k_b 64 INTEGER nsuperp(4) 65 INTEGER isuperp 66 INTEGER nsubh(3) 67 INTEGER isubh 68 INTEGER l_c 69 INTEGER k_c 70 DOUBLE PRECISION FACTORIAL 71 EXTERNAL nxtask 72 EXTERNAL FACTORIAL 73 nprocs = GA_NNODES() 74 count = 0 75 next = nxtask(nprocs,1) 76 DO h2b = 1,noab 77 DO h15b = 1,noab 78 IF (next.eq.count) THEN 79 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h15b- 80 &1).ne.4)) THEN 81 IF (int_mb(k_spin+h2b-1) .eq. int_mb(k_spin+h15b-1)) THEN 82 IF (ieor(int_mb(k_sym+h2b-1),int_mb(k_sym+h15b-1)) .eq. ieor(irrep 83 &_y,irrep_t)) THEN 84 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h15b-1) 85 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 86 & ERRQUIT('ccsdtq_lr_alpha_15_32_1_2',0,MA_ERR) 87 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 88 DO p5b = noab+1,noab+nvab 89 DO p6b = p5b,noab+nvab 90 DO p7b = p6b,noab+nvab 91 DO p8b = p7b,noab+nvab 92 DO h9b = 1,noab 93 DO h10b = h9b,noab 94 DO h11b = h10b,noab 95 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1)+int_mb(k_spin+p7b-1) 96 &+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+h9b 97 &-1)+int_mb(k_spin+h10b-1)+int_mb(k_spin+h11b-1)) THEN 98 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p6b-1),ieor(int_mb( 99 &k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h15b-1),ie 100 &or(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),int_mb(k_sym+h11b 101 &-1)))))))) .eq. irrep_t) THEN 102 CALL TCE_RESTRICTED_8(p5b,p6b,p7b,p8b,h15b,h9b,h10b,h11b,p5b_1,p6b 103 &_1,p7b_1,p8b_1,h15b_1,h9b_1,h10b_1,h11b_1) 104 CALL TCE_RESTRICTED_8(h2b,h9b,h10b,h11b,p5b,p6b,p7b,p8b,h2b_2,h9b_ 105 &2,h10b_2,h11b_2,p5b_2,p6b_2,p7b_2,p8b_2) 106 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+p6b-1) * int_m 107 &b(k_range+p7b-1) * int_mb(k_range+p8b-1) * int_mb(k_range+h9b-1) * 108 & int_mb(k_range+h10b-1) * int_mb(k_range+h11b-1) 109 dima_sort = int_mb(k_range+h15b-1) 110 dima = dim_common * dima_sort 111 dimb_sort = int_mb(k_range+h2b-1) 112 dimb = dim_common * dimb_sort 113 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 114 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 115 & ERRQUIT('ccsdtq_lr_alpha_15_32_1_2',1,MA_ERR) 116 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 117 &ccsdtq_lr_alpha_15_32_1_2',2,MA_ERR) 118 IF ((h11b .le. h15b)) THEN 119 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h15b_ 120 &1 - 1 + noab * (h11b_1 - 1 + noab * (h10b_1 - 1 + noab * (h9b_1 - 121 &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * ( 122 &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 123 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 124 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 125 &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+h11b- 126 &1),int_mb(k_range+h15b-1),8,7,6,5,4,3,2,1,1.0d0) 127 END IF 128 IF ((h10b .le. h15b) .and. (h15b .lt. h11b)) THEN 129 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_ 130 &1 - 1 + noab * (h15b_1 - 1 + noab * (h10b_1 - 1 + noab * (h9b_1 - 131 &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * ( 132 &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 133 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 134 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 135 &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+h15b- 136 &1),int_mb(k_range+h11b-1),7,8,6,5,4,3,2,1,-1.0d0) 137 END IF 138 IF ((h9b .le. h15b) .and. (h15b .lt. h10b)) THEN 139 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_ 140 &1 - 1 + noab * (h10b_1 - 1 + noab * (h15b_1 - 1 + noab * (h9b_1 - 141 &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * ( 142 &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 143 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 144 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 145 &,int_mb(k_range+h9b-1),int_mb(k_range+h15b-1),int_mb(k_range+h10b- 146 &1),int_mb(k_range+h11b-1),6,8,7,5,4,3,2,1,1.0d0) 147 END IF 148 IF ((h15b .lt. h9b)) THEN 149 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_ 150 &1 - 1 + noab * (h10b_1 - 1 + noab * (h9b_1 - 1 + noab * (h15b_1 - 151 &1 + noab * (p8b_1 - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * ( 152 &p6b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 153 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 154 &,int_mb(k_range+p6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1) 155 &,int_mb(k_range+h15b-1),int_mb(k_range+h9b-1),int_mb(k_range+h10b- 156 &1),int_mb(k_range+h11b-1),5,8,7,6,4,3,2,1,-1.0d0) 157 END IF 158 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_lr_alpha_15_32_1_ 159 &2',3,MA_ERR) 160 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 161 & ERRQUIT('ccsdtq_lr_alpha_15_32_1_2',4,MA_ERR) 162 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 163 &ccsdtq_lr_alpha_15_32_1_2',5,MA_ERR) 164 IF ((h11b .lt. h2b)) THEN 165 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 166 & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 167 &+ nvab * (p5b_2 - noab - 1 + nvab * (h2b_2 - 1 + noab * (h11b_2 - 168 &1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1))))))))) 169 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 170 &,int_mb(k_range+h10b-1),int_mb(k_range+h11b-1),int_mb(k_range+h2b- 171 &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b- 172 &1),int_mb(k_range+p8b-1),4,3,2,1,8,7,6,5,-1.0d0) 173 END IF 174 IF ((h10b .lt. h2b) .and. (h2b .le. h11b)) THEN 175 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 176 & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 177 &+ nvab * (p5b_2 - noab - 1 + nvab * (h11b_2 - 1 + noab * (h2b_2 - 178 &1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1))))))))) 179 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 180 &,int_mb(k_range+h10b-1),int_mb(k_range+h2b-1),int_mb(k_range+h11b- 181 &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b- 182 &1),int_mb(k_range+p8b-1),3,4,2,1,8,7,6,5,1.0d0) 183 END IF 184 IF ((h9b .lt. h2b) .and. (h2b .le. h10b)) THEN 185 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 186 & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 187 &+ nvab * (p5b_2 - noab - 1 + nvab * (h11b_2 - 1 + noab * (h10b_2 - 188 & 1 + noab * (h2b_2 - 1 + noab * (h9b_2 - 1))))))))) 189 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 190 &,int_mb(k_range+h2b-1),int_mb(k_range+h10b-1),int_mb(k_range+h11b- 191 &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b- 192 &1),int_mb(k_range+p8b-1),2,4,3,1,8,7,6,5,-1.0d0) 193 END IF 194 IF ((h2b .le. h9b)) THEN 195 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 196 & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p6b_2 - noab - 1 197 &+ nvab * (p5b_2 - noab - 1 + nvab * (h11b_2 - 1 + noab * (h10b_2 - 198 & 1 + noab * (h9b_2 - 1 + noab * (h2b_2 - 1))))))))) 199 CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 200 &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+h11b- 201 &1),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),int_mb(k_range+p7b- 202 &1),int_mb(k_range+p8b-1),1,4,3,2,8,7,6,5,1.0d0) 203 END IF 204 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_lr_alpha_15_32_1_ 205 &2',6,MA_ERR) 206 nsuperp(1) = 1 207 nsuperp(2) = 1 208 nsuperp(3) = 1 209 nsuperp(4) = 1 210 isuperp = 1 211 IF (p5b .eq. p6b) THEN 212 nsuperp(isuperp) = nsuperp(isuperp) + 1 213 ELSE 214 isuperp = isuperp + 1 215 END IF 216 IF (p6b .eq. p7b) THEN 217 nsuperp(isuperp) = nsuperp(isuperp) + 1 218 ELSE 219 isuperp = isuperp + 1 220 END IF 221 IF (p7b .eq. p8b) THEN 222 nsuperp(isuperp) = nsuperp(isuperp) + 1 223 ELSE 224 isuperp = isuperp + 1 225 END IF 226 nsubh(1) = 1 227 nsubh(2) = 1 228 nsubh(3) = 1 229 isubh = 1 230 IF (h9b .eq. h10b) THEN 231 nsubh(isubh) = nsubh(isubh) + 1 232 ELSE 233 isubh = isubh + 1 234 END IF 235 IF (h10b .eq. h11b) THEN 236 nsubh(isubh) = nsubh(isubh) + 1 237 ELSE 238 isubh = isubh + 1 239 END IF 240 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,144.0d0/FACTORIA 241 &L(nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsuperp(3))/FACTORIA 242 &L(nsuperp(4))/FACTORIAL(nsubh(1))/FACTORIAL(nsubh(2))/FACTORIAL(ns 243 &ubh(3)),dbl_mb(k_a_sort),dim_common,dbl_mb(k_b_sort),dim_common,1. 244 &0d0,dbl_mb(k_c_sort),dima_sort) 245 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 246 &32_1_2',7,MA_ERR) 247 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 248 &32_1_2',8,MA_ERR) 249 END IF 250 END IF 251 END IF 252 END DO 253 END DO 254 END DO 255 END DO 256 END DO 257 END DO 258 END DO 259 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 260 &ccsdtq_lr_alpha_15_32_1_2',9,MA_ERR) 261 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 262 &,int_mb(k_range+h15b-1),1,2,-1.0d0/12.0d0) 263 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h15b 264 &- 1 + noab * (h2b - 1))) 265 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lr_alpha_15_32_1_ 266 &2',10,MA_ERR) 267 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 268 &32_1_2',11,MA_ERR) 269 END IF 270 END IF 271 END IF 272 next = nxtask(nprocs,1) 273 END IF 274 count = count + 1 275 END DO 276 END DO 277 next = nxtask(-nprocs,1) 278 call GA_SYNC() 279 RETURN 280 END 281