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