1 SUBROUTINE eomccsdtq_x3_10(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_o 2 &ffset) 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 ( p4 p5 p6 h1 h2 h3 )_xv + = -1/2 * P( 3 ) * Sum ( p9 p8 h7 ) * x ( p4 p5 p8 p9 h1 h2 h3 h7 )_x * v ( h7 p6 p8 p9 )_v 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 p4b 24 INTEGER p5b 25 INTEGER p6b 26 INTEGER h1b 27 INTEGER h2b 28 INTEGER h3b 29 INTEGER dimc 30 INTEGER l_c_sort 31 INTEGER k_c_sort 32 INTEGER p8b 33 INTEGER p9b 34 INTEGER h7b 35 INTEGER p4b_1 36 INTEGER p5b_1 37 INTEGER p8b_1 38 INTEGER p9b_1 39 INTEGER h1b_1 40 INTEGER h2b_1 41 INTEGER h3b_1 42 INTEGER h7b_1 43 INTEGER p6b_2 44 INTEGER h7b_2 45 INTEGER p8b_2 46 INTEGER p9b_2 47 INTEGER dim_common 48 INTEGER dima_sort 49 INTEGER dima 50 INTEGER dimb_sort 51 INTEGER dimb 52 INTEGER l_a_sort 53 INTEGER k_a_sort 54 INTEGER l_a 55 INTEGER k_a 56 INTEGER l_b_sort 57 INTEGER k_b_sort 58 INTEGER l_b 59 INTEGER k_b 60 INTEGER nsuperp(2) 61 INTEGER isuperp 62 INTEGER l_c 63 INTEGER k_c 64 DOUBLE PRECISION FACTORIAL 65 EXTERNAL NXTASK 66 EXTERNAL FACTORIAL 67 nprocs = GA_NNODES() 68 count = 0 69 next = NXTASK(nprocs,1) 70 DO p4b = noab+1,noab+nvab 71 DO p5b = p4b,noab+nvab 72 DO p6b = noab+1,noab+nvab 73 DO h1b = 1,noab 74 DO h2b = h1b,noab 75 DO h3b = h2b,noab 76 IF (next.eq.count) THEN 77 IF ((.not.restricted).or.(int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1 78 &)+int_mb(k_spin+p6b-1)+int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+i 79 &nt_mb(k_spin+h3b-1).ne.12)) THEN 80 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6b-1) 81 & .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b-1)+int_mb(k_spin+h3b- 82 &1)) THEN 83 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 84 &k_sym+p6b-1),ieor(int_mb(k_sym+h1b-1),ieor(int_mb(k_sym+h2b-1),int 85 &_mb(k_sym+h3b-1)))))) .eq. ieor(irrep_x,irrep_v)) THEN 86 dimc = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb(k_ra 87 &nge+p6b-1) * int_mb(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_m 88 &b(k_range+h3b-1) 89 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 90 & ERRQUIT('eomccsdtq_x3_10',0,MA_ERR) 91 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 92 DO p8b = noab+1,noab+nvab 93 DO p9b = p8b,noab+nvab 94 DO h7b = 1,noab 95 IF (int_mb(k_spin+p4b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p8b-1) 96 &+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h1b-1)+int_mb(k_spin+h2b- 97 &1)+int_mb(k_spin+h3b-1)+int_mb(k_spin+h7b-1)) THEN 98 IF (ieor(int_mb(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 99 &k_sym+p8b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb(k_sym+h1b-1),ieo 100 &r(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h7b-1) 101 &))))))) .eq. irrep_x) THEN 102 CALL TCE_RESTRICTED_8(p4b,p5b,p8b,p9b,h1b,h2b,h3b,h7b,p4b_1,p5b_1, 103 &p8b_1,p9b_1,h1b_1,h2b_1,h3b_1,h7b_1) 104 CALL TCE_RESTRICTED_4(p6b,h7b,p8b,p9b,p6b_2,h7b_2,p8b_2,p9b_2) 105 dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+p9b-1) * int_m 106 &b(k_range+h7b-1) 107 dima_sort = int_mb(k_range+p4b-1) * int_mb(k_range+p5b-1) * int_mb 108 &(k_range+h1b-1) * int_mb(k_range+h2b-1) * int_mb(k_range+h3b-1) 109 dima = dim_common * dima_sort 110 dimb_sort = int_mb(k_range+p6b-1) 111 dimb = dim_common * dimb_sort 112 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 113 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 114 & ERRQUIT('eomccsdtq_x3_10',1,MA_ERR) 115 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 116 &eomccsdtq_x3_10',2,MA_ERR) 117 IF ((p9b .lt. p4b) .and. (h7b .lt. h1b)) THEN 118 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 119 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + 120 & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b 121 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 122 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 123 &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1) 124 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 125 &,int_mb(k_range+h3b-1),8,7,6,4,3,5,2,1,-1.0d0) 126 END IF 127 IF ((p9b .lt. p4b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 128 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 129 & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + 130 & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b 131 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 132 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 133 &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1) 134 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 135 &,int_mb(k_range+h3b-1),8,7,5,4,3,6,2,1,1.0d0) 136 END IF 137 IF ((p9b .lt. p4b) .and. (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN 138 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 139 & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 140 & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b 141 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 142 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 143 &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1) 144 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 145 &,int_mb(k_range+h3b-1),8,6,5,4,3,7,2,1,-1.0d0) 146 END IF 147 IF ((p9b .lt. p4b) .and. (h3b .le. h7b)) THEN 148 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 149 & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 150 & noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p9b 151 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 152 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 153 &,int_mb(k_range+p9b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1) 154 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 155 &,int_mb(k_range+h7b-1),7,6,5,4,3,8,2,1,1.0d0) 156 END IF 157 IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and. 158 & (h7b .lt. h1b)) THEN 159 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 160 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + 161 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b 162 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 163 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 164 &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 165 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 166 &,int_mb(k_range+h3b-1),8,7,6,4,2,5,3,1,1.0d0) 167 END IF 168 IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and. 169 & (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 170 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 171 & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + 172 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b 173 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 174 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 175 &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 176 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 177 &,int_mb(k_range+h3b-1),8,7,5,4,2,6,3,1,-1.0d0) 178 END IF 179 IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and. 180 & (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN 181 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 182 & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 183 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b 184 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 185 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 186 &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 187 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 188 &,int_mb(k_range+h3b-1),8,6,5,4,2,7,3,1,1.0d0) 189 END IF 190 IF ((p8b .lt. p4b) .and. (p4b .le. p9b) .and. (p9b .lt. p5b) .and. 191 & (h3b .le. h7b)) THEN 192 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 193 & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 194 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p4b 195 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 196 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 197 &,int_mb(k_range+p4b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 198 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 199 &,int_mb(k_range+h7b-1),7,6,5,4,2,8,3,1,-1.0d0) 200 END IF 201 IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h7b .lt. h1b)) THEN 202 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 203 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + 204 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b 205 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 206 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 207 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 208 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 209 &,int_mb(k_range+h3b-1),8,7,6,3,2,5,4,1,-1.0d0) 210 END IF 211 IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h1b .le. h7b) .and. 212 & (h7b .lt. h2b)) THEN 213 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 214 & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + 215 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b 216 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 217 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 218 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 219 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 220 &,int_mb(k_range+h3b-1),8,7,5,3,2,6,4,1,1.0d0) 221 END IF 222 IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h2b .le. h7b) .and. 223 & (h7b .lt. h3b)) THEN 224 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 225 & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 226 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b 227 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 228 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 229 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 230 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 231 &,int_mb(k_range+h3b-1),8,6,5,3,2,7,4,1,-1.0d0) 232 END IF 233 IF ((p8b .lt. p4b) .and. (p5b .le. p9b) .and. (h3b .le. h7b)) THEN 234 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 235 & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 236 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p4b 237 &_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 238 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 239 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 240 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 241 &,int_mb(k_range+h7b-1),7,6,5,3,2,8,4,1,1.0d0) 242 END IF 243 IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h7b .lt. h1b)) THEN 244 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 245 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + 246 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b 247 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 248 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 249 &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 250 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 251 &,int_mb(k_range+h3b-1),8,7,6,4,1,5,3,2,-1.0d0) 252 END IF 253 IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h1b .le. h7b) .and. 254 & (h7b .lt. h2b)) THEN 255 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 256 & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + 257 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b 258 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 259 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 260 &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 261 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 262 &,int_mb(k_range+h3b-1),8,7,5,4,1,6,3,2,1.0d0) 263 END IF 264 IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h2b .le. h7b) .and. 265 & (h7b .lt. h3b)) THEN 266 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 267 & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 268 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b 269 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 270 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 271 &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 272 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 273 &,int_mb(k_range+h3b-1),8,6,5,4,1,7,3,2,-1.0d0) 274 END IF 275 IF ((p4b .le. p8b) .and. (p9b .lt. p5b) .and. (h3b .le. h7b)) THEN 276 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 277 & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 278 & noab * (p5b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p8b 279 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 280 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 281 &,int_mb(k_range+p8b-1),int_mb(k_range+p9b-1),int_mb(k_range+p5b-1) 282 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 283 &,int_mb(k_range+h7b-1),7,6,5,4,1,8,3,2,1.0d0) 284 END IF 285 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and. 286 & (h7b .lt. h1b)) THEN 287 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 288 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + 289 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b 290 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 291 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 292 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 293 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 294 &,int_mb(k_range+h3b-1),8,7,6,3,1,5,4,2,1.0d0) 295 END IF 296 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and. 297 & (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 298 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 299 & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + 300 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b 301 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 302 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 303 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 304 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 305 &,int_mb(k_range+h3b-1),8,7,5,3,1,6,4,2,-1.0d0) 306 END IF 307 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and. 308 & (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN 309 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 310 & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 311 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b 312 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 313 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 314 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 315 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 316 &,int_mb(k_range+h3b-1),8,6,5,3,1,7,4,2,1.0d0) 317 END IF 318 IF ((p4b .le. p8b) .and. (p8b .lt. p5b) .and. (p5b .le. p9b) .and. 319 & (h3b .le. h7b)) THEN 320 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 321 & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 322 & noab * (p9b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * (p8b 323 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 324 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 325 &,int_mb(k_range+p8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p9b-1) 326 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 327 &,int_mb(k_range+h7b-1),7,6,5,3,1,8,4,2,-1.0d0) 328 END IF 329 IF ((p5b .le. p8b) .and. (h7b .lt. h1b)) THEN 330 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 331 & - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + noab * (h7b_1 - 1 + 332 & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b 333 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 334 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 335 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1) 336 &,int_mb(k_range+h7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h2b-1) 337 &,int_mb(k_range+h3b-1),8,7,6,2,1,5,4,3,-1.0d0) 338 END IF 339 IF ((p5b .le. p8b) .and. (h1b .le. h7b) .and. (h7b .lt. h2b)) THEN 340 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 341 & - 1 + noab * (h2b_1 - 1 + noab * (h7b_1 - 1 + noab * (h1b_1 - 1 + 342 & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b 343 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 344 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 345 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1) 346 &,int_mb(k_range+h1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h2b-1) 347 &,int_mb(k_range+h3b-1),8,7,5,2,1,6,4,3,1.0d0) 348 END IF 349 IF ((p5b .le. p8b) .and. (h2b .le. h7b) .and. (h7b .lt. h3b)) THEN 350 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h3b_1 351 & - 1 + noab * (h7b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 352 & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b 353 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 354 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 355 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1) 356 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h7b-1) 357 &,int_mb(k_range+h3b-1),8,6,5,2,1,7,4,3,-1.0d0) 358 END IF 359 IF ((p5b .le. p8b) .and. (h3b .le. h7b)) THEN 360 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h7b_1 361 & - 1 + noab * (h3b_1 - 1 + noab * (h2b_1 - 1 + noab * (h1b_1 - 1 + 362 & noab * (p9b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * (p5b 363 &_1 - noab - 1 + nvab * (p4b_1 - noab - 1))))))))) 364 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p4b-1) 365 &,int_mb(k_range+p5b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1) 366 &,int_mb(k_range+h1b-1),int_mb(k_range+h2b-1),int_mb(k_range+h3b-1) 367 &,int_mb(k_range+h7b-1),7,6,5,2,1,8,4,3,1.0d0) 368 END IF 369 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsdtq_x3_10',3,MA_ER 370 &R) 371 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 372 & ERRQUIT('eomccsdtq_x3_10',4,MA_ERR) 373 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 374 &eomccsdtq_x3_10',5,MA_ERR) 375 IF ((h7b .le. p6b)) THEN 376 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 377 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (p6b_2 - 1 + (noab 378 &+nvab) * (h7b_2 - 1))))) 379 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 380 &,int_mb(k_range+p6b-1),int_mb(k_range+p8b-1),int_mb(k_range+p9b-1) 381 &,2,1,4,3,1.0d0) 382 END IF 383 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsdtq_x3_10',6,MA_ER 384 &R) 385 nsuperp(1) = 1 386 nsuperp(2) = 1 387 isuperp = 1 388 IF (p8b .eq. p9b) THEN 389 nsuperp(isuperp) = nsuperp(isuperp) + 1 390 ELSE 391 isuperp = isuperp + 1 392 END IF 393 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 394 &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_ 395 &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 396 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsdtq_x3_10',7, 397 &MA_ERR) 398 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsdtq_x3_10',8, 399 &MA_ERR) 400 END IF 401 END IF 402 END IF 403 END DO 404 END DO 405 END DO 406 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 407 &eomccsdtq_x3_10',9,MA_ERR) 408 IF ((p5b .le. p6b)) THEN 409 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1) 410 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 411 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,5,1,4,3,2,-1.0d0/2. 412 &0d0) 413 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 414 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p6b - noab - 1 + 415 &nvab * (p5b - noab - 1 + nvab * (p4b - noab - 1))))))) 416 END IF 417 IF ((p6b .le. p4b)) THEN 418 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1) 419 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 420 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),1,6,5,4,3,2,-1.0d0/2. 421 &0d0) 422 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 423 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + 424 &nvab * (p4b - noab - 1 + nvab * (p6b - noab - 1))))))) 425 END IF 426 IF ((p4b .le. p6b) .and. (p6b .le. p5b)) THEN 427 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1) 428 &,int_mb(k_range+h3b-1),int_mb(k_range+h2b-1),int_mb(k_range+h1b-1) 429 &,int_mb(k_range+p5b-1),int_mb(k_range+p4b-1),6,1,5,4,3,2,1.0d0/2.0 430 &d0) 431 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h3b - 432 & 1 + noab * (h2b - 1 + noab * (h1b - 1 + noab * (p5b - noab - 1 + 433 &nvab * (p6b - noab - 1 + nvab * (p4b - noab - 1))))))) 434 END IF 435 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsdtq_x3_10',10,MA_E 436 &RR) 437 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsdtq_x3_10',11 438 &,MA_ERR) 439 END IF 440 END IF 441 END IF 442 next = NXTASK(nprocs,1) 443 END IF 444 count = count + 1 445 END DO 446 END DO 447 END DO 448 END DO 449 END DO 450 END DO 451 next = NXTASK(-nprocs,1) 452 call GA_SYNC() 453 RETURN 454 END 455