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