1 SUBROUTINE eomccsdtq_y2_23_4(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c 2 &_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 i1 ( p5 p15 p17 h13 h16 p1 )_vt + = -1/6 * Sum ( h11 h12 p8 ) * t ( p5 p8 p15 p17 h11 h12 h13 h16 )_t * v ( h11 h12 p1 p8 )_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 p5b 24 INTEGER p15b 25 INTEGER p17b 26 INTEGER p1b 27 INTEGER h13b 28 INTEGER h16b 29 INTEGER dimc 30 INTEGER l_c_sort 31 INTEGER k_c_sort 32 INTEGER p8b 33 INTEGER h11b 34 INTEGER h12b 35 INTEGER p5b_1 36 INTEGER p15b_1 37 INTEGER p17b_1 38 INTEGER p8b_1 39 INTEGER h13b_1 40 INTEGER h16b_1 41 INTEGER h11b_1 42 INTEGER h12b_1 43 INTEGER h11b_2 44 INTEGER h12b_2 45 INTEGER p1b_2 46 INTEGER p8b_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 nsubh(2) 61 INTEGER isubh 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 p5b = noab+1,noab+nvab 71 DO p15b = p5b,noab+nvab 72 DO p17b = p15b,noab+nvab 73 DO p1b = noab+1,noab+nvab 74 DO h13b = 1,noab 75 DO h16b = h13b,noab 76 IF (next.eq.count) THEN 77 IF ((.not.restricted).or.(int_mb(k_spin+p5b-1)+int_mb(k_spin+p15b- 78 &1)+int_mb(k_spin+p17b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h13b-1 79 &)+int_mb(k_spin+h16b-1).ne.12)) THEN 80 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p15b-1)+int_mb(k_spin+p17b- 81 &1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+h13b-1)+int_mb(k_spin+h 82 &16b-1)) THEN 83 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p15b-1),ieor(int_mb 84 &(k_sym+p17b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+h13b-1), 85 &int_mb(k_sym+h16b-1)))))) .eq. ieor(irrep_v,irrep_t)) THEN 86 dimc = int_mb(k_range+p5b-1) * int_mb(k_range+p15b-1) * int_mb(k_r 87 &ange+p17b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+h13b-1) * in 88 &t_mb(k_range+h16b-1) 89 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 90 & ERRQUIT('eomccsdtq_y2_23_4',0,MA_ERR) 91 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 92 DO p8b = noab+1,noab+nvab 93 DO h11b = 1,noab 94 DO h12b = h11b,noab 95 IF (int_mb(k_spin+p5b-1)+int_mb(k_spin+p15b-1)+int_mb(k_spin+p17b- 96 &1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h13b-1)+int_mb(k_spin+h 97 &16b-1)+int_mb(k_spin+h11b-1)+int_mb(k_spin+h12b-1)) THEN 98 IF (ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+p15b-1),ieor(int_mb 99 &(k_sym+p17b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(k_sym+h13b-1), 100 &ieor(int_mb(k_sym+h16b-1),ieor(int_mb(k_sym+h11b-1),int_mb(k_sym+h 101 &12b-1)))))))) .eq. irrep_t) THEN 102 CALL TCE_RESTRICTED_8(p5b,p15b,p17b,p8b,h13b,h16b,h11b,h12b,p5b_1, 103 &p15b_1,p17b_1,p8b_1,h13b_1,h16b_1,h11b_1,h12b_1) 104 CALL TCE_RESTRICTED_4(h11b,h12b,p1b,p8b,h11b_2,h12b_2,p1b_2,p8b_2) 105 dim_common = int_mb(k_range+p8b-1) * int_mb(k_range+h11b-1) * int_ 106 &mb(k_range+h12b-1) 107 dima_sort = int_mb(k_range+p5b-1) * int_mb(k_range+p15b-1) * int_m 108 &b(k_range+p17b-1) * int_mb(k_range+h13b-1) * int_mb(k_range+h16b-1 109 &) 110 dima = dim_common * dima_sort 111 dimb_sort = int_mb(k_range+p1b-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('eomccsdtq_y2_23_4',1,MA_ERR) 116 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 117 &eomccsdtq_y2_23_4',2,MA_ERR) 118 IF ((p8b .lt. p5b) .and. (h12b .le. h13b)) THEN 119 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 120 &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 121 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 122 &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 123 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 124 &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 125 &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1 126 &3b-1),int_mb(k_range+h16b-1),8,7,4,3,2,6,5,1,-1.0d0) 127 END IF 128 IF ((p8b .lt. p5b) .and. (h11b .le. h13b) .and. (h13b .lt. h12b) . 129 &and. (h12b .le. h16b)) THEN 130 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 131 &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 132 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 133 &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 134 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 135 &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 136 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 137 &2b-1),int_mb(k_range+h16b-1),8,6,4,3,2,7,5,1,1.0d0) 138 END IF 139 IF ((p8b .lt. p5b) .and. (h11b .le. h13b) .and. (h16b .lt. h12b)) 140 &THEN 141 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 142 &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 143 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 144 &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 145 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 146 &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 147 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 148 &6b-1),int_mb(k_range+h12b-1),7,6,4,3,2,8,5,1,-1.0d0) 149 END IF 150 IF ((p8b .lt. p5b) .and. (h13b .lt. h11b) .and. (h12b .le. h16b)) 151 &THEN 152 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 153 &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 154 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 155 &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 156 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 157 &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 158 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 159 &2b-1),int_mb(k_range+h16b-1),8,5,4,3,2,7,6,1,-1.0d0) 160 END IF 161 IF ((p8b .lt. p5b) .and. (h13b .lt. h11b) .and. (h11b .le. h16b) . 162 &and. (h16b .lt. h12b)) THEN 163 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 164 &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 165 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 166 &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 167 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 168 &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 169 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 170 &6b-1),int_mb(k_range+h12b-1),7,5,4,3,2,8,6,1,1.0d0) 171 END IF 172 IF ((p8b .lt. p5b) .and. (h16b .lt. h11b)) THEN 173 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 174 &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 175 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 176 &* (p5b_1 - noab - 1 + nvab * (p8b_1 - noab - 1))))))))) 177 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p8b-1) 178 &,int_mb(k_range+p5b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 179 &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1 180 &1b-1),int_mb(k_range+h12b-1),6,5,4,3,2,8,7,1,-1.0d0) 181 END IF 182 IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h12b .le. h13b)) T 183 &HEN 184 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 185 &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 186 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 187 &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 188 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 189 &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 190 &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1 191 &3b-1),int_mb(k_range+h16b-1),8,7,4,3,1,6,5,2,1.0d0) 192 END IF 193 IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h11b .le. h13b) .a 194 &nd. (h13b .lt. h12b) .and. (h12b .le. h16b)) THEN 195 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 196 &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 197 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 198 &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 199 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 200 &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 201 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 202 &2b-1),int_mb(k_range+h16b-1),8,6,4,3,1,7,5,2,-1.0d0) 203 END IF 204 IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h11b .le. h13b) .a 205 &nd. (h16b .lt. h12b)) THEN 206 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 207 &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 208 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 209 &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 210 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 211 &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 212 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 213 &6b-1),int_mb(k_range+h12b-1),7,6,4,3,1,8,5,2,1.0d0) 214 END IF 215 IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h13b .lt. h11b) .a 216 &nd. (h12b .le. h16b)) THEN 217 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 218 &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 219 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 220 &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 221 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 222 &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 223 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 224 &2b-1),int_mb(k_range+h16b-1),8,5,4,3,1,7,6,2,1.0d0) 225 END IF 226 IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h13b .lt. h11b) .a 227 &nd. (h11b .le. h16b) .and. (h16b .lt. h12b)) THEN 228 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 229 &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 230 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 231 &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 232 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 233 &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 234 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 235 &6b-1),int_mb(k_range+h12b-1),7,5,4,3,1,8,6,2,-1.0d0) 236 END IF 237 IF ((p5b .le. p8b) .and. (p8b .le. p15b) .and. (h16b .lt. h11b)) T 238 &HEN 239 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 240 &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 241 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p15b_1 - noab - 1 + nvab 242 &* (p8b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 243 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 244 &,int_mb(k_range+p8b-1),int_mb(k_range+p15b-1),int_mb(k_range+p17b- 245 &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1 246 &1b-1),int_mb(k_range+h12b-1),6,5,4,3,1,8,7,2,1.0d0) 247 END IF 248 IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h12b .le. h13b)) 249 &THEN 250 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 251 &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 252 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * 253 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 254 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 255 &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b- 256 &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1 257 &3b-1),int_mb(k_range+h16b-1),8,7,4,2,1,6,5,3,-1.0d0) 258 END IF 259 IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h11b .le. h13b) . 260 &and. (h13b .lt. h12b) .and. (h12b .le. h16b)) THEN 261 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 262 &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 263 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * 264 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 265 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 266 &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b- 267 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 268 &2b-1),int_mb(k_range+h16b-1),8,6,4,2,1,7,5,3,1.0d0) 269 END IF 270 IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h11b .le. h13b) . 271 &and. (h16b .lt. h12b)) THEN 272 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 273 &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 274 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * 275 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 276 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 277 &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b- 278 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 279 &6b-1),int_mb(k_range+h12b-1),7,6,4,2,1,8,5,3,-1.0d0) 280 END IF 281 IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h13b .lt. h11b) . 282 &and. (h12b .le. h16b)) THEN 283 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 284 &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 285 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * 286 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 287 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 288 &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b- 289 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 290 &2b-1),int_mb(k_range+h16b-1),8,5,4,2,1,7,6,3,-1.0d0) 291 END IF 292 IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h13b .lt. h11b) . 293 &and. (h11b .le. h16b) .and. (h16b .lt. h12b)) THEN 294 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 295 &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 296 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * 297 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 298 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 299 &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b- 300 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 301 &6b-1),int_mb(k_range+h12b-1),7,5,4,2,1,8,6,3,1.0d0) 302 END IF 303 IF ((p15b .lt. p8b) .and. (p8b .le. p17b) .and. (h16b .lt. h11b)) 304 &THEN 305 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 306 &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 307 & 1 + noab * (p17b_1 - noab - 1 + nvab * (p8b_1 - noab - 1 + nvab * 308 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 309 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 310 &,int_mb(k_range+p15b-1),int_mb(k_range+p8b-1),int_mb(k_range+p17b- 311 &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1 312 &1b-1),int_mb(k_range+h12b-1),6,5,4,2,1,8,7,3,-1.0d0) 313 END IF 314 IF ((p17b .lt. p8b) .and. (h12b .le. h13b)) THEN 315 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 316 &1 - 1 + noab * (h13b_1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 317 & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * 318 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 319 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 320 &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b- 321 &1),int_mb(k_range+h11b-1),int_mb(k_range+h12b-1),int_mb(k_range+h1 322 &3b-1),int_mb(k_range+h16b-1),8,7,3,2,1,6,5,4,1.0d0) 323 END IF 324 IF ((p17b .lt. p8b) .and. (h11b .le. h13b) .and. (h13b .lt. h12b) 325 &.and. (h12b .le. h16b)) THEN 326 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 327 &1 - 1 + noab * (h12b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 328 & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * 329 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 330 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 331 &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b- 332 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 333 &2b-1),int_mb(k_range+h16b-1),8,6,3,2,1,7,5,4,-1.0d0) 334 END IF 335 IF ((p17b .lt. p8b) .and. (h11b .le. h13b) .and. (h16b .lt. h12b)) 336 & THEN 337 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 338 &1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 1 + noab * (h11b_1 - 339 & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * 340 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 341 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 342 &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b- 343 &1),int_mb(k_range+h11b-1),int_mb(k_range+h13b-1),int_mb(k_range+h1 344 &6b-1),int_mb(k_range+h12b-1),7,6,3,2,1,8,5,4,1.0d0) 345 END IF 346 IF ((p17b .lt. p8b) .and. (h13b .lt. h11b) .and. (h12b .le. h16b)) 347 & THEN 348 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 349 &1 - 1 + noab * (h12b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 350 & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * 351 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 352 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 353 &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b- 354 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 355 &2b-1),int_mb(k_range+h16b-1),8,5,3,2,1,7,6,4,1.0d0) 356 END IF 357 IF ((p17b .lt. p8b) .and. (h13b .lt. h11b) .and. (h11b .le. h16b) 358 &.and. (h16b .lt. h12b)) THEN 359 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 360 &1 - 1 + noab * (h16b_1 - 1 + noab * (h11b_1 - 1 + noab * (h13b_1 - 361 & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * 362 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 363 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 364 &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b- 365 &1),int_mb(k_range+h13b-1),int_mb(k_range+h11b-1),int_mb(k_range+h1 366 &6b-1),int_mb(k_range+h12b-1),7,5,3,2,1,8,6,4,-1.0d0) 367 END IF 368 IF ((p17b .lt. p8b) .and. (h16b .lt. h11b)) THEN 369 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h12b_ 370 &1 - 1 + noab * (h11b_1 - 1 + noab * (h16b_1 - 1 + noab * (h13b_1 - 371 & 1 + noab * (p8b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * 372 & (p15b_1 - noab - 1 + nvab * (p5b_1 - noab - 1))))))))) 373 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 374 &,int_mb(k_range+p15b-1),int_mb(k_range+p17b-1),int_mb(k_range+p8b- 375 &1),int_mb(k_range+h13b-1),int_mb(k_range+h16b-1),int_mb(k_range+h1 376 &1b-1),int_mb(k_range+h12b-1),6,5,3,2,1,8,7,4,1.0d0) 377 END IF 378 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsdtq_y2_23_4',3,MA_ 379 &ERR) 380 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 381 & ERRQUIT('eomccsdtq_y2_23_4',4,MA_ERR) 382 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 383 &eomccsdtq_y2_23_4',5,MA_ERR) 384 IF ((p8b .lt. p1b)) THEN 385 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 386 & - 1 + (noab+nvab) * (p8b_2 - 1 + (noab+nvab) * (h12b_2 - 1 + (noa 387 &b+nvab) * (h11b_2 - 1))))) 388 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h11b-1 389 &),int_mb(k_range+h12b-1),int_mb(k_range+p8b-1),int_mb(k_range+p1b- 390 &1),4,2,1,3,-1.0d0) 391 END IF 392 IF ((p1b .le. p8b)) THEN 393 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2 394 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h12b_2 - 1 + (noa 395 &b+nvab) * (h11b_2 - 1))))) 396 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h11b-1 397 &),int_mb(k_range+h12b-1),int_mb(k_range+p1b-1),int_mb(k_range+p8b- 398 &1),3,2,1,4,1.0d0) 399 END IF 400 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsdtq_y2_23_4',6,MA_ 401 &ERR) 402 nsubh(1) = 1 403 nsubh(2) = 1 404 isubh = 1 405 IF (h11b .eq. h12b) THEN 406 nsubh(isubh) = nsubh(isubh) + 1 407 ELSE 408 isubh = isubh + 1 409 END IF 410 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 411 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 412 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 413 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsdtq_y2_23_4', 414 &7,MA_ERR) 415 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsdtq_y2_23_4', 416 &8,MA_ERR) 417 END IF 418 END IF 419 END IF 420 END DO 421 END DO 422 END DO 423 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 424 &eomccsdtq_y2_23_4',9,MA_ERR) 425 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 426 &,int_mb(k_range+h16b-1),int_mb(k_range+h13b-1),int_mb(k_range+p17b 427 &-1),int_mb(k_range+p15b-1),int_mb(k_range+p5b-1),6,5,4,1,3,2,-1.0d 428 &0/6.0d0) 429 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h16b 430 &- 1 + noab * (h13b - 1 + noab * (p1b - noab - 1 + nvab * (p17b - n 431 &oab - 1 + nvab * (p15b - noab - 1 + nvab * (p5b - noab - 1))))))) 432 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsdtq_y2_23_4',10,MA 433 &_ERR) 434 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsdtq_y2_23_4', 435 &11,MA_ERR) 436 END IF 437 END IF 438 END IF 439 next = NXTASK(nprocs,1) 440 END IF 441 count = count + 1 442 END DO 443 END DO 444 END DO 445 END DO 446 END DO 447 END DO 448 next = NXTASK(-nprocs,1) 449 call GA_SYNC() 450 RETURN 451 END 452