1 SUBROUTINE lambda_ccsd_t_left(a_i0,d_f1,d_v2,d_y1,d_y2,k_f1_offset 2 &,k_v2_offset,k_y1_offset,k_y2_offset,t_h4b,t_h5b,t_h6b,t_p1b,t_p2b 3 &,t_p3b,toggle) 4C $Id$ 5C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 6C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 7C i0 ( h4 h5 h6 p1 p2 p3 )_yv + = 1 * P( 9 ) * y ( h4 p1 )_y * v ( h5 h6 p2 p3 )_v 8C i0 ( h4 h5 h6 p1 p2 p3 )_yf + = 1 * P( 9 ) * y ( h4 h5 p1 p2 )_y * f ( h6 p3 )_f 9C i0 ( h4 h5 h6 p1 p2 p3 )_yv + = -1 * P( 9 ) * Sum ( h7 ) * y ( h4 h7 p1 p2 )_y * v ( h5 h6 h7 p3 )_v 10C i0 ( h4 h5 h6 p1 p2 p3 )_yv + = -1 * P( 9 ) * Sum ( p7 ) * y ( h4 h5 p1 p7 )_y * v ( h6 p7 p2 p3 )_v 11 IMPLICIT NONE 12#include "global.fh" 13#include "mafdecls.fh" 14#include "util.fh" 15#include "errquit.fh" 16#include "tce.fh" 17 INTEGER t_h4b 18 INTEGER t_h5b 19 INTEGER t_h6b 20 INTEGER t_p1b 21 INTEGER t_p2b 22 INTEGER t_p3b 23 INTEGER toggle 24 INTEGER d_y1 25 INTEGER k_y1_offset 26 INTEGER d_v2 27 INTEGER k_v2_offset 28 INTEGER d_y2 29 INTEGER k_y2_offset 30 INTEGER d_f1 31 INTEGER k_f1_offset 32 DOUBLE PRECISION a_i0(*) 33 IF (toggle .eq. 1) CALL lambda_ccsd_t_left_1(d_y1,k_y1_offset,d_v2 34 &,k_v2_offset,a_i0,t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 35 IF (toggle .eq. 2) CALL lambda_ccsd_t_left_2(d_y2,k_y2_offset,d_f1 36 &,k_f1_offset,a_i0,t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 37 IF (toggle .eq. 2) CALL lambda_ccsd_t_left_3(d_y2,k_y2_offset,d_v2 38 &,k_v2_offset,a_i0,t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 39 IF (toggle .eq. 2) CALL lambda_ccsd_t_left_4(d_y2,k_y2_offset,d_v2 40 &,k_v2_offset,a_i0,t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 41 RETURN 42 END 43 SUBROUTINE lambda_ccsd_t_left_1(d_a,k_a_offset,d_b,k_b_offset,a_c, 44 &t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 45C $Id$ 46C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 47C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 48C i0 ( h4 h5 h6 p1 p2 p3 )_yv + = 1 * P( 9 ) * y ( h4 p1 )_y * v ( h5 h6 p2 p3 )_v 49 IMPLICIT NONE 50#include "global.fh" 51#include "mafdecls.fh" 52#include "sym.fh" 53#include "errquit.fh" 54#include "tce.fh" 55 INTEGER d_a 56 INTEGER k_a_offset 57 INTEGER d_b 58 INTEGER k_b_offset 59 INTEGER t_h4b 60 INTEGER t_h5b 61 INTEGER t_h6b 62 INTEGER t_p1b 63 INTEGER t_p2b 64 INTEGER t_p3b 65 INTEGER h4b 66 INTEGER h5b 67 INTEGER h6b 68 INTEGER p1b 69 INTEGER p2b 70 INTEGER p3b 71 INTEGER dimc 72 INTEGER l_c_sort 73 INTEGER k_c_sort 74 INTEGER h4b_1 75 INTEGER p1b_1 76 INTEGER h5b_2 77 INTEGER h6b_2 78 INTEGER p2b_2 79 INTEGER p3b_2 80 INTEGER dim_common 81 INTEGER dima_sort 82 INTEGER dima 83 INTEGER dimb_sort 84 INTEGER dimb 85 INTEGER l_a_sort 86 INTEGER k_a_sort 87 INTEGER l_a 88 INTEGER k_a 89 INTEGER l_b_sort 90 INTEGER k_b_sort 91 INTEGER l_b 92 INTEGER k_b 93 DOUBLE PRECISION a_c(*) 94 LOGICAL skipped 95 DO h4b = 1,noab 96 DO h5b = 1,noab 97 DO h6b = h5b,noab 98 DO p1b = noab+1,noab+nvab 99 DO p2b = noab+1,noab+nvab 100 DO p3b = p2b,noab+nvab 101 skipped = .true. 102 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 103 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 104 &3b)) skipped = .false. 105 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 106 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 107 &3b)) skipped = .false. 108 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 109 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 110 &1b)) skipped = .false. 111 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 112 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 113 &3b)) skipped = .false. 114 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 115 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 116 &3b)) skipped = .false. 117 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 118 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 119 &1b)) skipped = .false. 120 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 121 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 122 &3b)) skipped = .false. 123 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 124 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 125 &3b)) skipped = .false. 126 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 127 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 128 &1b)) skipped = .false. 129 IF (.not.skipped) THEN 130 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 131 &)+int_mb(k_spin+h6b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+i 132 &nt_mb(k_spin+p3b-1).ne.12)) THEN 133 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) 134 & .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b- 135 &1)) THEN 136 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 137 &k_sym+h6b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),int 138 &_mb(k_sym+p3b-1)))))) .eq. ieor(irrep_y,irrep_v)) THEN 139 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra 140 &nge+h6b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m 141 &b(k_range+p3b-1) 142 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 143 & ERRQUIT('lambda_ccsd_t_left_1',0,MA_ERR) 144 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 145 IF (int_mb(k_spin+h4b-1) .eq. int_mb(k_spin+p1b-1)) THEN 146 IF (ieor(int_mb(k_sym+h4b-1),int_mb(k_sym+p1b-1)) .eq. irrep_y) TH 147 &EN 148 CALL TCE_RESTRICTED_2(h4b,p1b,h4b_1,p1b_1) 149 CALL TCE_RESTRICTED_4(h5b,h6b,p2b,p3b,h5b_2,h6b_2,p2b_2,p3b_2) 150 dim_common = 1 151 dima_sort = int_mb(k_range+h4b-1) * int_mb(k_range+p1b-1) 152 dima = dim_common * dima_sort 153 dimb_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 154 &(k_range+p2b-1) * int_mb(k_range+p3b-1) 155 dimb = dim_common * dimb_sort 156 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 157 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 158 & ERRQUIT('lambda_ccsd_t_left_1',1,MA_ERR) 159 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 160 &lambda_ccsd_t_left_1',2,MA_ERR) 161 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 162 & - noab - 1 + nvab * (h4b_1 - 1))) 163 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h4b-1) 164 &,int_mb(k_range+p1b-1),2,1,1.0d0) 165 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('lambda_ccsd_t_left_1',3, 166 &MA_ERR) 167 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 168 & ERRQUIT('lambda_ccsd_t_left_1',4,MA_ERR) 169 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 170 &lambda_ccsd_t_left_1',5,MA_ERR) 171 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 172 & - 1 + (noab+nvab) * (p2b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 173 &+nvab) * (h5b_2 - 1))))) 174 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 175 &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1) 176 &,4,3,2,1,1.0d0) 177 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('lambda_ccsd_t_left_1',6, 178 &MA_ERR) 179 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 180 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 181 &t),dima_sort) 182 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 183 &1',7,MA_ERR) 184 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 185 &1',8,MA_ERR) 186 END IF 187 END IF 188 END IF 189 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 190 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 191 &3b)) THEN 192 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 193 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 194 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),6,4,3,5,2,1,1.0d0) 195 END IF 196 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 197 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 198 &3b)) THEN 199 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 200 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 201 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),6,4,3,2,5,1,-1.0d0) 202 END IF 203 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 204 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 205 &1b)) THEN 206 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 207 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 208 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),6,4,3,2,1,5,1.0d0) 209 END IF 210 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 211 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 212 &3b)) THEN 213 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 214 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 215 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),4,6,3,5,2,1,-1.0d0) 216 END IF 217 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 218 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 219 &3b)) THEN 220 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 221 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 222 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),4,6,3,2,5,1,1.0d0) 223 END IF 224 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 225 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 226 &1b)) THEN 227 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 228 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 229 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),4,6,3,2,1,5,-1.0d0) 230 END IF 231 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 232 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 233 &3b)) THEN 234 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 235 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 236 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),4,3,6,5,2,1,1.0d0) 237 END IF 238 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 239 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 240 &3b)) THEN 241 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 242 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 243 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),4,3,6,2,5,1,-1.0d0) 244 END IF 245 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 246 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 247 &1b)) THEN 248 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 249 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_ 250 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),4,3,6,2,1,5,1.0d0) 251 END IF 252 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 253 &1',9,MA_ERR) 254 END IF 255 END IF 256 END IF 257 END IF 258 END DO 259 END DO 260 END DO 261 END DO 262 END DO 263 END DO 264 RETURN 265 END 266 SUBROUTINE lambda_ccsd_t_left_2(d_a,k_a_offset,d_b,k_b_offset,a_c, 267 &t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 268C $Id$ 269C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 270C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 271C i0 ( h4 h5 h6 p1 p2 p3 )_yf + = 1 * P( 9 ) * y ( h4 h5 p1 p2 )_y * f ( h6 p3 )_f 272 IMPLICIT NONE 273#include "global.fh" 274#include "mafdecls.fh" 275#include "sym.fh" 276#include "errquit.fh" 277#include "tce.fh" 278 INTEGER d_a 279 INTEGER k_a_offset 280 INTEGER d_b 281 INTEGER k_b_offset 282 INTEGER t_h4b 283 INTEGER t_h5b 284 INTEGER t_h6b 285 INTEGER t_p1b 286 INTEGER t_p2b 287 INTEGER t_p3b 288 INTEGER h4b 289 INTEGER h5b 290 INTEGER h6b 291 INTEGER p1b 292 INTEGER p2b 293 INTEGER p3b 294 INTEGER dimc 295 INTEGER l_c_sort 296 INTEGER k_c_sort 297 INTEGER h4b_1 298 INTEGER h5b_1 299 INTEGER p1b_1 300 INTEGER p2b_1 301 INTEGER h6b_2 302 INTEGER p3b_2 303 INTEGER dim_common 304 INTEGER dima_sort 305 INTEGER dima 306 INTEGER dimb_sort 307 INTEGER dimb 308 INTEGER l_a_sort 309 INTEGER k_a_sort 310 INTEGER l_a 311 INTEGER k_a 312 INTEGER l_b_sort 313 INTEGER k_b_sort 314 INTEGER l_b 315 INTEGER k_b 316 DOUBLE PRECISION a_c(*) 317 LOGICAL skipped 318 DO h4b = 1,noab 319 DO h5b = h4b,noab 320 DO h6b = 1,noab 321 DO p1b = noab+1,noab+nvab 322 DO p2b = p1b,noab+nvab 323 DO p3b = noab+1,noab+nvab 324 skipped = .true. 325 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 326 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 327 &3b)) skipped = .false. 328 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 329 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 330 &2b)) skipped = .false. 331 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 332 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 333 &2b)) skipped = .false. 334 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 335 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 336 &3b)) skipped = .false. 337 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 338 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 339 &2b)) skipped = .false. 340 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 341 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 342 &2b)) skipped = .false. 343 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 344 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 345 &3b)) skipped = .false. 346 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 347 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 348 &2b)) skipped = .false. 349 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 350 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 351 &2b)) skipped = .false. 352 IF (.not.skipped) THEN 353 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 354 &)+int_mb(k_spin+h6b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+i 355 &nt_mb(k_spin+p3b-1).ne.12)) THEN 356 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) 357 & .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b- 358 &1)) THEN 359 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 360 &k_sym+h6b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),int 361 &_mb(k_sym+p3b-1)))))) .eq. ieor(irrep_y,irrep_f)) THEN 362 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra 363 &nge+h6b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m 364 &b(k_range+p3b-1) 365 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 366 & ERRQUIT('lambda_ccsd_t_left_2',0,MA_ERR) 367 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 368 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p 369 &1b-1)+int_mb(k_spin+p2b-1)) THEN 370 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 371 &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. irrep_y) THEN 372 CALL TCE_RESTRICTED_4(h4b,h5b,p1b,p2b,h4b_1,h5b_1,p1b_1,p2b_1) 373 CALL TCE_RESTRICTED_2(h6b,p3b,h6b_2,p3b_2) 374 dim_common = 1 375 dima_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb 376 &(k_range+p1b-1) * int_mb(k_range+p2b-1) 377 dima = dim_common * dima_sort 378 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p3b-1) 379 dimb = dim_common * dimb_sort 380 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 381 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 382 & ERRQUIT('lambda_ccsd_t_left_2',1,MA_ERR) 383 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 384 &lambda_ccsd_t_left_2',2,MA_ERR) 385 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 386 & - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (h5b_1 - 1 + noab 387 &* (h4b_1 - 1))))) 388 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h4b-1) 389 &,int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1) 390 &,4,3,2,1,1.0d0) 391 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('lambda_ccsd_t_left_2',3, 392 &MA_ERR) 393 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 394 & ERRQUIT('lambda_ccsd_t_left_2',4,MA_ERR) 395 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 396 &lambda_ccsd_t_left_2',5,MA_ERR) 397 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 398 & - 1 + (noab+nvab) * (h6b_2 - 1))) 399 CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 400 &,int_mb(k_range+p3b-1),2,1,1.0d0) 401 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('lambda_ccsd_t_left_2',6, 402 &MA_ERR) 403 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 404 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 405 &t),dima_sort) 406 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 407 &2',7,MA_ERR) 408 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 409 &2',8,MA_ERR) 410 END IF 411 END IF 412 END IF 413 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 414 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 415 &3b)) THEN 416 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 417 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 418 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,2,4,3,1,1.0d0) 419 END IF 420 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 421 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 422 &2b)) THEN 423 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 424 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 425 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,2,1,4,3,1.0d0) 426 END IF 427 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 428 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 429 &2b)) THEN 430 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 431 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 432 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,2,4,1,3,-1.0d0) 433 END IF 434 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 435 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 436 &3b)) THEN 437 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 438 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 439 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),2,6,5,4,3,1,1.0d0) 440 END IF 441 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 442 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 443 &2b)) THEN 444 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 445 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 446 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),2,6,5,1,4,3,1.0d0) 447 END IF 448 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 449 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 450 &2b)) THEN 451 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 452 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 453 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),2,6,5,4,1,3,-1.0d0) 454 END IF 455 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 456 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 457 &3b)) THEN 458 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 459 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 460 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,2,5,4,3,1,-1.0d0) 461 END IF 462 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 463 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 464 &2b)) THEN 465 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 466 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 467 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,2,5,1,4,3,-1.0d0) 468 END IF 469 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 470 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 471 &2b)) THEN 472 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 473 &mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1),int_ 474 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,2,5,4,1,3,1.0d0) 475 END IF 476 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 477 &2',9,MA_ERR) 478 END IF 479 END IF 480 END IF 481 END IF 482 END DO 483 END DO 484 END DO 485 END DO 486 END DO 487 END DO 488 RETURN 489 END 490 SUBROUTINE lambda_ccsd_t_left_3(d_a,k_a_offset,d_b,k_b_offset,a_c, 491 &t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 492C $Id$ 493C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 494C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 495C i0 ( h4 h5 h6 p1 p2 p3 )_yv + = -1 * P( 9 ) * Sum ( h7 ) * y ( h4 h7 p1 p2 )_y * v ( h5 h6 h7 p3 )_v 496 IMPLICIT NONE 497#include "global.fh" 498#include "mafdecls.fh" 499#include "sym.fh" 500#include "errquit.fh" 501#include "tce.fh" 502 INTEGER d_a 503 INTEGER k_a_offset 504 INTEGER d_b 505 INTEGER k_b_offset 506 INTEGER t_h4b 507 INTEGER t_h5b 508 INTEGER t_h6b 509 INTEGER t_p1b 510 INTEGER t_p2b 511 INTEGER t_p3b 512 INTEGER h4b 513 INTEGER h5b 514 INTEGER h6b 515 INTEGER p1b 516 INTEGER p2b 517 INTEGER p3b 518 INTEGER dimc 519 INTEGER l_c_sort 520 INTEGER k_c_sort 521 INTEGER h7b 522 INTEGER h4b_1 523 INTEGER h7b_1 524 INTEGER p1b_1 525 INTEGER p2b_1 526 INTEGER h5b_2 527 INTEGER h6b_2 528 INTEGER p3b_2 529 INTEGER h7b_2 530 INTEGER dim_common 531 INTEGER dima_sort 532 INTEGER dima 533 INTEGER dimb_sort 534 INTEGER dimb 535 INTEGER l_a_sort 536 INTEGER k_a_sort 537 INTEGER l_a 538 INTEGER k_a 539 INTEGER l_b_sort 540 INTEGER k_b_sort 541 INTEGER l_b 542 INTEGER k_b 543 DOUBLE PRECISION a_c(*) 544 LOGICAL skipped 545 DO h4b = 1,noab 546 DO h5b = 1,noab 547 DO h6b = h5b,noab 548 DO p1b = noab+1,noab+nvab 549 DO p2b = p1b,noab+nvab 550 DO p3b = noab+1,noab+nvab 551 skipped = .true. 552 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 553 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 554 &3b)) skipped = .false. 555 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 556 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 557 &2b)) skipped = .false. 558 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 559 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 560 &2b)) skipped = .false. 561 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 562 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 563 &3b)) skipped = .false. 564 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 565 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 566 &2b)) skipped = .false. 567 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 568 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 569 &2b)) skipped = .false. 570 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 571 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 572 &3b)) skipped = .false. 573 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 574 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 575 &2b)) skipped = .false. 576 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 577 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 578 &2b)) skipped = .false. 579 IF (.not.skipped) THEN 580 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 581 &)+int_mb(k_spin+h6b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+i 582 &nt_mb(k_spin+p3b-1).ne.12)) THEN 583 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) 584 & .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b- 585 &1)) THEN 586 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 587 &k_sym+h6b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),int 588 &_mb(k_sym+p3b-1)))))) .eq. ieor(irrep_y,irrep_v)) THEN 589 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra 590 &nge+h6b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m 591 &b(k_range+p3b-1) 592 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 593 & ERRQUIT('lambda_ccsd_t_left_3',0,MA_ERR) 594 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 595 DO h7b = 1,noab 596 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1) .eq. int_mb(k_spin+p 597 &1b-1)+int_mb(k_spin+p2b-1)) THEN 598 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h7b-1),ieor(int_mb( 599 &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. irrep_y) THEN 600 CALL TCE_RESTRICTED_4(h4b,h7b,p1b,p2b,h4b_1,h7b_1,p1b_1,p2b_1) 601 CALL TCE_RESTRICTED_4(h5b,h6b,p3b,h7b,h5b_2,h6b_2,p3b_2,h7b_2) 602 dim_common = int_mb(k_range+h7b-1) 603 dima_sort = int_mb(k_range+h4b-1) * int_mb(k_range+p1b-1) * int_mb 604 &(k_range+p2b-1) 605 dima = dim_common * dima_sort 606 dimb_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb 607 &(k_range+p3b-1) 608 dimb = dim_common * dimb_sort 609 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 610 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 611 & ERRQUIT('lambda_ccsd_t_left_3',1,MA_ERR) 612 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 613 &lambda_ccsd_t_left_3',2,MA_ERR) 614 IF ((h7b .lt. h4b)) THEN 615 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 616 & - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (h4b_1 - 1 + noab 617 &* (h7b_1 - 1))))) 618 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h7b-1) 619 &,int_mb(k_range+h4b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1) 620 &,4,3,2,1,-1.0d0) 621 END IF 622 IF ((h4b .le. h7b)) THEN 623 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1 624 & - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (h7b_1 - 1 + noab 625 &* (h4b_1 - 1))))) 626 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h4b-1) 627 &,int_mb(k_range+h7b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1) 628 &,4,3,1,2,1.0d0) 629 END IF 630 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('lambda_ccsd_t_left_3',3, 631 &MA_ERR) 632 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 633 & ERRQUIT('lambda_ccsd_t_left_3',4,MA_ERR) 634 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 635 &lambda_ccsd_t_left_3',5,MA_ERR) 636 IF ((h7b .le. p3b)) THEN 637 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 638 & - 1 + (noab+nvab) * (h7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 639 &+nvab) * (h5b_2 - 1))))) 640 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 641 &,int_mb(k_range+h6b-1),int_mb(k_range+h7b-1),int_mb(k_range+p3b-1) 642 &,4,2,1,3,1.0d0) 643 END IF 644 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('lambda_ccsd_t_left_3',6, 645 &MA_ERR) 646 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 647 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 648 &t),dima_sort) 649 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 650 &3',7,MA_ERR) 651 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 652 &3',8,MA_ERR) 653 END IF 654 END IF 655 END IF 656 END DO 657 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 658 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 659 &3b)) THEN 660 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 661 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 662 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),6,3,2,5,4,1,-1.0d0) 663 END IF 664 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 665 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 666 &2b)) THEN 667 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 668 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 669 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),6,3,2,1,5,4,-1.0d0) 670 END IF 671 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 672 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 673 &2b)) THEN 674 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 675 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 676 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),6,3,2,5,1,4,1.0d0) 677 END IF 678 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 679 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 680 &3b)) THEN 681 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 682 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 683 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),3,6,2,5,4,1,1.0d0) 684 END IF 685 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 686 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 687 &2b)) THEN 688 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 689 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 690 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),3,6,2,1,5,4,1.0d0) 691 END IF 692 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h6b) 693 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 694 &2b)) THEN 695 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 696 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 697 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),3,6,2,5,1,4,-1.0d0) 698 END IF 699 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 700 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 701 &3b)) THEN 702 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 703 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 704 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),3,2,6,5,4,1,-1.0d0) 705 END IF 706 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 707 & .and. (t_p1b .eq. p3b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 708 &2b)) THEN 709 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 710 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 711 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),3,2,6,1,5,4,-1.0d0) 712 END IF 713 IF ((t_h4b .eq. h5b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h4b) 714 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 715 &2b)) THEN 716 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 717 &mb(k_range+h6b-1),int_mb(k_range+h5b-1),int_mb(k_range+p2b-1),int_ 718 &mb(k_range+p1b-1),int_mb(k_range+h4b-1),3,2,6,5,1,4,1.0d0) 719 END IF 720 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 721 &3',9,MA_ERR) 722 END IF 723 END IF 724 END IF 725 END IF 726 END DO 727 END DO 728 END DO 729 END DO 730 END DO 731 END DO 732 RETURN 733 END 734 SUBROUTINE lambda_ccsd_t_left_4(d_a,k_a_offset,d_b,k_b_offset,a_c, 735 &t_h4b,t_h5b,t_h6b,t_p1b,t_p2b,t_p3b) 736C $Id$ 737C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 738C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 739C i0 ( h4 h5 h6 p1 p2 p3 )_yv + = -1 * P( 9 ) * Sum ( p7 ) * y ( h4 h5 p1 p7 )_y * v ( h6 p7 p2 p3 )_v 740 IMPLICIT NONE 741#include "global.fh" 742#include "mafdecls.fh" 743#include "sym.fh" 744#include "errquit.fh" 745#include "tce.fh" 746 INTEGER d_a 747 INTEGER k_a_offset 748 INTEGER d_b 749 INTEGER k_b_offset 750 INTEGER t_h4b 751 INTEGER t_h5b 752 INTEGER t_h6b 753 INTEGER t_p1b 754 INTEGER t_p2b 755 INTEGER t_p3b 756 INTEGER h4b 757 INTEGER h5b 758 INTEGER h6b 759 INTEGER p1b 760 INTEGER p2b 761 INTEGER p3b 762 INTEGER dimc 763 INTEGER l_c_sort 764 INTEGER k_c_sort 765 INTEGER p7b 766 INTEGER h4b_1 767 INTEGER h5b_1 768 INTEGER p1b_1 769 INTEGER p7b_1 770 INTEGER h6b_2 771 INTEGER p7b_2 772 INTEGER p2b_2 773 INTEGER p3b_2 774 INTEGER dim_common 775 INTEGER dima_sort 776 INTEGER dima 777 INTEGER dimb_sort 778 INTEGER dimb 779 INTEGER l_a_sort 780 INTEGER k_a_sort 781 INTEGER l_a 782 INTEGER k_a 783 INTEGER l_b_sort 784 INTEGER k_b_sort 785 INTEGER l_b 786 INTEGER k_b 787 DOUBLE PRECISION a_c(*) 788 LOGICAL skipped 789 DO h4b = 1,noab 790 DO h5b = h4b,noab 791 DO h6b = 1,noab 792 DO p1b = noab+1,noab+nvab 793 DO p2b = noab+1,noab+nvab 794 DO p3b = p2b,noab+nvab 795 skipped = .true. 796 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 797 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 798 &3b)) skipped = .false. 799 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 800 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 801 &3b)) skipped = .false. 802 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 803 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 804 &1b)) skipped = .false. 805 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 806 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 807 &3b)) skipped = .false. 808 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 809 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 810 &3b)) skipped = .false. 811 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 812 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 813 &1b)) skipped = .false. 814 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 815 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 816 &3b)) skipped = .false. 817 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 818 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 819 &3b)) skipped = .false. 820 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 821 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 822 &1b)) skipped = .false. 823 IF (.not.skipped) THEN 824 IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1 825 &)+int_mb(k_spin+h6b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+i 826 &nt_mb(k_spin+p3b-1).ne.12)) THEN 827 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1) 828 & .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b- 829 &1)) THEN 830 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 831 &k_sym+h6b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),int 832 &_mb(k_sym+p3b-1)))))) .eq. ieor(irrep_y,irrep_v)) THEN 833 dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra 834 &nge+h6b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m 835 &b(k_range+p3b-1) 836 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 837 & ERRQUIT('lambda_ccsd_t_left_4',0,MA_ERR) 838 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 839 DO p7b = noab+1,noab+nvab 840 IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p 841 &1b-1)+int_mb(k_spin+p7b-1)) THEN 842 IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb( 843 &k_sym+p1b-1),int_mb(k_sym+p7b-1)))) .eq. irrep_y) THEN 844 CALL TCE_RESTRICTED_4(h4b,h5b,p1b,p7b,h4b_1,h5b_1,p1b_1,p7b_1) 845 CALL TCE_RESTRICTED_4(h6b,p7b,p2b,p3b,h6b_2,p7b_2,p2b_2,p3b_2) 846 dim_common = int_mb(k_range+p7b-1) 847 dima_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb 848 &(k_range+p1b-1) 849 dima = dim_common * dima_sort 850 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p2b-1) * int_mb 851 &(k_range+p3b-1) 852 dimb = dim_common * dimb_sort 853 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 854 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 855 & ERRQUIT('lambda_ccsd_t_left_4',1,MA_ERR) 856 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 857 &lambda_ccsd_t_left_4',2,MA_ERR) 858 IF ((p7b .lt. p1b)) THEN 859 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p1b_1 860 & - noab - 1 + nvab * (p7b_1 - noab - 1 + nvab * (h5b_1 - 1 + noab 861 &* (h4b_1 - 1))))) 862 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h4b-1) 863 &,int_mb(k_range+h5b-1),int_mb(k_range+p7b-1),int_mb(k_range+p1b-1) 864 &,4,2,1,3,-1.0d0) 865 END IF 866 IF ((p1b .le. p7b)) THEN 867 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p7b_1 868 & - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (h5b_1 - 1 + noab 869 &* (h4b_1 - 1))))) 870 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h4b-1) 871 &,int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1) 872 &,3,2,1,4,1.0d0) 873 END IF 874 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('lambda_ccsd_t_left_4',3, 875 &MA_ERR) 876 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 877 & ERRQUIT('lambda_ccsd_t_left_4',4,MA_ERR) 878 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 879 &lambda_ccsd_t_left_4',5,MA_ERR) 880 IF ((h6b .le. p7b)) THEN 881 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 882 & - 1 + (noab+nvab) * (p2b_2 - 1 + (noab+nvab) * (p7b_2 - 1 + (noab 883 &+nvab) * (h6b_2 - 1))))) 884 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 885 &,int_mb(k_range+p7b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1) 886 &,4,3,1,2,1.0d0) 887 END IF 888 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('lambda_ccsd_t_left_4',6, 889 &MA_ERR) 890 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 891 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 892 &t),dima_sort) 893 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 894 &4',7,MA_ERR) 895 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 896 &4',8,MA_ERR) 897 END IF 898 END IF 899 END IF 900 END DO 901 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 902 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 903 &3b)) THEN 904 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 905 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 906 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,3,4,2,1,-1.0d0) 907 END IF 908 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 909 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 910 &3b)) THEN 911 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 912 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 913 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,3,2,4,1,1.0d0) 914 END IF 915 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h5b) .and. (t_h6b .eq. h6b) 916 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 917 &1b)) THEN 918 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 919 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 920 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,3,2,1,4,-1.0d0) 921 END IF 922 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 923 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 924 &3b)) THEN 925 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 926 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 927 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),3,6,5,4,2,1,-1.0d0) 928 END IF 929 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 930 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 931 &3b)) THEN 932 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 933 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 934 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),3,6,5,2,4,1,1.0d0) 935 END IF 936 IF ((t_h4b .eq. h6b) .and. (t_h5b .eq. h4b) .and. (t_h6b .eq. h5b) 937 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 938 &1b)) THEN 939 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 940 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 941 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),3,6,5,2,1,4,-1.0d0) 942 END IF 943 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 944 & .and. (t_p1b .eq. p1b) .and. (t_p2b .eq. p2b) .and. (t_p3b .eq. p 945 &3b)) THEN 946 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 947 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 948 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,3,5,4,2,1,1.0d0) 949 END IF 950 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 951 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p1b) .and. (t_p3b .eq. p 952 &3b)) THEN 953 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 954 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 955 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,3,5,2,4,1,-1.0d0) 956 END IF 957 IF ((t_h4b .eq. h4b) .and. (t_h5b .eq. h6b) .and. (t_h6b .eq. h5b) 958 & .and. (t_p1b .eq. p2b) .and. (t_p2b .eq. p3b) .and. (t_p3b .eq. p 959 &1b)) THEN 960 CALL TCE_SORTACC_6(dbl_mb(k_c_sort),a_c,int_mb(k_range+p3b-1),int_ 961 &mb(k_range+p2b-1),int_mb(k_range+h6b-1),int_mb(k_range+p1b-1),int_ 962 &mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,3,5,2,1,4,1.0d0) 963 END IF 964 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('lambda_ccsd_t_left_ 965 &4',9,MA_ERR) 966 END IF 967 END IF 968 END IF 969 END IF 970 END DO 971 END DO 972 END DO 973 END DO 974 END DO 975 END DO 976 RETURN 977 END 978