1 SUBROUTINE ccsdtq_lambda2_26_4_2_1(d_a,k_a_offset,d_c,k_c_offset) 2C $Id$ 3C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5C i3 ( h3 h7 h8 h11 p1 p5 p9 p10 )_y + = 1 * y ( h3 h7 h8 h11 p1 p5 p9 p10 )_y 6 IMPLICIT NONE 7#include "global.fh" 8#include "mafdecls.fh" 9#include "sym.fh" 10#include "errquit.fh" 11#include "tce.fh" 12 INTEGER d_a 13 INTEGER k_a_offset 14 INTEGER d_c 15 INTEGER k_c_offset 16 INTEGER NXTASK 17 INTEGER next 18 INTEGER nprocs 19 INTEGER count 20 INTEGER h3b 21 INTEGER h7b 22 INTEGER h8b 23 INTEGER h11b 24 INTEGER p1b 25 INTEGER p5b 26 INTEGER p9b 27 INTEGER p10b 28 INTEGER dimc 29 INTEGER h3b_1 30 INTEGER h7b_1 31 INTEGER h8b_1 32 INTEGER h11b_1 33 INTEGER p1b_1 34 INTEGER p5b_1 35 INTEGER p9b_1 36 INTEGER p10b_1 37 INTEGER dim_common 38 INTEGER dima_sort 39 INTEGER dima 40 INTEGER l_a_sort 41 INTEGER k_a_sort 42 INTEGER l_a 43 INTEGER k_a 44 INTEGER l_c 45 INTEGER k_c 46 EXTERNAL NXTASK 47 nprocs = GA_NNODES() 48 count = 0 49 next = NXTASK(nprocs,1) 50 DO h3b = 1,noab 51 DO h7b = 1,noab 52 DO h8b = h7b,noab 53 DO h11b = h8b,noab 54 DO p1b = noab+1,noab+nvab 55 DO p5b = noab+1,noab+nvab 56 DO p9b = p5b,noab+nvab 57 DO p10b = p9b,noab+nvab 58 IF (next.eq.count) THEN 59 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h7b-1 60 &)+int_mb(k_spin+h8b-1)+int_mb(k_spin+h11b-1)+int_mb(k_spin+p1b-1)+ 61 &int_mb(k_spin+p5b-1)+int_mb(k_spin+p9b-1)+int_mb(k_spin+p10b-1).ne 62 &.16)) THEN 63 IF (int_mb(k_spin+h3b-1)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1) 64 &+int_mb(k_spin+h11b-1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p5b 65 &-1)+int_mb(k_spin+p9b-1)+int_mb(k_spin+p10b-1)) THEN 66 IF (ieor(int_mb(k_sym+h3b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 67 &k_sym+h8b-1),ieor(int_mb(k_sym+h11b-1),ieor(int_mb(k_sym+p1b-1),ie 68 &or(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+p10b- 69 &1)))))))) .eq. irrep_y) THEN 70 dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h7b-1) * int_mb(k_ra 71 &nge+h8b-1) * int_mb(k_range+h11b-1) * int_mb(k_range+p1b-1) * int_ 72 &mb(k_range+p5b-1) * int_mb(k_range+p9b-1) * int_mb(k_range+p10b-1) 73 CALL TCE_RESTRICTED_8(h3b,h7b,h8b,h11b,p1b,p5b,p9b,p10b,h3b_1,h7b_ 74 &1,h8b_1,h11b_1,p1b_1,p5b_1,p9b_1,p10b_1) 75 dim_common = 1 76 dima_sort = int_mb(k_range+h3b-1) * int_mb(k_range+h7b-1) * int_mb 77 &(k_range+h8b-1) * int_mb(k_range+h11b-1) * int_mb(k_range+p1b-1) * 78 & int_mb(k_range+p5b-1) * int_mb(k_range+p9b-1) * int_mb(k_range+p1 79 &0b-1) 80 dima = dim_common * dima_sort 81 IF (dima .gt. 0) THEN 82 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 83 & ERRQUIT('ccsdtq_lambda2_26_4_2_1',0,MA_ERR) 84 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 85 &ccsdtq_lambda2_26_4_2_1',1,MA_ERR) 86 IF ((h11b .lt. h3b) .and. (p10b .lt. p1b)) THEN 87 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 88 & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 89 & + nvab * (p5b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 - 90 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 91 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 92 &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1 93 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b- 94 &1),int_mb(k_range+p1b-1),7,6,5,8,3,2,1,4,1.0d0) 95 END IF 96 IF ((h11b .lt. h3b) .and. (p9b .lt. p1b) .and. (p1b .le. p10b)) TH 97 &EN 98 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 99 &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 100 & + nvab * (p5b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 - 101 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 102 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 103 &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1 104 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1 105 &),int_mb(k_range+p10b-1),8,6,5,7,3,2,1,4,-1.0d0) 106 END IF 107 IF ((h11b .lt. h3b) .and. (p5b .lt. p1b) .and. (p1b .le. p9b)) THE 108 &N 109 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 110 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 111 & + nvab * (p5b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 - 112 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 113 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 114 &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1 115 &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1 116 &),int_mb(k_range+p10b-1),8,7,5,6,3,2,1,4,1.0d0) 117 END IF 118 IF ((h11b .lt. h3b) .and. (p1b .le. p5b)) THEN 119 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 120 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 121 & + nvab * (p1b_1 - noab - 1 + nvab * (h3b_1 - 1 + noab * (h11b_1 - 122 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 123 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 124 &,int_mb(k_range+h8b-1),int_mb(k_range+h11b-1),int_mb(k_range+h3b-1 125 &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1 126 &),int_mb(k_range+p10b-1),8,7,6,5,3,2,1,4,-1.0d0) 127 END IF 128 IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p10b .lt. p1b)) TH 129 &EN 130 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 131 & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 132 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 - 133 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 134 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 135 &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1 136 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b- 137 &1),int_mb(k_range+p1b-1),7,6,5,8,4,2,1,3,-1.0d0) 138 END IF 139 IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p9b .lt. p1b) .and 140 &. (p1b .le. p10b)) THEN 141 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 142 &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 143 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 - 144 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 145 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 146 &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1 147 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1 148 &),int_mb(k_range+p10b-1),8,6,5,7,4,2,1,3,1.0d0) 149 END IF 150 IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p5b .lt. p1b) .and 151 &. (p1b .le. p9b)) THEN 152 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 153 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 154 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 - 155 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 156 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 157 &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1 158 &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1 159 &),int_mb(k_range+p10b-1),8,7,5,6,4,2,1,3,-1.0d0) 160 END IF 161 IF ((h8b .lt. h3b) .and. (h3b .le. h11b) .and. (p1b .le. p5b)) THE 162 &N 163 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 164 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 165 & + nvab * (p1b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h3b_1 - 166 & 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1))))))))) 167 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 168 &,int_mb(k_range+h8b-1),int_mb(k_range+h3b-1),int_mb(k_range+h11b-1 169 &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1 170 &),int_mb(k_range+p10b-1),8,7,6,5,4,2,1,3,1.0d0) 171 END IF 172 IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p10b .lt. p1b)) THE 173 &N 174 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 175 & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 176 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 177 & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1))))))))) 178 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 179 &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 180 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b- 181 &1),int_mb(k_range+p1b-1),7,6,5,8,4,3,1,2,1.0d0) 182 END IF 183 IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p9b .lt. p1b) .and. 184 & (p1b .le. p10b)) THEN 185 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 186 &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 187 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 188 & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1))))))))) 189 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 190 &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 191 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1 192 &),int_mb(k_range+p10b-1),8,6,5,7,4,3,1,2,-1.0d0) 193 END IF 194 IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p5b .lt. p1b) .and. 195 & (p1b .le. p9b)) THEN 196 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 197 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 198 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 199 & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1))))))))) 200 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 201 &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 202 &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1 203 &),int_mb(k_range+p10b-1),8,7,5,6,4,3,1,2,1.0d0) 204 END IF 205 IF ((h7b .lt. h3b) .and. (h3b .le. h8b) .and. (p1b .le. p5b)) THEN 206 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 207 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 208 & + nvab * (p1b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 209 & 1 + noab * (h3b_1 - 1 + noab * (h7b_1 - 1))))))))) 210 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 211 &,int_mb(k_range+h3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 212 &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1 213 &),int_mb(k_range+p10b-1),8,7,6,5,4,3,1,2,-1.0d0) 214 END IF 215 IF ((h3b .le. h7b) .and. (p10b .lt. p1b)) THEN 216 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 217 & - noab - 1 + nvab * (p10b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 218 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 219 & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1))))))))) 220 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1) 221 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 222 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p10b- 223 &1),int_mb(k_range+p1b-1),7,6,5,8,4,3,2,1,-1.0d0) 224 END IF 225 IF ((h3b .le. h7b) .and. (p9b .lt. p1b) .and. (p1b .le. p10b)) THE 226 &N 227 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 228 &1 - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 229 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 230 & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1))))))))) 231 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1) 232 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 233 &),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1 234 &),int_mb(k_range+p10b-1),8,6,5,7,4,3,2,1,1.0d0) 235 END IF 236 IF ((h3b .le. h7b) .and. (p5b .lt. p1b) .and. (p1b .le. p9b)) THEN 237 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 238 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 239 & + nvab * (p5b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 240 & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1))))))))) 241 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1) 242 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 243 &),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1 244 &),int_mb(k_range+p10b-1),8,7,5,6,4,3,2,1,-1.0d0) 245 END IF 246 IF ((h3b .le. h7b) .and. (p1b .le. p5b)) THEN 247 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p10b_ 248 &1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 249 & + nvab * (p1b_1 - noab - 1 + nvab * (h11b_1 - 1 + noab * (h8b_1 - 250 & 1 + noab * (h7b_1 - 1 + noab * (h3b_1 - 1))))))))) 251 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h3b-1) 252 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h11b-1 253 &),int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1 254 &),int_mb(k_range+p10b-1),8,7,6,5,4,3,2,1,1.0d0) 255 END IF 256 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_lambda2_26_4_2_1' 257 &,2,MA_ERR) 258 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 259 &ccsdtq_lambda2_26_4_2_1',3,MA_ERR) 260 CALL TCE_SORT_8(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p10b-1 261 &),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1),int_mb(k_range+p1b-1 262 &),int_mb(k_range+h11b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b- 263 &1),int_mb(k_range+h3b-1),8,7,6,5,4,3,2,1,1.0d0) 264 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p10b 265 &- noab - 1 + nvab * (p9b - noab - 1 + nvab * (p5b - noab - 1 + nva 266 &b * (p1b - noab - 1 + nvab * (h11b - 1 + noab * (h8b - 1 + noab * 267 &(h7b - 1 + noab * (h3b - 1))))))))) 268 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lambda2_26_4_2_1' 269 &,4,MA_ERR) 270 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lambda2_26_4 271 &_2_1',5,MA_ERR) 272 END IF 273 END IF 274 END IF 275 END IF 276 next = NXTASK(nprocs,1) 277 END IF 278 count = count + 1 279 END DO 280 END DO 281 END DO 282 END DO 283 END DO 284 END DO 285 END DO 286 END DO 287 next = NXTASK(-nprocs,1) 288 call GA_SYNC() 289 RETURN 290 END 291