1 SUBROUTINE ccsdt2_q_left(a_i0,d_f1,d_i1_2,d_i1_3,d_i1_4,d_t1,d_v2, 2 &d_y2,d_y3,k_f1_offset,k_i1_offset_2,k_i1_offset_3,k_i1_offset_4,k_ 3 &t1_offset,k_v2_offset,k_y2_offset,k_y3_offset,l_i1_offset_2,l_i1_o 4 &ffset_3,l_i1_offset_4,t_h5b,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_ 5 &p4b,toggle) 6C $Id$ 7C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 8C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 9C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yv + = 1 * P( 36 ) * y ( h5 h6 p1 p2 )_y * v ( h7 h8 p3 p4 )_v 10C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yf + = 1 * P( 16 ) * y ( h5 h6 h7 p1 p2 p3 )_y * i1 ( h8 p4 )_f 11C i1 ( h5 p1 )_f + = 1 * f ( h5 p1 )_f 12C i1 ( h5 p1 )_vt + = 1 * Sum ( h10 p9 ) * t ( p9 h10 )_t * v ( h5 h10 p1 p9 )_v 13C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yv + = -1 * P( 24 ) * Sum ( h11 ) * y ( h5 h6 h11 p1 p2 p3 )_y * i1 ( h7 h8 h11 p4 )_v 14C i1 ( h5 h6 h11 p1 )_v + = 1 * v ( h5 h6 h11 p1 )_v 15C i1 ( h5 h6 h11 p1 )_vt + = -1 * Sum ( p9 ) * t ( p9 h11 )_t * v ( h5 h6 p1 p9 )_v 16C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yv + = -1 * P( 24 ) * Sum ( p9 ) * y ( h5 h6 h7 p1 p2 p9 )_y * i1 ( h8 p9 p3 p4 )_v 17C i1 ( h5 p9 p1 p2 )_v + = 1 * v ( h5 p9 p1 p2 )_v 18C i1 ( h5 p9 p1 p2 )_vt + = -1 * Sum ( h10 ) * t ( p9 h10 )_t * v ( h5 h10 p1 p2 )_v 19 IMPLICIT NONE 20#include "global.fh" 21#include "mafdecls.fh" 22#include "util.fh" 23#include "errquit.fh" 24#include "tce.fh" 25 INTEGER t_h5b 26 INTEGER t_h6b 27 INTEGER t_h7b 28 INTEGER t_h8b 29 INTEGER t_p1b 30 INTEGER t_p2b 31 INTEGER t_p3b 32 INTEGER t_p4b 33 INTEGER toggle 34 INTEGER d_y2 35 INTEGER k_y2_offset 36 INTEGER d_v2 37 INTEGER k_v2_offset 38 INTEGER d_y3 39 INTEGER k_y3_offset 40 INTEGER d_i1_2 41 INTEGER k_i1_offset_2 42 INTEGER l_i1_offset_2 43 INTEGER d_i1_3 44 INTEGER k_i1_offset_3 45 INTEGER l_i1_offset_3 46 INTEGER d_i1_4 47 INTEGER k_i1_offset_4 48 INTEGER l_i1_offset_4 49 INTEGER d_f1 50 INTEGER k_f1_offset 51 INTEGER size_i1_2 52 INTEGER d_t1 53 INTEGER k_t1_offset 54 INTEGER size_i1_3 55 INTEGER size_i1_4 56 DOUBLE PRECISION a_i0(*) 57 CHARACTER*255 filename 58 IF (toggle .eq. 3) THEN 59 CALL DELETEFILE(d_i1_4) 60 IF (.not.MA_POP_STACK(l_i1_offset_4)) CALL ERRQUIT('ccsdt2_q_left' 61 &,-1,MA_ERR) 62 END IF 63 IF (toggle .eq. 3) THEN 64 CALL DELETEFILE(d_i1_3) 65 IF (.not.MA_POP_STACK(l_i1_offset_3)) CALL ERRQUIT('ccsdt2_q_left' 66 &,-1,MA_ERR) 67 END IF 68 IF (toggle .eq. 3) THEN 69 CALL DELETEFILE(d_i1_2) 70 IF (.not.MA_POP_STACK(l_i1_offset_2)) CALL ERRQUIT('ccsdt2_q_left' 71 &,-1,MA_ERR) 72 END IF 73 IF (toggle .eq. 2) CALL ccsdt2_q_left_1(d_y2,k_y2_offset,d_v2,k_v2 74 &_offset,a_i0,t_h5b,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 75 IF (toggle .eq. 1) CALL OFFSET_ccsdt2_q_left_2_1(l_i1_offset_2,k_i 76 &1_offset_2,size_i1_2) 77 IF (toggle .eq. 1) CALL TCE_FILENAME('ccsdt2_q_left_2_1_i1',filena 78 &me) 79 IF (toggle .eq. 1) CALL CREATEFILE(filename,d_i1_2,size_i1_2) 80 IF (toggle .eq. 1) CALL ccsdt2_q_left_2_1(d_f1,k_f1_offset,d_i1_2, 81 &k_i1_offset_2) 82 IF (toggle .eq. 1) CALL ccsdt2_q_left_2_2(d_t1,k_t1_offset,d_v2,k_ 83 &v2_offset,d_i1_2,k_i1_offset_2) 84 IF (toggle .eq. 1) CALL RECONCILEFILE(d_i1_2,size_i1_2) 85 IF (toggle .eq. 2) CALL ccsdt2_q_left_2(d_y3,k_y3_offset,d_i1_2,k_ 86 &i1_offset_2,a_i0,t_h5b,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 87 IF (toggle .eq. 1) CALL OFFSET_ccsdt2_q_left_3_1(l_i1_offset_3,k_i 88 &1_offset_3,size_i1_3) 89 IF (toggle .eq. 1) CALL TCE_FILENAME('ccsdt2_q_left_3_1_i1',filena 90 &me) 91 IF (toggle .eq. 1) CALL CREATEFILE(filename,d_i1_3,size_i1_3) 92 IF (toggle .eq. 1) CALL ccsdt2_q_left_3_1(d_v2,k_v2_offset,d_i1_3, 93 &k_i1_offset_3) 94 IF (toggle .eq. 1) CALL ccsdt2_q_left_3_2(d_t1,k_t1_offset,d_v2,k_ 95 &v2_offset,d_i1_3,k_i1_offset_3) 96 IF (toggle .eq. 1) CALL RECONCILEFILE(d_i1_3,size_i1_3) 97 IF (toggle .eq. 2) CALL ccsdt2_q_left_3(d_y3,k_y3_offset,d_i1_3,k_ 98 &i1_offset_3,a_i0,t_h5b,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 99 IF (toggle .eq. 1) CALL OFFSET_ccsdt2_q_left_4_1(l_i1_offset_4,k_i 100 &1_offset_4,size_i1_4) 101 IF (toggle .eq. 1) CALL TCE_FILENAME('ccsdt2_q_left_4_1_i1',filena 102 &me) 103 IF (toggle .eq. 1) CALL CREATEFILE(filename,d_i1_4,size_i1_4) 104 IF (toggle .eq. 1) CALL ccsdt2_q_left_4_1(d_v2,k_v2_offset,d_i1_4, 105 &k_i1_offset_4) 106 IF (toggle .eq. 1) CALL ccsdt2_q_left_4_2(d_t1,k_t1_offset,d_v2,k_ 107 &v2_offset,d_i1_4,k_i1_offset_4) 108 IF (toggle .eq. 1) CALL RECONCILEFILE(d_i1_4,size_i1_4) 109 IF (toggle .eq. 2) CALL ccsdt2_q_left_4(d_y3,k_y3_offset,d_i1_4,k_ 110 &i1_offset_4,a_i0,t_h5b,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 111 RETURN 112 END 113 SUBROUTINE ccsdt2_q_left_1(d_a,k_a_offset,d_b,k_b_offset,a_c,t_h5b 114 &,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 115C $Id$ 116C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 117C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 118C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yv + = 1 * P( 36 ) * y ( h5 h6 p1 p2 )_y * v ( h7 h8 p3 p4 )_v 119 IMPLICIT NONE 120#include "global.fh" 121#include "mafdecls.fh" 122#include "sym.fh" 123#include "errquit.fh" 124#include "tce.fh" 125 INTEGER d_a 126 INTEGER k_a_offset 127 INTEGER d_b 128 INTEGER k_b_offset 129 INTEGER t_h5b 130 INTEGER t_h6b 131 INTEGER t_h7b 132 INTEGER t_h8b 133 INTEGER t_p1b 134 INTEGER t_p2b 135 INTEGER t_p3b 136 INTEGER t_p4b 137 INTEGER h5b 138 INTEGER h6b 139 INTEGER h7b 140 INTEGER h8b 141 INTEGER p1b 142 INTEGER p2b 143 INTEGER p3b 144 INTEGER p4b 145 INTEGER dimc 146 INTEGER l_c_sort 147 INTEGER k_c_sort 148 INTEGER h5b_1 149 INTEGER h6b_1 150 INTEGER p1b_1 151 INTEGER p2b_1 152 INTEGER h7b_2 153 INTEGER h8b_2 154 INTEGER p3b_2 155 INTEGER p4b_2 156 INTEGER dim_common 157 INTEGER dima_sort 158 INTEGER dima 159 INTEGER dimb_sort 160 INTEGER dimb 161 INTEGER l_a_sort 162 INTEGER k_a_sort 163 INTEGER l_a 164 INTEGER k_a 165 INTEGER l_b_sort 166 INTEGER k_b_sort 167 INTEGER l_b 168 INTEGER k_b 169 DOUBLE PRECISION a_c(*) 170 LOGICAL skipped 171 DO h5b = 1,noab 172 DO h6b = h5b,noab 173 DO h7b = 1,noab 174 DO h8b = h7b,noab 175 DO p1b = noab+1,noab+nvab 176 DO p2b = p1b,noab+nvab 177 DO p3b = noab+1,noab+nvab 178 DO p4b = p3b,noab+nvab 179 skipped = .true. 180 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 181 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 182 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 183 &e. 184 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 185 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 186 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 187 &e. 188 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 189 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 190 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 191 &e. 192 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 193 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 194 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 195 &e. 196 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 197 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 198 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 199 &e. 200 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 201 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 202 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 203 &e. 204 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 205 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 206 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 207 &e. 208 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 209 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 210 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 211 &e. 212 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 213 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 214 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 215 &e. 216 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 217 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 218 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 219 &e. 220 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 221 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 222 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 223 &e. 224 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 225 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 226 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 227 &e. 228 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 229 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 230 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 231 &e. 232 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 233 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 234 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 235 &e. 236 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 237 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 238 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 239 &e. 240 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 241 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 242 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 243 &e. 244 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 245 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 246 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 247 &e. 248 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 249 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 250 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 251 &e. 252 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 253 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 254 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 255 &e. 256 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 257 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 258 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 259 &e. 260 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 261 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 262 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 263 &e. 264 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 265 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 266 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 267 &e. 268 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 269 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 270 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 271 &e. 272 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 273 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 274 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 275 &e. 276 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 277 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 278 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 279 &e. 280 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 281 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 282 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 283 &e. 284 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 285 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 286 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 287 &e. 288 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 289 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 290 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 291 &e. 292 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 293 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 294 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 295 &e. 296 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 297 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 298 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 299 &e. 300 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 301 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 302 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 303 &e. 304 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 305 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 306 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 307 &e. 308 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 309 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 310 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 311 &e. 312 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 313 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 314 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 315 &e. 316 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 317 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 318 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 319 &e. 320 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 321 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 322 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 323 &e. 324 IF (.not.skipped) THEN 325 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 326 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1)+int_mb(k_spin+p1b-1)+i 327 &nt_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1).ne.1 328 &6)) THEN 329 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) 330 &+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b- 331 &1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1)) THEN 332 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 333 &k_sym+h7b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+p1b-1),ieo 334 &r(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p4b-1) 335 &))))))) .eq. ieor(irrep_y,irrep_v)) THEN 336 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 337 &nge+h7b-1) * int_mb(k_range+h8b-1) * int_mb(k_range+p1b-1) * int_m 338 &b(k_range+p2b-1) * int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) 339 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 340 & ERRQUIT('ccsdt2_q_left_1',0,MA_ERR) 341 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 342 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p 343 &1b-1)+int_mb(k_spin+p2b-1)) THEN 344 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 345 &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. irrep_y) THEN 346 CALL TCE_RESTRICTED_4(h5b,h6b,p1b,p2b,h5b_1,h6b_1,p1b_1,p2b_1) 347 CALL TCE_RESTRICTED_4(h7b,h8b,p3b,p4b,h7b_2,h8b_2,p3b_2,p4b_2) 348 dim_common = 1 349 dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 350 &(k_range+p1b-1) * int_mb(k_range+p2b-1) 351 dima = dim_common * dima_sort 352 dimb_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h8b-1) * int_mb 353 &(k_range+p3b-1) * int_mb(k_range+p4b-1) 354 dimb = dim_common * dimb_sort 355 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 356 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 357 & ERRQUIT('ccsdt2_q_left_1',1,MA_ERR) 358 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 359 &ccsdt2_q_left_1',2,MA_ERR) 360 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 361 & - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (h6b_1 - 1 + noab 362 &* (h5b_1 - 1))))) 363 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 364 &,int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1) 365 &,4,3,2,1,1.0d0) 366 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_1',3,MA_ER 367 &R) 368 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 369 & ERRQUIT('ccsdt2_q_left_1',4,MA_ERR) 370 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 371 &ccsdt2_q_left_1',5,MA_ERR) 372 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 373 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab 374 &+nvab) * (h7b_2 - 1))))) 375 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 376 &,int_mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 377 &,4,3,2,1,1.0d0) 378 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt2_q_left_1',6,MA_ER 379 &R) 380 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 381 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 382 &t),dima_sort) 383 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt2_q_left_1',7, 384 &MA_ERR) 385 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_1',8, 386 &MA_ERR) 387 END IF 388 END IF 389 END IF 390 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 391 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 392 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 393 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 394 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 395 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 396 &mb(k_range+h5b-1),8,7,4,3,6,5,2,1,1.0d0) 397 END IF 398 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 399 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 400 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 401 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 402 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 403 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 404 &mb(k_range+h5b-1),8,7,4,3,2,6,5,1,1.0d0) 405 END IF 406 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 407 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 408 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 409 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 410 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 411 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 412 &mb(k_range+h5b-1),8,7,4,3,2,6,1,5,-1.0d0) 413 END IF 414 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 415 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 416 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 417 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 418 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 419 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 420 &mb(k_range+h5b-1),8,7,4,3,6,2,5,1,-1.0d0) 421 END IF 422 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 423 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 424 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 425 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 426 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 427 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 428 &mb(k_range+h5b-1),8,7,4,3,6,2,1,5,1.0d0) 429 END IF 430 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 431 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 432 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 433 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 434 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 435 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 436 &mb(k_range+h5b-1),8,7,4,3,2,1,6,5,1.0d0) 437 END IF 438 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 439 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 440 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 441 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 442 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 443 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 444 &mb(k_range+h5b-1),4,8,7,3,6,5,2,1,1.0d0) 445 END IF 446 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 447 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 448 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 449 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 450 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 451 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 452 &mb(k_range+h5b-1),4,8,7,3,2,6,5,1,1.0d0) 453 END IF 454 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 455 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 456 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 457 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 458 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 459 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 460 &mb(k_range+h5b-1),4,8,7,3,2,6,1,5,-1.0d0) 461 END IF 462 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 463 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 464 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 465 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 466 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 467 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 468 &mb(k_range+h5b-1),4,8,7,3,6,2,5,1,-1.0d0) 469 END IF 470 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 471 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 472 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 473 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 474 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 475 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 476 &mb(k_range+h5b-1),4,8,7,3,6,2,1,5,1.0d0) 477 END IF 478 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 479 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 480 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 481 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 482 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 483 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 484 &mb(k_range+h5b-1),4,8,7,3,2,1,6,5,1.0d0) 485 END IF 486 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 487 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 488 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 489 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 490 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 491 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 492 &mb(k_range+h5b-1),4,8,3,7,6,5,2,1,-1.0d0) 493 END IF 494 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 495 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 496 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 497 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 498 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 499 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 500 &mb(k_range+h5b-1),4,8,3,7,2,6,5,1,-1.0d0) 501 END IF 502 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 503 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 504 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 505 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 506 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 507 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 508 &mb(k_range+h5b-1),4,8,3,7,2,6,1,5,1.0d0) 509 END IF 510 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 511 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 512 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 513 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 514 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 515 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 516 &mb(k_range+h5b-1),4,8,3,7,6,2,5,1,1.0d0) 517 END IF 518 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 519 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 520 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 521 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 522 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 523 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 524 &mb(k_range+h5b-1),4,8,3,7,6,2,1,5,-1.0d0) 525 END IF 526 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 527 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 528 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 529 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 530 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 531 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 532 &mb(k_range+h5b-1),4,8,3,7,2,1,6,5,-1.0d0) 533 END IF 534 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 535 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 536 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 537 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 538 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 539 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 540 &mb(k_range+h5b-1),8,4,7,3,6,5,2,1,-1.0d0) 541 END IF 542 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 543 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 544 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 545 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 546 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 547 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 548 &mb(k_range+h5b-1),8,4,7,3,2,6,5,1,-1.0d0) 549 END IF 550 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 551 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 552 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 553 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 554 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 555 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 556 &mb(k_range+h5b-1),8,4,7,3,2,6,1,5,1.0d0) 557 END IF 558 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 559 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 560 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 561 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 562 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 563 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 564 &mb(k_range+h5b-1),8,4,7,3,6,2,5,1,1.0d0) 565 END IF 566 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 567 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 568 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 569 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 570 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 571 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 572 &mb(k_range+h5b-1),8,4,7,3,6,2,1,5,-1.0d0) 573 END IF 574 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 575 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 576 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 577 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 578 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 579 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 580 &mb(k_range+h5b-1),8,4,7,3,2,1,6,5,-1.0d0) 581 END IF 582 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 583 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 584 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 585 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 586 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 587 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 588 &mb(k_range+h5b-1),8,4,3,7,6,5,2,1,1.0d0) 589 END IF 590 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 591 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 592 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 593 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 594 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 595 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 596 &mb(k_range+h5b-1),8,4,3,7,2,6,5,1,1.0d0) 597 END IF 598 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 599 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 600 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 601 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 602 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 603 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 604 &mb(k_range+h5b-1),8,4,3,7,2,6,1,5,-1.0d0) 605 END IF 606 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 607 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 608 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 609 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 610 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 611 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 612 &mb(k_range+h5b-1),8,4,3,7,6,2,5,1,-1.0d0) 613 END IF 614 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 615 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 616 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 617 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 618 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 619 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 620 &mb(k_range+h5b-1),8,4,3,7,6,2,1,5,1.0d0) 621 END IF 622 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 623 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 624 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 625 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 626 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 627 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 628 &mb(k_range+h5b-1),8,4,3,7,2,1,6,5,1.0d0) 629 END IF 630 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 631 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 632 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 633 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 634 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 635 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 636 &mb(k_range+h5b-1),4,3,8,7,6,5,2,1,1.0d0) 637 END IF 638 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 639 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 640 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 641 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 642 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 643 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 644 &mb(k_range+h5b-1),4,3,8,7,2,6,5,1,1.0d0) 645 END IF 646 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 647 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 648 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 649 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 650 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 651 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 652 &mb(k_range+h5b-1),4,3,8,7,2,6,1,5,-1.0d0) 653 END IF 654 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 655 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 656 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 657 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 658 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 659 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 660 &mb(k_range+h5b-1),4,3,8,7,6,2,5,1,-1.0d0) 661 END IF 662 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 663 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 664 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 665 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 666 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 667 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 668 &mb(k_range+h5b-1),4,3,8,7,6,2,1,5,1.0d0) 669 END IF 670 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 671 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 672 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 673 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 674 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_ 675 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 676 &mb(k_range+h5b-1),4,3,8,7,2,1,6,5,1.0d0) 677 END IF 678 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt2_q_left_1',9, 679 &MA_ERR) 680 END IF 681 END IF 682 END IF 683 END IF 684 END DO 685 END DO 686 END DO 687 END DO 688 END DO 689 END DO 690 END DO 691 END DO 692 RETURN 693 END 694 SUBROUTINE ccsdt2_q_left_2(d_a,k_a_offset,d_b,k_b_offset,a_c,t_h5b 695 &,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 696C $Id$ 697C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 698C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 699C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yf + = 1 * P( 16 ) * y ( h5 h6 h7 p1 p2 p3 )_y * i1 ( h8 p4 )_f 700 IMPLICIT NONE 701#include "global.fh" 702#include "mafdecls.fh" 703#include "sym.fh" 704#include "errquit.fh" 705#include "tce.fh" 706 INTEGER d_a 707 INTEGER k_a_offset 708 INTEGER d_b 709 INTEGER k_b_offset 710 INTEGER t_h5b 711 INTEGER t_h6b 712 INTEGER t_h7b 713 INTEGER t_h8b 714 INTEGER t_p1b 715 INTEGER t_p2b 716 INTEGER t_p3b 717 INTEGER t_p4b 718 INTEGER h5b 719 INTEGER h6b 720 INTEGER h7b 721 INTEGER h8b 722 INTEGER p1b 723 INTEGER p2b 724 INTEGER p3b 725 INTEGER p4b 726 INTEGER dimc 727 INTEGER l_c_sort 728 INTEGER k_c_sort 729 INTEGER h5b_1 730 INTEGER h6b_1 731 INTEGER h7b_1 732 INTEGER p1b_1 733 INTEGER p2b_1 734 INTEGER p3b_1 735 INTEGER h8b_2 736 INTEGER p4b_2 737 INTEGER dim_common 738 INTEGER dima_sort 739 INTEGER dima 740 INTEGER dimb_sort 741 INTEGER dimb 742 INTEGER l_a_sort 743 INTEGER k_a_sort 744 INTEGER l_a 745 INTEGER k_a 746 INTEGER l_b_sort 747 INTEGER k_b_sort 748 INTEGER l_b 749 INTEGER k_b 750 DOUBLE PRECISION a_c(*) 751 LOGICAL skipped 752 DO h5b = 1,noab 753 DO h6b = h5b,noab 754 DO h7b = h6b,noab 755 DO h8b = 1,noab 756 DO p1b = noab+1,noab+nvab 757 DO p2b = p1b,noab+nvab 758 DO p3b = p2b,noab+nvab 759 DO p4b = noab+1,noab+nvab 760 skipped = .true. 761 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 762 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 763 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 764 &e. 765 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 766 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 767 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 768 &e. 769 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 770 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 771 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 772 &e. 773 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 774 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 775 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 776 &e. 777 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 778 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 779 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 780 &e. 781 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 782 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 783 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 784 &e. 785 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 786 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 787 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 788 &e. 789 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 790 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 791 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 792 &e. 793 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 794 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 795 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 796 &e. 797 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 798 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 799 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 800 &e. 801 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 802 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 803 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 804 &e. 805 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 806 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 807 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 808 &e. 809 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 810 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 811 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 812 &e. 813 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 814 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 815 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 816 &e. 817 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 818 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 819 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 820 &e. 821 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 822 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 823 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 824 &e. 825 IF (.not.skipped) THEN 826 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 827 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1)+int_mb(k_spin+p1b-1)+i 828 &nt_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1).ne.1 829 &6)) THEN 830 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) 831 &+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b- 832 &1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1)) THEN 833 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 834 &k_sym+h7b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+p1b-1),ieo 835 &r(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p4b-1) 836 &))))))) .eq. ieor(irrep_y,irrep_f)) THEN 837 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 838 &nge+h7b-1) * int_mb(k_range+h8b-1) * int_mb(k_range+p1b-1) * int_m 839 &b(k_range+p2b-1) * int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) 840 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 841 & ERRQUIT('ccsdt2_q_left_2',0,MA_ERR) 842 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 843 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) 844 & .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b- 845 &1)) THEN 846 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 847 &k_sym+h7b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),int 848 &_mb(k_sym+p3b-1)))))) .eq. irrep_y) THEN 849 CALL TCE_RESTRICTED_6(h5b,h6b,h7b,p1b,p2b,p3b,h5b_1,h6b_1,h7b_1,p1 850 &b_1,p2b_1,p3b_1) 851 CALL TCE_RESTRICTED_2(h8b,p4b,h8b_2,p4b_2) 852 dim_common = 1 853 dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 854 &(k_range+h7b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * 855 &int_mb(k_range+p3b-1) 856 dima = dim_common * dima_sort 857 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p4b-1) 858 dimb = dim_common * dimb_sort 859 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 860 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 861 & ERRQUIT('ccsdt2_q_left_2',1,MA_ERR) 862 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 863 &ccsdt2_q_left_2',2,MA_ERR) 864 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1 865 & - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 866 &+ nvab * (h7b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1))))))) 867 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 868 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),int_mb(k_range+p1b-1) 869 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),6,5,4,3,2,1,1.0d0) 870 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_2',3,MA_ER 871 &R) 872 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 873 & ERRQUIT('ccsdt2_q_left_2',4,MA_ERR) 874 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 875 &ccsdt2_q_left_2',5,MA_ERR) 876 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 877 & - noab - 1 + nvab * (h8b_2 - 1))) 878 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 879 &,int_mb(k_range+p4b-1),2,1,1.0d0) 880 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt2_q_left_2',6,MA_ER 881 &R) 882 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 883 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 884 &t),dima_sort) 885 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt2_q_left_2',7, 886 &MA_ERR) 887 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_2',8, 888 &MA_ERR) 889 END IF 890 END IF 891 END IF 892 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 893 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 894 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 895 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 896 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 897 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 898 &mb(k_range+h5b-1),8,7,6,2,5,4,3,1,1.0d0) 899 END IF 900 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 901 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 902 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 903 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 904 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 905 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 906 &mb(k_range+h5b-1),8,7,6,2,1,5,4,3,-1.0d0) 907 END IF 908 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 909 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 910 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 911 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 912 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 913 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 914 &mb(k_range+h5b-1),8,7,6,2,5,1,4,3,1.0d0) 915 END IF 916 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 917 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 918 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 919 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 920 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 921 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 922 &mb(k_range+h5b-1),8,7,6,2,5,4,1,3,-1.0d0) 923 END IF 924 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 925 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 926 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 927 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 928 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 929 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 930 &mb(k_range+h5b-1),2,8,7,6,5,4,3,1,-1.0d0) 931 END IF 932 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 933 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 934 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 935 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 936 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 937 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 938 &mb(k_range+h5b-1),2,8,7,6,1,5,4,3,1.0d0) 939 END IF 940 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 941 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 942 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 943 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 944 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 945 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 946 &mb(k_range+h5b-1),2,8,7,6,5,1,4,3,-1.0d0) 947 END IF 948 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 949 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 950 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 951 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 952 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 953 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 954 &mb(k_range+h5b-1),2,8,7,6,5,4,1,3,1.0d0) 955 END IF 956 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 957 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 958 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 959 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 960 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 961 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 962 &mb(k_range+h5b-1),8,2,7,6,5,4,3,1,1.0d0) 963 END IF 964 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 965 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 966 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 967 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 968 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 969 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 970 &mb(k_range+h5b-1),8,2,7,6,1,5,4,3,-1.0d0) 971 END IF 972 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 973 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 974 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 975 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 976 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 977 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 978 &mb(k_range+h5b-1),8,2,7,6,5,1,4,3,1.0d0) 979 END IF 980 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 981 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 982 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 983 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 984 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 985 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 986 &mb(k_range+h5b-1),8,2,7,6,5,4,1,3,-1.0d0) 987 END IF 988 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 989 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 990 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 991 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 992 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 993 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 994 &mb(k_range+h5b-1),8,7,2,6,5,4,3,1,-1.0d0) 995 END IF 996 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 997 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 998 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 999 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1000 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 1001 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 1002 &mb(k_range+h5b-1),8,7,2,6,1,5,4,3,1.0d0) 1003 END IF 1004 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 1005 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1006 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1007 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1008 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 1009 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 1010 &mb(k_range+h5b-1),8,7,2,6,5,1,4,3,-1.0d0) 1011 END IF 1012 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 1013 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1014 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 1015 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1016 &mb(k_range+h8b-1),int_mb(k_range+p3b-1),int_mb(k_range+p2b-1),int_ 1017 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 1018 &mb(k_range+h5b-1),8,7,2,6,5,4,1,3,1.0d0) 1019 END IF 1020 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt2_q_left_2',9, 1021 &MA_ERR) 1022 END IF 1023 END IF 1024 END IF 1025 END IF 1026 END DO 1027 END DO 1028 END DO 1029 END DO 1030 END DO 1031 END DO 1032 END DO 1033 END DO 1034 RETURN 1035 END 1036 SUBROUTINE ccsdt2_q_left_2_1(d_a,k_a_offset,d_c,k_c_offset) 1037C $Id$ 1038C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1039C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1040C i1 ( h5 p1 )_f + = 1 * f ( h5 p1 )_f 1041 IMPLICIT NONE 1042#include "global.fh" 1043#include "mafdecls.fh" 1044#include "sym.fh" 1045#include "errquit.fh" 1046#include "tce.fh" 1047 INTEGER d_a 1048 INTEGER k_a_offset 1049 INTEGER d_c 1050 INTEGER k_c_offset 1051 INTEGER nxtask 1052 INTEGER next 1053 INTEGER nprocs 1054 INTEGER count 1055 INTEGER h5b 1056 INTEGER p1b 1057 INTEGER dimc 1058 INTEGER h5b_1 1059 INTEGER p1b_1 1060 INTEGER dim_common 1061 INTEGER dima_sort 1062 INTEGER dima 1063 INTEGER l_a_sort 1064 INTEGER k_a_sort 1065 INTEGER l_a 1066 INTEGER k_a 1067 INTEGER l_c 1068 INTEGER k_c 1069 EXTERNAL nxtask 1070 nprocs = GA_NNODES() 1071 count = 0 1072 next = nxtask(nprocs,1) 1073 DO h5b = 1,noab 1074 DO p1b = noab+1,noab+nvab 1075 IF (next.eq.count) THEN 1076 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p1b-1 1077 &).ne.4)) THEN 1078 IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p1b-1)) THEN 1079 IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+p1b-1)) .eq. irrep_f) TH 1080 &EN 1081 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+p1b-1) 1082 CALL TCE_RESTRICTED_2(h5b,p1b,h5b_1,p1b_1) 1083 dim_common = 1 1084 dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+p1b-1) 1085 dima = dim_common * dima_sort 1086 IF (dima .gt. 0) THEN 1087 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1088 & ERRQUIT('ccsdt2_q_left_2_1',0,MA_ERR) 1089 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1090 &ccsdt2_q_left_2_1',1,MA_ERR) 1091 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 1092 & - 1 + (noab+nvab) * (h5b_1 - 1))) 1093 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 1094 &,int_mb(k_range+p1b-1),2,1,1.0d0) 1095 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_2_1',2,MA_ 1096 &ERR) 1097 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1098 &ccsdt2_q_left_2_1',3,MA_ERR) 1099 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 1100 &,int_mb(k_range+h5b-1),2,1,1.0d0) 1101 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 1102 & noab - 1 + nvab * (h5b - 1))) 1103 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt2_q_left_2_1',4,MA_ 1104 &ERR) 1105 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_2_1', 1106 &5,MA_ERR) 1107 END IF 1108 END IF 1109 END IF 1110 END IF 1111 next = nxtask(nprocs,1) 1112 END IF 1113 count = count + 1 1114 END DO 1115 END DO 1116 next = nxtask(-nprocs,1) 1117 call GA_SYNC() 1118 RETURN 1119 END 1120 SUBROUTINE OFFSET_ccsdt2_q_left_2_1(l_a_offset,k_a_offset,size) 1121C $Id$ 1122C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1123C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1124C i1 ( h5 p1 )_f 1125 IMPLICIT NONE 1126#include "global.fh" 1127#include "mafdecls.fh" 1128#include "sym.fh" 1129#include "errquit.fh" 1130#include "tce.fh" 1131 INTEGER l_a_offset 1132 INTEGER k_a_offset 1133 INTEGER size 1134 INTEGER length 1135 INTEGER addr 1136 INTEGER h5b 1137 INTEGER p1b 1138 length = 0 1139 DO h5b = 1,noab 1140 DO p1b = noab+1,noab+nvab 1141 IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p1b-1)) THEN 1142 IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+p1b-1)) .eq. irrep_f) TH 1143 &EN 1144 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p1b-1 1145 &).ne.4)) THEN 1146 length = length + 1 1147 END IF 1148 END IF 1149 END IF 1150 END DO 1151 END DO 1152 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1153 &set)) CALL ERRQUIT('ccsdt2_q_left_2_1',0,MA_ERR) 1154 int_mb(k_a_offset) = length 1155 addr = 0 1156 size = 0 1157 DO h5b = 1,noab 1158 DO p1b = noab+1,noab+nvab 1159 IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p1b-1)) THEN 1160 IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+p1b-1)) .eq. irrep_f) TH 1161 &EN 1162 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p1b-1 1163 &).ne.4)) THEN 1164 addr = addr + 1 1165 int_mb(k_a_offset+addr) = p1b - noab - 1 + nvab * (h5b - 1) 1166 int_mb(k_a_offset+length+addr) = size 1167 size = size + int_mb(k_range+h5b-1) * int_mb(k_range+p1b-1) 1168 END IF 1169 END IF 1170 END IF 1171 END DO 1172 END DO 1173 RETURN 1174 END 1175 SUBROUTINE ccsdt2_q_left_2_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c 1176 &_offset) 1177C $Id$ 1178C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1179C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1180C i1 ( h5 p1 )_vt + = 1 * Sum ( h10 p9 ) * t ( p9 h10 )_t * v ( h5 h10 p1 p9 )_v 1181 IMPLICIT NONE 1182#include "global.fh" 1183#include "mafdecls.fh" 1184#include "sym.fh" 1185#include "errquit.fh" 1186#include "tce.fh" 1187 INTEGER d_a 1188 INTEGER k_a_offset 1189 INTEGER d_b 1190 INTEGER k_b_offset 1191 INTEGER d_c 1192 INTEGER k_c_offset 1193 INTEGER nxtask 1194 INTEGER next 1195 INTEGER nprocs 1196 INTEGER count 1197 INTEGER h5b 1198 INTEGER p1b 1199 INTEGER dimc 1200 INTEGER l_c_sort 1201 INTEGER k_c_sort 1202 INTEGER p9b 1203 INTEGER h10b 1204 INTEGER p9b_1 1205 INTEGER h10b_1 1206 INTEGER h5b_2 1207 INTEGER h10b_2 1208 INTEGER p1b_2 1209 INTEGER p9b_2 1210 INTEGER dim_common 1211 INTEGER dima_sort 1212 INTEGER dima 1213 INTEGER dimb_sort 1214 INTEGER dimb 1215 INTEGER l_a_sort 1216 INTEGER k_a_sort 1217 INTEGER l_a 1218 INTEGER k_a 1219 INTEGER l_b_sort 1220 INTEGER k_b_sort 1221 INTEGER l_b 1222 INTEGER k_b 1223 INTEGER l_c 1224 INTEGER k_c 1225 EXTERNAL nxtask 1226 nprocs = GA_NNODES() 1227 count = 0 1228 next = nxtask(nprocs,1) 1229 DO h5b = 1,noab 1230 DO p1b = noab+1,noab+nvab 1231 IF (next.eq.count) THEN 1232 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p1b-1 1233 &).ne.4)) THEN 1234 IF (int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p1b-1)) THEN 1235 IF (ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+p1b-1)) .eq. ieor(irrep_ 1236 &v,irrep_t)) THEN 1237 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+p1b-1) 1238 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1239 & ERRQUIT('ccsdt2_q_left_2_2',0,MA_ERR) 1240 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1241 DO p9b = noab+1,noab+nvab 1242 DO h10b = 1,noab 1243 IF (int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h10b-1)) THEN 1244 IF (ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+h10b-1)) .eq. irrep_t) T 1245 &HEN 1246 CALL TCE_RESTRICTED_2(p9b,h10b,p9b_1,h10b_1) 1247 CALL TCE_RESTRICTED_4(h5b,h10b,p1b,p9b,h5b_2,h10b_2,p1b_2,p9b_2) 1248 dim_common = int_mb(k_range+p9b-1) * int_mb(k_range+h10b-1) 1249 dima_sort = 1 1250 dima = dim_common * dima_sort 1251 dimb_sort = int_mb(k_range+h5b-1) * int_mb(k_range+p1b-1) 1252 dimb = dim_common * dimb_sort 1253 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1254 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1255 & ERRQUIT('ccsdt2_q_left_2_2',1,MA_ERR) 1256 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1257 &ccsdt2_q_left_2_2',2,MA_ERR) 1258 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 1259 &1 - 1 + noab * (p9b_1 - noab - 1))) 1260 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 1261 &,int_mb(k_range+h10b-1),2,1,1.0d0) 1262 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_2_2',3,MA_ 1263 &ERR) 1264 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1265 & ERRQUIT('ccsdt2_q_left_2_2',4,MA_ERR) 1266 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1267 &ccsdt2_q_left_2_2',5,MA_ERR) 1268 IF ((h10b .lt. h5b) .and. (p9b .lt. p1b)) THEN 1269 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 1270 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 1271 &+nvab) * (h10b_2 - 1))))) 1272 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 1273 &),int_mb(k_range+h5b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1 1274 &),4,2,1,3,1.0d0) 1275 END IF 1276 IF ((h10b .lt. h5b) .and. (p1b .le. p9b)) THEN 1277 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 1278 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 1279 &+nvab) * (h10b_2 - 1))))) 1280 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 1281 &),int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1 1282 &),3,2,1,4,-1.0d0) 1283 END IF 1284 IF ((h5b .le. h10b) .and. (p9b .lt. p1b)) THEN 1285 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 1286 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 1287 &b+nvab) * (h5b_2 - 1))))) 1288 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 1289 &,int_mb(k_range+h10b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1 1290 &),4,1,2,3,-1.0d0) 1291 END IF 1292 IF ((h5b .le. h10b) .and. (p1b .le. p9b)) THEN 1293 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 1294 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 1295 &b+nvab) * (h5b_2 - 1))))) 1296 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 1297 &,int_mb(k_range+h10b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1 1298 &),3,1,2,4,1.0d0) 1299 END IF 1300 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt2_q_left_2_2',6,MA_ 1301 &ERR) 1302 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1303 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1304 &t),dima_sort) 1305 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt2_q_left_2_2', 1306 &7,MA_ERR) 1307 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_2_2', 1308 &8,MA_ERR) 1309 END IF 1310 END IF 1311 END IF 1312 END DO 1313 END DO 1314 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1315 &ccsdt2_q_left_2_2',9,MA_ERR) 1316 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 1317 &,int_mb(k_range+h5b-1),2,1,1.0d0) 1318 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p1b - 1319 & noab - 1 + nvab * (h5b - 1))) 1320 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt2_q_left_2_2',10,MA 1321 &_ERR) 1322 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt2_q_left_2_2', 1323 &11,MA_ERR) 1324 END IF 1325 END IF 1326 END IF 1327 next = nxtask(nprocs,1) 1328 END IF 1329 count = count + 1 1330 END DO 1331 END DO 1332 next = nxtask(-nprocs,1) 1333 call GA_SYNC() 1334 RETURN 1335 END 1336 SUBROUTINE ccsdt2_q_left_3(d_a,k_a_offset,d_b,k_b_offset,a_c,t_h5b 1337 &,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 1338C $Id$ 1339C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1340C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1341C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yv + = -1 * P( 24 ) * Sum ( h11 ) * y ( h5 h6 h11 p1 p2 p3 )_y * i1 ( h7 h8 h11 p4 )_v 1342 IMPLICIT NONE 1343#include "global.fh" 1344#include "mafdecls.fh" 1345#include "sym.fh" 1346#include "errquit.fh" 1347#include "tce.fh" 1348 INTEGER d_a 1349 INTEGER k_a_offset 1350 INTEGER d_b 1351 INTEGER k_b_offset 1352 INTEGER t_h5b 1353 INTEGER t_h6b 1354 INTEGER t_h7b 1355 INTEGER t_h8b 1356 INTEGER t_p1b 1357 INTEGER t_p2b 1358 INTEGER t_p3b 1359 INTEGER t_p4b 1360 INTEGER h5b 1361 INTEGER h6b 1362 INTEGER h7b 1363 INTEGER h8b 1364 INTEGER p1b 1365 INTEGER p2b 1366 INTEGER p3b 1367 INTEGER p4b 1368 INTEGER dimc 1369 INTEGER l_c_sort 1370 INTEGER k_c_sort 1371 INTEGER h11b 1372 INTEGER h5b_1 1373 INTEGER h6b_1 1374 INTEGER h11b_1 1375 INTEGER p1b_1 1376 INTEGER p2b_1 1377 INTEGER p3b_1 1378 INTEGER h7b_2 1379 INTEGER h8b_2 1380 INTEGER p4b_2 1381 INTEGER h11b_2 1382 INTEGER dim_common 1383 INTEGER dima_sort 1384 INTEGER dima 1385 INTEGER dimb_sort 1386 INTEGER dimb 1387 INTEGER l_a_sort 1388 INTEGER k_a_sort 1389 INTEGER l_a 1390 INTEGER k_a 1391 INTEGER l_b_sort 1392 INTEGER k_b_sort 1393 INTEGER l_b 1394 INTEGER k_b 1395 DOUBLE PRECISION a_c(*) 1396 LOGICAL skipped 1397 DO h5b = 1,noab 1398 DO h6b = h5b,noab 1399 DO h7b = 1,noab 1400 DO h8b = h7b,noab 1401 DO p1b = noab+1,noab+nvab 1402 DO p2b = p1b,noab+nvab 1403 DO p3b = p2b,noab+nvab 1404 DO p4b = noab+1,noab+nvab 1405 skipped = .true. 1406 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1407 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1408 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 1409 &e. 1410 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1411 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1412 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1413 &e. 1414 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1415 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1416 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1417 &e. 1418 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1419 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1420 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 1421 &e. 1422 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1423 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1424 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 1425 &e. 1426 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1427 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1428 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1429 &e. 1430 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1431 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1432 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1433 &e. 1434 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1435 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1436 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 1437 &e. 1438 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1439 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1440 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 1441 &e. 1442 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1443 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1444 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1445 &e. 1446 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1447 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1448 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1449 &e. 1450 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1451 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1452 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 1453 &e. 1454 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1455 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1456 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 1457 &e. 1458 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1459 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1460 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1461 &e. 1462 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1463 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1464 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1465 &e. 1466 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1467 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1468 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 1469 &e. 1470 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1471 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1472 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 1473 &e. 1474 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1475 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1476 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1477 &e. 1478 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1479 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1480 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1481 &e. 1482 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1483 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1484 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 1485 &e. 1486 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1487 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1488 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 1489 &e. 1490 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1491 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1492 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1493 &e. 1494 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1495 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1496 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) skipped = .fals 1497 &e. 1498 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1499 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1500 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) skipped = .fals 1501 &e. 1502 IF (.not.skipped) THEN 1503 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 1504 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1)+int_mb(k_spin+p1b-1)+i 1505 &nt_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1).ne.1 1506 &6)) THEN 1507 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) 1508 &+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b- 1509 &1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1)) THEN 1510 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 1511 &k_sym+h7b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+p1b-1),ieo 1512 &r(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p4b-1) 1513 &))))))) .eq. ieor(irrep_y,irrep_v)) THEN 1514 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 1515 &nge+h7b-1) * int_mb(k_range+h8b-1) * int_mb(k_range+p1b-1) * int_m 1516 &b(k_range+p2b-1) * int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) 1517 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 1518 & ERRQUIT('ccsdt2_q_left_3',0,MA_ERR) 1519 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 1520 DO h11b = 1,noab 1521 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h11b-1 1522 &) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b 1523 &-1)) THEN 1524 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 1525 &k_sym+h11b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),in 1526 &t_mb(k_sym+p3b-1)))))) .eq. irrep_y) THEN 1527 CALL TCE_RESTRICTED_6(h5b,h6b,h11b,p1b,p2b,p3b,h5b_1,h6b_1,h11b_1, 1528 &p1b_1,p2b_1,p3b_1) 1529 CALL TCE_RESTRICTED_4(h7b,h8b,p4b,h11b,h7b_2,h8b_2,p4b_2,h11b_2) 1530 dim_common = int_mb(k_range+h11b-1) 1531 dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 1532 &(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_mb(k_range+p3b-1) 1533 dima = dim_common * dima_sort 1534 dimb_sort = int_mb(k_range+h7b-1) * int_mb(k_range+h8b-1) * int_mb 1535 &(k_range+p4b-1) 1536 dimb = dim_common * dimb_sort 1537 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 1538 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1539 & ERRQUIT('ccsdt2_q_left_3',1,MA_ERR) 1540 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1541 &ccsdt2_q_left_3',2,MA_ERR) 1542 IF ((h11b .lt. h5b)) THEN 1543 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1 1544 & - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 1545 &+ nvab * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h11b_1 - 1)))))) 1546 &) 1547 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h11b-1 1548 &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1 1549 &),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),6,5,4,3,2,1,1.0d0) 1550 END IF 1551 IF ((h5b .le. h11b) .and. (h11b .lt. h6b)) THEN 1552 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1 1553 & - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 1554 &+ nvab * (h6b_1 - 1 + noab * (h11b_1 - 1 + noab * (h5b_1 - 1)))))) 1555 &) 1556 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 1557 &,int_mb(k_range+h11b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1 1558 &),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),6,5,4,3,1,2,-1.0d0) 1559 END IF 1560 IF ((h6b .le. h11b)) THEN 1561 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p3b_1 1562 & - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 1563 &+ nvab * (h11b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1)))))) 1564 &) 1565 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 1566 &,int_mb(k_range+h6b-1),int_mb(k_range+h11b-1),int_mb(k_range+p1b-1 1567 &),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),6,5,4,2,1,3,1.0d0) 1568 END IF 1569 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_3',3,MA_ER 1570 &R) 1571 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 1572 & ERRQUIT('ccsdt2_q_left_3',4,MA_ERR) 1573 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 1574 &ccsdt2_q_left_3',5,MA_ERR) 1575 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(h11b_ 1576 &2 - 1 + noab * (p4b_2 - noab - 1 + nvab * (h8b_2 - 1 + noab * (h7b 1577 &_2 - 1))))) 1578 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 1579 &,int_mb(k_range+h8b-1),int_mb(k_range+p4b-1),int_mb(k_range+h11b-1 1580 &),3,2,1,4,1.0d0) 1581 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt2_q_left_3',6,MA_ER 1582 &R) 1583 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 1584 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 1585 &t),dima_sort) 1586 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt2_q_left_3',7, 1587 &MA_ERR) 1588 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_3',8, 1589 &MA_ERR) 1590 END IF 1591 END IF 1592 END IF 1593 END DO 1594 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1595 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1596 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 1597 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1598 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1599 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1600 &mb(k_range+h5b-1),8,7,3,2,6,5,4,1,-1.0d0) 1601 END IF 1602 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1603 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1604 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1605 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1606 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1607 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1608 &mb(k_range+h5b-1),8,7,3,2,1,6,5,4,1.0d0) 1609 END IF 1610 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1611 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1612 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1613 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1614 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1615 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1616 &mb(k_range+h5b-1),8,7,3,2,6,1,5,4,-1.0d0) 1617 END IF 1618 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 1619 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1620 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 1621 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1622 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1623 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1624 &mb(k_range+h5b-1),8,7,3,2,6,5,1,4,1.0d0) 1625 END IF 1626 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1627 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1628 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 1629 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1630 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1631 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1632 &mb(k_range+h5b-1),3,8,7,2,6,5,4,1,-1.0d0) 1633 END IF 1634 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1635 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1636 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1637 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1638 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1639 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1640 &mb(k_range+h5b-1),3,8,7,2,1,6,5,4,1.0d0) 1641 END IF 1642 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1643 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1644 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1645 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1646 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1647 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1648 &mb(k_range+h5b-1),3,8,7,2,6,1,5,4,-1.0d0) 1649 END IF 1650 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 1651 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1652 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 1653 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1654 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1655 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1656 &mb(k_range+h5b-1),3,8,7,2,6,5,1,4,1.0d0) 1657 END IF 1658 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1659 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1660 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 1661 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1662 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1663 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1664 &mb(k_range+h5b-1),3,8,2,7,6,5,4,1,1.0d0) 1665 END IF 1666 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1667 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1668 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1669 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1670 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1671 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1672 &mb(k_range+h5b-1),3,8,2,7,1,6,5,4,-1.0d0) 1673 END IF 1674 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1675 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1676 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1677 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1678 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1679 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1680 &mb(k_range+h5b-1),3,8,2,7,6,1,5,4,1.0d0) 1681 END IF 1682 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h8b) 1683 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1684 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 1685 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1686 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1687 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1688 &mb(k_range+h5b-1),3,8,2,7,6,5,1,4,-1.0d0) 1689 END IF 1690 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1691 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1692 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 1693 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1694 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1695 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1696 &mb(k_range+h5b-1),8,3,7,2,6,5,4,1,1.0d0) 1697 END IF 1698 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1699 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1700 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1701 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1702 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1703 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1704 &mb(k_range+h5b-1),8,3,7,2,1,6,5,4,-1.0d0) 1705 END IF 1706 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1707 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1708 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1709 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1710 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1711 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1712 &mb(k_range+h5b-1),8,3,7,2,6,1,5,4,1.0d0) 1713 END IF 1714 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h6b) 1715 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1716 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 1717 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1718 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1719 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1720 &mb(k_range+h5b-1),8,3,7,2,6,5,1,4,-1.0d0) 1721 END IF 1722 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1723 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1724 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 1725 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1726 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1727 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1728 &mb(k_range+h5b-1),8,3,2,7,6,5,4,1,-1.0d0) 1729 END IF 1730 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1731 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1732 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1733 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1734 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1735 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1736 &mb(k_range+h5b-1),8,3,2,7,1,6,5,4,1.0d0) 1737 END IF 1738 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1739 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1740 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1741 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1742 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1743 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1744 &mb(k_range+h5b-1),8,3,2,7,6,1,5,4,-1.0d0) 1745 END IF 1746 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h7b) .and. (t_h7b .eq. h8b) 1747 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1748 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 1749 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1750 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1751 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1752 &mb(k_range+h5b-1),8,3,2,7,6,5,1,4,1.0d0) 1753 END IF 1754 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1755 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1756 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 1757 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1758 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1759 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1760 &mb(k_range+h5b-1),3,2,8,7,6,5,4,1,-1.0d0) 1761 END IF 1762 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1763 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p4b) .and. (t_p2b .eq. p 1764 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1765 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1766 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1767 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1768 &mb(k_range+h5b-1),3,2,8,7,1,6,5,4,1.0d0) 1769 END IF 1770 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1771 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1772 &4b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p3b)) THEN 1773 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1774 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1775 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1776 &mb(k_range+h5b-1),3,2,8,7,6,1,5,4,-1.0d0) 1777 END IF 1778 IF ((t_h5b .eq. h7b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h5b) 1779 & .and. (t_h8b .eq. h6b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 1780 &2b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p3b)) THEN 1781 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 1782 &mb(k_range+h8b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1),int_ 1783 &mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_ 1784 &mb(k_range+h5b-1),3,2,8,7,6,5,1,4,1.0d0) 1785 END IF 1786 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt2_q_left_3',9, 1787 &MA_ERR) 1788 END IF 1789 END IF 1790 END IF 1791 END IF 1792 END DO 1793 END DO 1794 END DO 1795 END DO 1796 END DO 1797 END DO 1798 END DO 1799 END DO 1800 RETURN 1801 END 1802 SUBROUTINE ccsdt2_q_left_3_1(d_a,k_a_offset,d_c,k_c_offset) 1803C $Id$ 1804C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1805C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1806C i1 ( h5 h6 h11 p1 )_v + = 1 * v ( h5 h6 h11 p1 )_v 1807 IMPLICIT NONE 1808#include "global.fh" 1809#include "mafdecls.fh" 1810#include "sym.fh" 1811#include "errquit.fh" 1812#include "tce.fh" 1813 INTEGER d_a 1814 INTEGER k_a_offset 1815 INTEGER d_c 1816 INTEGER k_c_offset 1817 INTEGER nxtask 1818 INTEGER next 1819 INTEGER nprocs 1820 INTEGER count 1821 INTEGER h5b 1822 INTEGER h6b 1823 INTEGER p1b 1824 INTEGER h11b 1825 INTEGER dimc 1826 INTEGER h5b_1 1827 INTEGER h6b_1 1828 INTEGER p1b_1 1829 INTEGER h11b_1 1830 INTEGER dim_common 1831 INTEGER dima_sort 1832 INTEGER dima 1833 INTEGER l_a_sort 1834 INTEGER k_a_sort 1835 INTEGER l_a 1836 INTEGER k_a 1837 INTEGER l_c 1838 INTEGER k_c 1839 EXTERNAL nxtask 1840 nprocs = GA_NNODES() 1841 count = 0 1842 next = nxtask(nprocs,1) 1843 DO h5b = 1,noab 1844 DO h6b = h5b,noab 1845 DO p1b = noab+1,noab+nvab 1846 DO h11b = 1,noab 1847 IF (next.eq.count) THEN 1848 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 1849 &)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h11b-1).ne.8)) THEN 1850 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p 1851 &1b-1)+int_mb(k_spin+h11b-1)) THEN 1852 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 1853 &k_sym+p1b-1),int_mb(k_sym+h11b-1)))) .eq. irrep_v) THEN 1854 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 1855 &nge+p1b-1) * int_mb(k_range+h11b-1) 1856 CALL TCE_RESTRICTED_4(h5b,h6b,p1b,h11b,h5b_1,h6b_1,p1b_1,h11b_1) 1857 dim_common = 1 1858 dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 1859 &(k_range+p1b-1) * int_mb(k_range+h11b-1) 1860 dima = dim_common * dima_sort 1861 IF (dima .gt. 0) THEN 1862 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 1863 & ERRQUIT('ccsdt2_q_left_3_1',0,MA_ERR) 1864 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 1865 &ccsdt2_q_left_3_1',1,MA_ERR) 1866 IF ((h11b .le. p1b)) THEN 1867 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 1868 & - 1 + (noab+nvab) * (h11b_1 - 1 + (noab+nvab) * (h6b_1 - 1 + (noa 1869 &b+nvab) * (h5b_1 - 1))))) 1870 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 1871 &,int_mb(k_range+h6b-1),int_mb(k_range+h11b-1),int_mb(k_range+p1b-1 1872 &),3,4,2,1,1.0d0) 1873 END IF 1874 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_3_1',2,MA_ 1875 &ERR) 1876 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 1877 &ccsdt2_q_left_3_1',3,MA_ERR) 1878 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h11b-1 1879 &),int_mb(k_range+p1b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1 1880 &),4,3,2,1,1.0d0) 1881 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h11b 1882 &- 1 + noab * (p1b - noab - 1 + nvab * (h6b - 1 + noab * (h5b - 1)) 1883 &))) 1884 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt2_q_left_3_1',4,MA_ 1885 &ERR) 1886 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_3_1', 1887 &5,MA_ERR) 1888 END IF 1889 END IF 1890 END IF 1891 END IF 1892 next = nxtask(nprocs,1) 1893 END IF 1894 count = count + 1 1895 END DO 1896 END DO 1897 END DO 1898 END DO 1899 next = nxtask(-nprocs,1) 1900 call GA_SYNC() 1901 RETURN 1902 END 1903 SUBROUTINE OFFSET_ccsdt2_q_left_3_1(l_a_offset,k_a_offset,size) 1904C $Id$ 1905C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1906C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1907C i1 ( h5 h6 h11 p1 )_v 1908 IMPLICIT NONE 1909#include "global.fh" 1910#include "mafdecls.fh" 1911#include "sym.fh" 1912#include "errquit.fh" 1913#include "tce.fh" 1914 INTEGER l_a_offset 1915 INTEGER k_a_offset 1916 INTEGER size 1917 INTEGER length 1918 INTEGER addr 1919 INTEGER h5b 1920 INTEGER h6b 1921 INTEGER p1b 1922 INTEGER h11b 1923 length = 0 1924 DO h5b = 1,noab 1925 DO h6b = h5b,noab 1926 DO p1b = noab+1,noab+nvab 1927 DO h11b = 1,noab 1928 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 1929 &11b-1)+int_mb(k_spin+p1b-1)) THEN 1930 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 1931 &k_sym+h11b-1),int_mb(k_sym+p1b-1)))) .eq. irrep_v) THEN 1932 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 1933 &)+int_mb(k_spin+h11b-1)+int_mb(k_spin+p1b-1).ne.8)) THEN 1934 length = length + 1 1935 END IF 1936 END IF 1937 END IF 1938 END DO 1939 END DO 1940 END DO 1941 END DO 1942 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 1943 &set)) CALL ERRQUIT('ccsdt2_q_left_3_1',0,MA_ERR) 1944 int_mb(k_a_offset) = length 1945 addr = 0 1946 size = 0 1947 DO h5b = 1,noab 1948 DO h6b = h5b,noab 1949 DO p1b = noab+1,noab+nvab 1950 DO h11b = 1,noab 1951 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h 1952 &11b-1)+int_mb(k_spin+p1b-1)) THEN 1953 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 1954 &k_sym+h11b-1),int_mb(k_sym+p1b-1)))) .eq. irrep_v) THEN 1955 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 1956 &)+int_mb(k_spin+h11b-1)+int_mb(k_spin+p1b-1).ne.8)) THEN 1957 addr = addr + 1 1958 int_mb(k_a_offset+addr) = h11b - 1 + noab * (p1b - noab - 1 + nvab 1959 & * (h6b - 1 + noab * (h5b - 1))) 1960 int_mb(k_a_offset+length+addr) = size 1961 size = size + int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_ 1962 &mb(k_range+p1b-1) * int_mb(k_range+h11b-1) 1963 END IF 1964 END IF 1965 END IF 1966 END DO 1967 END DO 1968 END DO 1969 END DO 1970 RETURN 1971 END 1972 SUBROUTINE ccsdt2_q_left_3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c 1973 &_offset) 1974C $Id$ 1975C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 1976C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 1977C i1 ( h5 h6 h11 p1 )_vt + = -1 * Sum ( p9 ) * t ( p9 h11 )_t * v ( h5 h6 p1 p9 )_v 1978 IMPLICIT NONE 1979#include "global.fh" 1980#include "mafdecls.fh" 1981#include "sym.fh" 1982#include "errquit.fh" 1983#include "tce.fh" 1984 INTEGER d_a 1985 INTEGER k_a_offset 1986 INTEGER d_b 1987 INTEGER k_b_offset 1988 INTEGER d_c 1989 INTEGER k_c_offset 1990 INTEGER nxtask 1991 INTEGER next 1992 INTEGER nprocs 1993 INTEGER count 1994 INTEGER h5b 1995 INTEGER h6b 1996 INTEGER p1b 1997 INTEGER h11b 1998 INTEGER dimc 1999 INTEGER l_c_sort 2000 INTEGER k_c_sort 2001 INTEGER p9b 2002 INTEGER p9b_1 2003 INTEGER h11b_1 2004 INTEGER h5b_2 2005 INTEGER h6b_2 2006 INTEGER p1b_2 2007 INTEGER p9b_2 2008 INTEGER dim_common 2009 INTEGER dima_sort 2010 INTEGER dima 2011 INTEGER dimb_sort 2012 INTEGER dimb 2013 INTEGER l_a_sort 2014 INTEGER k_a_sort 2015 INTEGER l_a 2016 INTEGER k_a 2017 INTEGER l_b_sort 2018 INTEGER k_b_sort 2019 INTEGER l_b 2020 INTEGER k_b 2021 INTEGER l_c 2022 INTEGER k_c 2023 EXTERNAL nxtask 2024 nprocs = GA_NNODES() 2025 count = 0 2026 next = nxtask(nprocs,1) 2027 DO h5b = 1,noab 2028 DO h6b = h5b,noab 2029 DO p1b = noab+1,noab+nvab 2030 DO h11b = 1,noab 2031 IF (next.eq.count) THEN 2032 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 2033 &)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h11b-1).ne.8)) THEN 2034 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p 2035 &1b-1)+int_mb(k_spin+h11b-1)) THEN 2036 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 2037 &k_sym+p1b-1),int_mb(k_sym+h11b-1)))) .eq. ieor(irrep_v,irrep_t)) T 2038 &HEN 2039 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 2040 &nge+p1b-1) * int_mb(k_range+h11b-1) 2041 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2042 & ERRQUIT('ccsdt2_q_left_3_2',0,MA_ERR) 2043 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2044 DO p9b = noab+1,noab+nvab 2045 IF (int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h11b-1)) THEN 2046 IF (ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+h11b-1)) .eq. irrep_t) T 2047 &HEN 2048 CALL TCE_RESTRICTED_2(p9b,h11b,p9b_1,h11b_1) 2049 CALL TCE_RESTRICTED_4(h5b,h6b,p1b,p9b,h5b_2,h6b_2,p1b_2,p9b_2) 2050 dim_common = int_mb(k_range+p9b-1) 2051 dima_sort = int_mb(k_range+h11b-1) 2052 dima = dim_common * dima_sort 2053 dimb_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 2054 &(k_range+p1b-1) 2055 dimb = dim_common * dimb_sort 2056 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2057 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2058 & ERRQUIT('ccsdt2_q_left_3_2',1,MA_ERR) 2059 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2060 &ccsdt2_q_left_3_2',2,MA_ERR) 2061 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h11b_ 2062 &1 - 1 + noab * (p9b_1 - noab - 1))) 2063 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 2064 &,int_mb(k_range+h11b-1),2,1,1.0d0) 2065 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_3_2',3,MA_ 2066 &ERR) 2067 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2068 & ERRQUIT('ccsdt2_q_left_3_2',4,MA_ERR) 2069 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2070 &ccsdt2_q_left_3_2',5,MA_ERR) 2071 IF ((p9b .lt. p1b)) THEN 2072 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 2073 & - 1 + (noab+nvab) * (p9b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 2074 &+nvab) * (h5b_2 - 1))))) 2075 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 2076 &,int_mb(k_range+h6b-1),int_mb(k_range+p9b-1),int_mb(k_range+p1b-1) 2077 &,4,2,1,3,-1.0d0) 2078 END IF 2079 IF ((p1b .le. p9b)) THEN 2080 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 2081 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 2082 &+nvab) * (h5b_2 - 1))))) 2083 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 2084 &,int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_mb(k_range+p9b-1) 2085 &,3,2,1,4,1.0d0) 2086 END IF 2087 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt2_q_left_3_2',6,MA_ 2088 &ERR) 2089 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2090 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2091 &t),dima_sort) 2092 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt2_q_left_3_2', 2093 &7,MA_ERR) 2094 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_3_2', 2095 &8,MA_ERR) 2096 END IF 2097 END IF 2098 END IF 2099 END DO 2100 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2101 &ccsdt2_q_left_3_2',9,MA_ERR) 2102 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p1b-1) 2103 &,int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+h11b-1 2104 &),3,2,1,4,-1.0d0) 2105 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h11b 2106 &- 1 + noab * (p1b - noab - 1 + nvab * (h6b - 1 + noab * (h5b - 1)) 2107 &))) 2108 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt2_q_left_3_2',10,MA 2109 &_ERR) 2110 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt2_q_left_3_2', 2111 &11,MA_ERR) 2112 END IF 2113 END IF 2114 END IF 2115 next = nxtask(nprocs,1) 2116 END IF 2117 count = count + 1 2118 END DO 2119 END DO 2120 END DO 2121 END DO 2122 next = nxtask(-nprocs,1) 2123 call GA_SYNC() 2124 RETURN 2125 END 2126 SUBROUTINE ccsdt2_q_left_4(d_a,k_a_offset,d_b,k_b_offset,a_c,t_h5b 2127 &,t_h6b,t_h7b,t_h8b,t_p1b,t_p2b,t_p3b,t_p4b) 2128C $Id$ 2129C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2130C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2131C i0 ( h5 h6 h7 h8 p1 p2 p3 p4 )_yv + = -1 * P( 24 ) * Sum ( p9 ) * y ( h5 h6 h7 p1 p2 p9 )_y * i1 ( h8 p9 p3 p4 )_v 2132 IMPLICIT NONE 2133#include "global.fh" 2134#include "mafdecls.fh" 2135#include "sym.fh" 2136#include "errquit.fh" 2137#include "tce.fh" 2138 INTEGER d_a 2139 INTEGER k_a_offset 2140 INTEGER d_b 2141 INTEGER k_b_offset 2142 INTEGER t_h5b 2143 INTEGER t_h6b 2144 INTEGER t_h7b 2145 INTEGER t_h8b 2146 INTEGER t_p1b 2147 INTEGER t_p2b 2148 INTEGER t_p3b 2149 INTEGER t_p4b 2150 INTEGER h5b 2151 INTEGER h6b 2152 INTEGER h7b 2153 INTEGER h8b 2154 INTEGER p1b 2155 INTEGER p2b 2156 INTEGER p3b 2157 INTEGER p4b 2158 INTEGER dimc 2159 INTEGER l_c_sort 2160 INTEGER k_c_sort 2161 INTEGER p9b 2162 INTEGER h5b_1 2163 INTEGER h6b_1 2164 INTEGER h7b_1 2165 INTEGER p1b_1 2166 INTEGER p2b_1 2167 INTEGER p9b_1 2168 INTEGER h8b_2 2169 INTEGER p9b_2 2170 INTEGER p3b_2 2171 INTEGER p4b_2 2172 INTEGER dim_common 2173 INTEGER dima_sort 2174 INTEGER dima 2175 INTEGER dimb_sort 2176 INTEGER dimb 2177 INTEGER l_a_sort 2178 INTEGER k_a_sort 2179 INTEGER l_a 2180 INTEGER k_a 2181 INTEGER l_b_sort 2182 INTEGER k_b_sort 2183 INTEGER l_b 2184 INTEGER k_b 2185 DOUBLE PRECISION a_c(*) 2186 LOGICAL skipped 2187 DO h5b = 1,noab 2188 DO h6b = h5b,noab 2189 DO h7b = h6b,noab 2190 DO h8b = 1,noab 2191 DO p1b = noab+1,noab+nvab 2192 DO p2b = p1b,noab+nvab 2193 DO p3b = noab+1,noab+nvab 2194 DO p4b = p3b,noab+nvab 2195 skipped = .true. 2196 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2197 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2198 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 2199 &e. 2200 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2201 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2202 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2203 &e. 2204 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2205 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2206 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2207 &e. 2208 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2209 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2210 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2211 &e. 2212 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2213 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2214 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2215 &e. 2216 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2217 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2218 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 2219 &e. 2220 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2221 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2222 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 2223 &e. 2224 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2225 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2226 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2227 &e. 2228 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2229 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2230 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2231 &e. 2232 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2233 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2234 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2235 &e. 2236 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2237 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2238 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2239 &e. 2240 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2241 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2242 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 2243 &e. 2244 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2245 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2246 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 2247 &e. 2248 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2249 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2250 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2251 &e. 2252 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2253 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2254 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2255 &e. 2256 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2257 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2258 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2259 &e. 2260 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2261 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2262 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2263 &e. 2264 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2265 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2266 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 2267 &e. 2268 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2269 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2270 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) skipped = .fals 2271 &e. 2272 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2273 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2274 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2275 &e. 2276 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2277 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2278 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2279 &e. 2280 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2281 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2282 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) skipped = .fals 2283 &e. 2284 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2285 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2286 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) skipped = .fals 2287 &e. 2288 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2289 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2290 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) skipped = .fals 2291 &e. 2292 IF (.not.skipped) THEN 2293 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1 2294 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1)+int_mb(k_spin+p1b-1)+i 2295 &nt_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1).ne.1 2296 &6)) THEN 2297 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) 2298 &+int_mb(k_spin+h8b-1) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b- 2299 &1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1)) THEN 2300 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 2301 &k_sym+h7b-1),ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+p1b-1),ieo 2302 &r(int_mb(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+p4b-1) 2303 &))))))) .eq. ieor(irrep_y,irrep_v)) THEN 2304 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra 2305 &nge+h7b-1) * int_mb(k_range+h8b-1) * int_mb(k_range+p1b-1) * int_m 2306 &b(k_range+p2b-1) * int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) 2307 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2308 & ERRQUIT('ccsdt2_q_left_4',0,MA_ERR) 2309 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2310 DO p9b = noab+1,noab+nvab 2311 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h7b-1) 2312 & .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p9b- 2313 &1)) THEN 2314 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( 2315 &k_sym+h7b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),int 2316 &_mb(k_sym+p9b-1)))))) .eq. irrep_y) THEN 2317 CALL TCE_RESTRICTED_6(h5b,h6b,h7b,p1b,p2b,p9b,h5b_1,h6b_1,h7b_1,p1 2318 &b_1,p2b_1,p9b_1) 2319 CALL TCE_RESTRICTED_4(h8b,p9b,p3b,p4b,h8b_2,p9b_2,p3b_2,p4b_2) 2320 dim_common = int_mb(k_range+p9b-1) 2321 dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 2322 &(k_range+h7b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 2323 dima = dim_common * dima_sort 2324 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+p3b-1) * int_mb 2325 &(k_range+p4b-1) 2326 dimb = dim_common * dimb_sort 2327 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2328 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2329 & ERRQUIT('ccsdt2_q_left_4',1,MA_ERR) 2330 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2331 &ccsdt2_q_left_4',2,MA_ERR) 2332 IF ((p9b .lt. p1b)) THEN 2333 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 2334 & - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (p9b_1 - noab - 1 2335 &+ nvab * (h7b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1))))))) 2336 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 2337 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),int_mb(k_range+p9b-1) 2338 &,int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),6,5,3,2,1,4,1.0d0) 2339 END IF 2340 IF ((p1b .le. p9b) .and. (p9b .lt. p2b)) THEN 2341 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 2342 & - noab - 1 + nvab * (p9b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 2343 &+ nvab * (h7b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1))))))) 2344 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 2345 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),int_mb(k_range+p1b-1) 2346 &,int_mb(k_range+p9b-1),int_mb(k_range+p2b-1),6,4,3,2,1,5,-1.0d0) 2347 END IF 2348 IF ((p2b .le. p9b)) THEN 2349 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p9b_1 2350 & - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1 2351 &+ nvab * (h7b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1))))))) 2352 CALL TCE_SORT_6(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 2353 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),int_mb(k_range+p1b-1) 2354 &,int_mb(k_range+p2b-1),int_mb(k_range+p9b-1),5,4,3,2,1,6,1.0d0) 2355 END IF 2356 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_4',3,MA_ER 2357 &R) 2358 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2359 & ERRQUIT('ccsdt2_q_left_4',4,MA_ERR) 2360 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2361 &ccsdt2_q_left_4',5,MA_ERR) 2362 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2 2363 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p9b_2 - noab - 1 2364 &+ nvab * (h8b_2 - 1))))) 2365 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 2366 &,int_mb(k_range+p9b-1),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1) 2367 &,4,3,1,2,1.0d0) 2368 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt2_q_left_4',6,MA_ER 2369 &R) 2370 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2371 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2372 &t),dima_sort) 2373 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt2_q_left_4',7, 2374 &MA_ERR) 2375 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_4',8, 2376 &MA_ERR) 2377 END IF 2378 END IF 2379 END IF 2380 END DO 2381 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2382 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2383 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 2384 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2385 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2386 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2387 &mb(k_range+h5b-1),8,7,6,3,5,4,2,1,-1.0d0) 2388 END IF 2389 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2390 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2391 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2392 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2393 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2394 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2395 &mb(k_range+h5b-1),8,7,6,3,2,5,4,1,-1.0d0) 2396 END IF 2397 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2398 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2399 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2400 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2401 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2402 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2403 &mb(k_range+h5b-1),8,7,6,3,2,5,1,4,1.0d0) 2404 END IF 2405 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2406 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2407 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2408 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2409 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2410 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2411 &mb(k_range+h5b-1),8,7,6,3,5,2,4,1,1.0d0) 2412 END IF 2413 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2414 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2415 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2416 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2417 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2418 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2419 &mb(k_range+h5b-1),8,7,6,3,5,2,1,4,-1.0d0) 2420 END IF 2421 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h7b) 2422 & .and. (t_h8b .eq. h8b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2423 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 2424 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2425 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2426 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2427 &mb(k_range+h5b-1),8,7,6,3,2,1,5,4,-1.0d0) 2428 END IF 2429 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2430 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2431 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 2432 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2433 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2434 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2435 &mb(k_range+h5b-1),3,8,7,6,5,4,2,1,1.0d0) 2436 END IF 2437 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2438 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2439 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2440 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2441 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2442 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2443 &mb(k_range+h5b-1),3,8,7,6,2,5,4,1,1.0d0) 2444 END IF 2445 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2446 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2447 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2448 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2449 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2450 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2451 &mb(k_range+h5b-1),3,8,7,6,2,5,1,4,-1.0d0) 2452 END IF 2453 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2454 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2455 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2456 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2457 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2458 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2459 &mb(k_range+h5b-1),3,8,7,6,5,2,4,1,-1.0d0) 2460 END IF 2461 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2462 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2463 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2464 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2465 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2466 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2467 &mb(k_range+h5b-1),3,8,7,6,5,2,1,4,1.0d0) 2468 END IF 2469 IF ((t_h5b .eq. h8b) .and. (t_h6b .eq. h5b) .and. (t_h7b .eq. h6b) 2470 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2471 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 2472 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2473 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2474 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2475 &mb(k_range+h5b-1),3,8,7,6,2,1,5,4,1.0d0) 2476 END IF 2477 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2478 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2479 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 2480 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2481 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2482 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2483 &mb(k_range+h5b-1),8,3,7,6,5,4,2,1,-1.0d0) 2484 END IF 2485 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2486 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2487 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2488 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2489 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2490 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2491 &mb(k_range+h5b-1),8,3,7,6,2,5,4,1,-1.0d0) 2492 END IF 2493 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2494 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2495 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2496 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2497 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2498 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2499 &mb(k_range+h5b-1),8,3,7,6,2,5,1,4,1.0d0) 2500 END IF 2501 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2502 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2503 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2504 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2505 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2506 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2507 &mb(k_range+h5b-1),8,3,7,6,5,2,4,1,1.0d0) 2508 END IF 2509 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2510 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2511 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2512 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2513 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2514 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2515 &mb(k_range+h5b-1),8,3,7,6,5,2,1,4,-1.0d0) 2516 END IF 2517 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h8b) .and. (t_h7b .eq. h6b) 2518 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2519 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 2520 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2521 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2522 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2523 &mb(k_range+h5b-1),8,3,7,6,2,1,5,4,-1.0d0) 2524 END IF 2525 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2526 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2527 &2b) .and. (t_p3b .eq. p3b) .and. (t_p4b .eq. p4b)) THEN 2528 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2529 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2530 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2531 &mb(k_range+h5b-1),8,7,3,6,5,4,2,1,1.0d0) 2532 END IF 2533 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2534 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2535 &1b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2536 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2537 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2538 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2539 &mb(k_range+h5b-1),8,7,3,6,2,5,4,1,1.0d0) 2540 END IF 2541 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2542 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2543 &1b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2544 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2545 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2546 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2547 &mb(k_range+h5b-1),8,7,3,6,2,5,1,4,-1.0d0) 2548 END IF 2549 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2550 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2551 &3b) .and. (t_p3b .eq. p2b) .and. (t_p4b .eq. p4b)) THEN 2552 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2553 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2554 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2555 &mb(k_range+h5b-1),8,7,3,6,5,2,4,1,-1.0d0) 2556 END IF 2557 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2558 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p 2559 &3b) .and. (t_p3b .eq. p4b) .and. (t_p4b .eq. p2b)) THEN 2560 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2561 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2562 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2563 &mb(k_range+h5b-1),8,7,3,6,5,2,1,4,1.0d0) 2564 END IF 2565 IF ((t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) .and. (t_h7b .eq. h8b) 2566 & .and. (t_h8b .eq. h7b) .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p 2567 &4b) .and. (t_p3b .eq. p1b) .and. (t_p4b .eq. p2b)) THEN 2568 CALL TCE_SORTACC_8(dbl_mb(k_c_sort),a_c,int_mb(k_range+p4b-1),int_ 2569 &mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+p2b-1),int_ 2570 &mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h6b-1),int_ 2571 &mb(k_range+h5b-1),8,7,3,6,2,1,5,4,1.0d0) 2572 END IF 2573 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt2_q_left_4',9, 2574 &MA_ERR) 2575 END IF 2576 END IF 2577 END IF 2578 END IF 2579 END DO 2580 END DO 2581 END DO 2582 END DO 2583 END DO 2584 END DO 2585 END DO 2586 END DO 2587 RETURN 2588 END 2589 SUBROUTINE ccsdt2_q_left_4_1(d_a,k_a_offset,d_c,k_c_offset) 2590C $Id$ 2591C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2592C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2593C i1 ( h5 p9 p1 p2 )_v + = 1 * v ( h5 p9 p1 p2 )_v 2594 IMPLICIT NONE 2595#include "global.fh" 2596#include "mafdecls.fh" 2597#include "sym.fh" 2598#include "errquit.fh" 2599#include "tce.fh" 2600 INTEGER d_a 2601 INTEGER k_a_offset 2602 INTEGER d_c 2603 INTEGER k_c_offset 2604 INTEGER nxtask 2605 INTEGER next 2606 INTEGER nprocs 2607 INTEGER count 2608 INTEGER h5b 2609 INTEGER p9b 2610 INTEGER p1b 2611 INTEGER p2b 2612 INTEGER dimc 2613 INTEGER h5b_1 2614 INTEGER p9b_1 2615 INTEGER p1b_1 2616 INTEGER p2b_1 2617 INTEGER dim_common 2618 INTEGER dima_sort 2619 INTEGER dima 2620 INTEGER l_a_sort 2621 INTEGER k_a_sort 2622 INTEGER l_a 2623 INTEGER k_a 2624 INTEGER l_c 2625 INTEGER k_c 2626 EXTERNAL nxtask 2627 nprocs = GA_NNODES() 2628 count = 0 2629 next = nxtask(nprocs,1) 2630 DO h5b = 1,noab 2631 DO p9b = noab+1,noab+nvab 2632 DO p1b = noab+1,noab+nvab 2633 DO p2b = p1b,noab+nvab 2634 IF (next.eq.count) THEN 2635 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1 2636 &)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1).ne.8)) THEN 2637 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+p 2638 &1b-1)+int_mb(k_spin+p2b-1)) THEN 2639 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb( 2640 &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. irrep_v) THEN 2641 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+p9b-1) * int_mb(k_ra 2642 &nge+p1b-1) * int_mb(k_range+p2b-1) 2643 CALL TCE_RESTRICTED_4(h5b,p9b,p1b,p2b,h5b_1,p9b_1,p1b_1,p2b_1) 2644 dim_common = 1 2645 dima_sort = int_mb(k_range+h5b-1) * int_mb(k_range+p9b-1) * int_mb 2646 &(k_range+p1b-1) * int_mb(k_range+p2b-1) 2647 dima = dim_common * dima_sort 2648 IF (dima .gt. 0) THEN 2649 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2650 & ERRQUIT('ccsdt2_q_left_4_1',0,MA_ERR) 2651 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2652 &ccsdt2_q_left_4_1',1,MA_ERR) 2653 IF ((h5b .le. p9b)) THEN 2654 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 2655 & - 1 + (noab+nvab) * (p1b_1 - 1 + (noab+nvab) * (p9b_1 - 1 + (noab 2656 &+nvab) * (h5b_1 - 1))))) 2657 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h5b-1) 2658 &,int_mb(k_range+p9b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1) 2659 &,4,3,2,1,1.0d0) 2660 END IF 2661 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_4_1',2,MA_ 2662 &ERR) 2663 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2664 &ccsdt2_q_left_4_1',3,MA_ERR) 2665 CALL TCE_SORT_4(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 2666 &,int_mb(k_range+p1b-1),int_mb(k_range+p9b-1),int_mb(k_range+h5b-1) 2667 &,4,3,2,1,1.0d0) 2668 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b - 2669 & noab - 1 + nvab * (p1b - noab - 1 + nvab * (p9b - noab - 1 + nvab 2670 & * (h5b - 1))))) 2671 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt2_q_left_4_1',4,MA_ 2672 &ERR) 2673 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_4_1', 2674 &5,MA_ERR) 2675 END IF 2676 END IF 2677 END IF 2678 END IF 2679 next = nxtask(nprocs,1) 2680 END IF 2681 count = count + 1 2682 END DO 2683 END DO 2684 END DO 2685 END DO 2686 next = nxtask(-nprocs,1) 2687 call GA_SYNC() 2688 RETURN 2689 END 2690 SUBROUTINE OFFSET_ccsdt2_q_left_4_1(l_a_offset,k_a_offset,size) 2691C $Id$ 2692C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2693C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2694C i1 ( h5 p9 p1 p2 )_v 2695 IMPLICIT NONE 2696#include "global.fh" 2697#include "mafdecls.fh" 2698#include "sym.fh" 2699#include "errquit.fh" 2700#include "tce.fh" 2701 INTEGER l_a_offset 2702 INTEGER k_a_offset 2703 INTEGER size 2704 INTEGER length 2705 INTEGER addr 2706 INTEGER h5b 2707 INTEGER p9b 2708 INTEGER p1b 2709 INTEGER p2b 2710 length = 0 2711 DO h5b = 1,noab 2712 DO p9b = noab+1,noab+nvab 2713 DO p1b = noab+1,noab+nvab 2714 DO p2b = p1b,noab+nvab 2715 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+p 2716 &1b-1)+int_mb(k_spin+p2b-1)) THEN 2717 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb( 2718 &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. irrep_v) THEN 2719 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1 2720 &)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1).ne.8)) THEN 2721 length = length + 1 2722 END IF 2723 END IF 2724 END IF 2725 END DO 2726 END DO 2727 END DO 2728 END DO 2729 IF (.not.MA_PUSH_GET(mt_int,2*length+1,'noname',l_a_offset,k_a_off 2730 &set)) CALL ERRQUIT('ccsdt2_q_left_4_1',0,MA_ERR) 2731 int_mb(k_a_offset) = length 2732 addr = 0 2733 size = 0 2734 DO h5b = 1,noab 2735 DO p9b = noab+1,noab+nvab 2736 DO p1b = noab+1,noab+nvab 2737 DO p2b = p1b,noab+nvab 2738 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+p 2739 &1b-1)+int_mb(k_spin+p2b-1)) THEN 2740 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb( 2741 &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. irrep_v) THEN 2742 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1 2743 &)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1).ne.8)) THEN 2744 addr = addr + 1 2745 int_mb(k_a_offset+addr) = p2b - noab - 1 + nvab * (p1b - noab - 1 2746 &+ nvab * (p9b - noab - 1 + nvab * (h5b - 1))) 2747 int_mb(k_a_offset+length+addr) = size 2748 size = size + int_mb(k_range+h5b-1) * int_mb(k_range+p9b-1) * int_ 2749 &mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 2750 END IF 2751 END IF 2752 END IF 2753 END DO 2754 END DO 2755 END DO 2756 END DO 2757 RETURN 2758 END 2759 SUBROUTINE ccsdt2_q_left_4_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c 2760 &_offset) 2761C $Id$ 2762C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 2763C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 2764C i1 ( h5 p9 p1 p2 )_vt + = -1 * Sum ( h10 ) * t ( p9 h10 )_t * v ( h5 h10 p1 p2 )_v 2765 IMPLICIT NONE 2766#include "global.fh" 2767#include "mafdecls.fh" 2768#include "sym.fh" 2769#include "errquit.fh" 2770#include "tce.fh" 2771 INTEGER d_a 2772 INTEGER k_a_offset 2773 INTEGER d_b 2774 INTEGER k_b_offset 2775 INTEGER d_c 2776 INTEGER k_c_offset 2777 INTEGER nxtask 2778 INTEGER next 2779 INTEGER nprocs 2780 INTEGER count 2781 INTEGER h5b 2782 INTEGER p9b 2783 INTEGER p1b 2784 INTEGER p2b 2785 INTEGER dimc 2786 INTEGER l_c_sort 2787 INTEGER k_c_sort 2788 INTEGER h10b 2789 INTEGER p9b_1 2790 INTEGER h10b_1 2791 INTEGER h5b_2 2792 INTEGER h10b_2 2793 INTEGER p1b_2 2794 INTEGER p2b_2 2795 INTEGER dim_common 2796 INTEGER dima_sort 2797 INTEGER dima 2798 INTEGER dimb_sort 2799 INTEGER dimb 2800 INTEGER l_a_sort 2801 INTEGER k_a_sort 2802 INTEGER l_a 2803 INTEGER k_a 2804 INTEGER l_b_sort 2805 INTEGER k_b_sort 2806 INTEGER l_b 2807 INTEGER k_b 2808 INTEGER l_c 2809 INTEGER k_c 2810 EXTERNAL nxtask 2811 nprocs = GA_NNODES() 2812 count = 0 2813 next = nxtask(nprocs,1) 2814 DO h5b = 1,noab 2815 DO p9b = noab+1,noab+nvab 2816 DO p1b = noab+1,noab+nvab 2817 DO p2b = p1b,noab+nvab 2818 IF (next.eq.count) THEN 2819 IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1 2820 &)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1).ne.8)) THEN 2821 IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+p 2822 &1b-1)+int_mb(k_spin+p2b-1)) THEN 2823 IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+p9b-1),ieor(int_mb( 2824 &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. ieor(irrep_v,irrep_t)) TH 2825 &EN 2826 dimc = int_mb(k_range+h5b-1) * int_mb(k_range+p9b-1) * int_mb(k_ra 2827 &nge+p1b-1) * int_mb(k_range+p2b-1) 2828 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 2829 & ERRQUIT('ccsdt2_q_left_4_2',0,MA_ERR) 2830 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 2831 DO h10b = 1,noab 2832 IF (int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h10b-1)) THEN 2833 IF (ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+h10b-1)) .eq. irrep_t) T 2834 &HEN 2835 CALL TCE_RESTRICTED_2(p9b,h10b,p9b_1,h10b_1) 2836 CALL TCE_RESTRICTED_4(h5b,h10b,p1b,p2b,h5b_2,h10b_2,p1b_2,p2b_2) 2837 dim_common = int_mb(k_range+h10b-1) 2838 dima_sort = int_mb(k_range+p9b-1) 2839 dima = dim_common * dima_sort 2840 dimb_sort = int_mb(k_range+h5b-1) * int_mb(k_range+p1b-1) * int_mb 2841 &(k_range+p2b-1) 2842 dimb = dim_common * dimb_sort 2843 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 2844 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 2845 & ERRQUIT('ccsdt2_q_left_4_2',1,MA_ERR) 2846 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 2847 &ccsdt2_q_left_4_2',2,MA_ERR) 2848 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 2849 &1 - 1 + noab * (p9b_1 - noab - 1))) 2850 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 2851 &,int_mb(k_range+h10b-1),1,2,1.0d0) 2852 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt2_q_left_4_2',3,MA_ 2853 &ERR) 2854 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 2855 & ERRQUIT('ccsdt2_q_left_4_2',4,MA_ERR) 2856 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 2857 &ccsdt2_q_left_4_2',5,MA_ERR) 2858 IF ((h10b .lt. h5b)) THEN 2859 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 2860 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h5b_2 - 1 + (noab 2861 &+nvab) * (h10b_2 - 1))))) 2862 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h10b-1 2863 &),int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1 2864 &),4,3,2,1,-1.0d0) 2865 END IF 2866 IF ((h5b .le. h10b)) THEN 2867 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 2868 & - 1 + (noab+nvab) * (p1b_2 - 1 + (noab+nvab) * (h10b_2 - 1 + (noa 2869 &b+nvab) * (h5b_2 - 1))))) 2870 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 2871 &,int_mb(k_range+h10b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1 2872 &),4,3,1,2,1.0d0) 2873 END IF 2874 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt2_q_left_4_2',6,MA_ 2875 &ERR) 2876 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 2877 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 2878 &t),dima_sort) 2879 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt2_q_left_4_2', 2880 &7,MA_ERR) 2881 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt2_q_left_4_2', 2882 &8,MA_ERR) 2883 END IF 2884 END IF 2885 END IF 2886 END DO 2887 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 2888 &ccsdt2_q_left_4_2',9,MA_ERR) 2889 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 2890 &,int_mb(k_range+p1b-1),int_mb(k_range+h5b-1),int_mb(k_range+p9b-1) 2891 &,3,4,2,1,-1.0d0) 2892 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b - 2893 & noab - 1 + nvab * (p1b - noab - 1 + nvab * (p9b - noab - 1 + nvab 2894 & * (h5b - 1))))) 2895 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt2_q_left_4_2',10,MA 2896 &_ERR) 2897 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt2_q_left_4_2', 2898 &11,MA_ERR) 2899 END IF 2900 END IF 2901 END IF 2902 next = nxtask(nprocs,1) 2903 END IF 2904 count = count + 1 2905 END DO 2906 END DO 2907 END DO 2908 END DO 2909 next = nxtask(-nprocs,1) 2910 call GA_SYNC() 2911 RETURN 2912 END 2913