1 SUBROUTINE ccsdtq_lr_alpha_15_12(d_a,k_a_offset,d_b,k_b_offset,d_c 2 &,k_c_offset) 3C $Id$ 4C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6C i1 ( p13 p17 h15 h16 )_ytrbtra + = 1/12 * Sum ( h5 h6 p1 p2 p3 ) * tra ( p1 p2 p3 p17 h5 h6 h15 h16 )_tra * i2 ( h5 h6 p13 p1 p2 p3 )_ytrb 7 IMPLICIT NONE 8#include "global.fh" 9#include "mafdecls.fh" 10#include "sym.fh" 11#include "errquit.fh" 12#include "tce.fh" 13 INTEGER d_a 14 INTEGER k_a_offset 15 INTEGER d_b 16 INTEGER k_b_offset 17 INTEGER d_c 18 INTEGER k_c_offset 19 INTEGER nxtask 20 INTEGER next 21 INTEGER nprocs 22 INTEGER count 23 INTEGER p17b 24 INTEGER p13b 25 INTEGER h15b 26 INTEGER h16b 27 INTEGER dimc 28 INTEGER l_c_sort 29 INTEGER k_c_sort 30 INTEGER p1b 31 INTEGER p2b 32 INTEGER p3b 33 INTEGER h5b 34 INTEGER h6b 35 INTEGER p17b_1 36 INTEGER p1b_1 37 INTEGER p2b_1 38 INTEGER p3b_1 39 INTEGER h15b_1 40 INTEGER h16b_1 41 INTEGER h5b_1 42 INTEGER h6b_1 43 INTEGER p13b_2 44 INTEGER h5b_2 45 INTEGER h6b_2 46 INTEGER p1b_2 47 INTEGER p2b_2 48 INTEGER p3b_2 49 INTEGER dim_common 50 INTEGER dima_sort 51 INTEGER dima 52 INTEGER dimb_sort 53 INTEGER dimb 54 INTEGER l_a_sort 55 INTEGER k_a_sort 56 INTEGER l_a 57 INTEGER k_a 58 INTEGER l_b_sort 59 INTEGER k_b_sort 60 INTEGER l_b 61 INTEGER k_b 62 INTEGER nsuperp(3) 63 INTEGER isuperp 64 INTEGER nsubh(2) 65 INTEGER isubh 66 INTEGER l_c 67 INTEGER k_c 68 DOUBLE PRECISION FACTORIAL 69 EXTERNAL nxtask 70 EXTERNAL FACTORIAL 71 nprocs = GA_NNODES() 72 count = 0 73 next = nxtask(nprocs,1) 74 DO p17b = noab+1,noab+nvab 75 DO p13b = noab+1,noab+nvab 76 DO h15b = 1,noab 77 DO h16b = h15b,noab 78 IF (next.eq.count) THEN 79 IF ((.not.restricted).or.(int_mb(k_spin+p13b-1)+int_mb(k_spin+p17b 80 &-1)+int_mb(k_spin+h15b-1)+int_mb(k_spin+h16b-1).ne.8)) THEN 81 IF (int_mb(k_spin+p13b-1)+int_mb(k_spin+p17b-1) .eq. int_mb(k_spin 82 &+h15b-1)+int_mb(k_spin+h16b-1)) THEN 83 IF (ieor(int_mb(k_sym+p13b-1),ieor(int_mb(k_sym+p17b-1),ieor(int_m 84 &b(k_sym+h15b-1),int_mb(k_sym+h16b-1)))) .eq. ieor(irrep_y,ieor(irr 85 &ep_trb,irrep_tra))) THEN 86 dimc = int_mb(k_range+p13b-1) * int_mb(k_range+p17b-1) * int_mb(k_ 87 &range+h15b-1) * int_mb(k_range+h16b-1) 88 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 89 & ERRQUIT('ccsdtq_lr_alpha_15_12',0,MA_ERR) 90 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 91 DO p1b = noab+1,noab+nvab 92 DO p2b = p1b,noab+nvab 93 DO p3b = p2b,noab+nvab 94 DO h5b = 1,noab 95 DO h6b = h5b,noab 96 IF (int_mb(k_spin+p17b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1 97 &)+int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+h1 98 &6b-1)+int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)) THEN 99 IF (ieor(int_mb(k_sym+p17b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb 100 &(k_sym+p2b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h15b-1),i 101 &eor(int_mb(k_sym+h16b-1),ieor(int_mb(k_sym+h5b-1),int_mb(k_sym+h6b 102 &-1)))))))) .eq. irrep_tra) THEN 103 CALL TCE_RESTRICTED_8(p17b,p1b,p2b,p3b,h15b,h16b,h5b,h6b,p17b_1,p1 104 &b_1,p2b_1,p3b_1,h15b_1,h16b_1,h5b_1,h6b_1) 105 CALL TCE_RESTRICTED_6(p13b,h5b,h6b,p1b,p2b,p3b,p13b_2,h5b_2,h6b_2, 106 &p1b_2,p2b_2,p3b_2) 107 dim_common = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m 108 &b(k_range+p3b-1) * int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) 109 dima_sort = int_mb(k_range+p17b-1) * int_mb(k_range+h15b-1) * int_ 110 &mb(k_range+h16b-1) 111 dima = dim_common * dima_sort 112 dimb_sort = int_mb(k_range+p13b-1) 113 dimb = dim_common * dimb_sort 114 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 115 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 116 & ERRQUIT('ccsdtq_lr_alpha_15_12',1,MA_ERR) 117 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 118 &ccsdtq_lr_alpha_15_12',2,MA_ERR) 119 IF ((p3b .le. p17b) .and. (h6b .le. h15b)) THEN 120 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 121 &1 - 1 + noab * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 122 & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * ( 123 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 124 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 125 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1 126 &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b- 127 &1),int_mb(k_range+h16b-1),8,7,4,6,5,3,2,1,1.0d0) 128 END IF 129 IF ((p3b .le. p17b) .and. (h5b .le. h15b) .and. (h15b .lt. h6b) .a 130 &nd. (h6b .le. h16b)) THEN 131 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 132 &1 - 1 + noab * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 133 & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * ( 134 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 135 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 136 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1 137 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b- 138 &1),int_mb(k_range+h16b-1),8,6,4,7,5,3,2,1,-1.0d0) 139 END IF 140 IF ((p3b .le. p17b) .and. (h5b .le. h15b) .and. (h16b .lt. h6b)) T 141 &HEN 142 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 143 & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 144 & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * ( 145 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 146 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 147 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1 148 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b 149 &-1),int_mb(k_range+h6b-1),7,6,4,8,5,3,2,1,1.0d0) 150 END IF 151 IF ((p3b .le. p17b) .and. (h15b .lt. h5b) .and. (h6b .le. h16b)) T 152 &HEN 153 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 154 &1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 155 & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * ( 156 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 157 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 158 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1 159 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b- 160 &1),int_mb(k_range+h16b-1),8,5,4,7,6,3,2,1,1.0d0) 161 END IF 162 IF ((p3b .le. p17b) .and. (h15b .lt. h5b) .and. (h5b .le. h16b) .a 163 &nd. (h16b .lt. h6b)) THEN 164 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 165 & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 166 & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * ( 167 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 168 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 169 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1 170 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b 171 &-1),int_mb(k_range+h6b-1),7,5,4,8,6,3,2,1,-1.0d0) 172 END IF 173 IF ((p3b .le. p17b) .and. (h16b .lt. h5b)) THEN 174 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 175 & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 176 & + noab * (p17b_1 - noab - 1 + nvab * (p3b_1 - noab - 1 + nvab * ( 177 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 178 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 179 &,int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),int_mb(k_range+p17b-1 180 &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b 181 &-1),int_mb(k_range+h6b-1),6,5,4,8,7,3,2,1,1.0d0) 182 END IF 183 IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h6b .le. h15b)) T 184 &HEN 185 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 186 &1 - 1 + noab * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 187 & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * ( 188 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 189 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 190 &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1 191 &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b- 192 &1),int_mb(k_range+h16b-1),8,7,3,6,5,4,2,1,-1.0d0) 193 END IF 194 IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h5b .le. h15b) .a 195 &nd. (h15b .lt. h6b) .and. (h6b .le. h16b)) THEN 196 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 197 &1 - 1 + noab * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 198 & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * ( 199 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 200 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 201 &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1 202 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b- 203 &1),int_mb(k_range+h16b-1),8,6,3,7,5,4,2,1,1.0d0) 204 END IF 205 IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h5b .le. h15b) .a 206 &nd. (h16b .lt. h6b)) THEN 207 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 208 & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 209 & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * ( 210 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 211 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 212 &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1 213 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b 214 &-1),int_mb(k_range+h6b-1),7,6,3,8,5,4,2,1,-1.0d0) 215 END IF 216 IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h15b .lt. h5b) .a 217 &nd. (h6b .le. h16b)) THEN 218 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 219 &1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 220 & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * ( 221 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 222 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 223 &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1 224 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b- 225 &1),int_mb(k_range+h16b-1),8,5,3,7,6,4,2,1,-1.0d0) 226 END IF 227 IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h15b .lt. h5b) .a 228 &nd. (h5b .le. h16b) .and. (h16b .lt. h6b)) THEN 229 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 230 & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 231 & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * ( 232 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 233 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 234 &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1 235 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b 236 &-1),int_mb(k_range+h6b-1),7,5,3,8,6,4,2,1,1.0d0) 237 END IF 238 IF ((p2b .le. p17b) .and. (p17b .lt. p3b) .and. (h16b .lt. h5b)) T 239 &HEN 240 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 241 & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 242 & + noab * (p3b_1 - noab - 1 + nvab * (p17b_1 - noab - 1 + nvab * ( 243 &p2b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 244 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 245 &,int_mb(k_range+p2b-1),int_mb(k_range+p17b-1),int_mb(k_range+p3b-1 246 &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b 247 &-1),int_mb(k_range+h6b-1),6,5,3,8,7,4,2,1,-1.0d0) 248 END IF 249 IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h6b .le. h15b)) T 250 &HEN 251 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 252 &1 - 1 + noab * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 253 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 254 &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 255 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 256 &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 257 &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b- 258 &1),int_mb(k_range+h16b-1),8,7,2,6,5,4,3,1,1.0d0) 259 END IF 260 IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h5b .le. h15b) .a 261 &nd. (h15b .lt. h6b) .and. (h6b .le. h16b)) THEN 262 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 263 &1 - 1 + noab * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 264 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 265 &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 266 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 267 &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 268 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b- 269 &1),int_mb(k_range+h16b-1),8,6,2,7,5,4,3,1,-1.0d0) 270 END IF 271 IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h5b .le. h15b) .a 272 &nd. (h16b .lt. h6b)) THEN 273 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 274 & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 275 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 276 &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 277 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 278 &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 279 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b 280 &-1),int_mb(k_range+h6b-1),7,6,2,8,5,4,3,1,1.0d0) 281 END IF 282 IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h15b .lt. h5b) .a 283 &nd. (h6b .le. h16b)) THEN 284 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 285 &1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 286 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 287 &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 288 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 289 &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 290 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b- 291 &1),int_mb(k_range+h16b-1),8,5,2,7,6,4,3,1,1.0d0) 292 END IF 293 IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h15b .lt. h5b) .a 294 &nd. (h5b .le. h16b) .and. (h16b .lt. h6b)) THEN 295 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 296 & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 297 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 298 &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 299 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 300 &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 301 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b 302 &-1),int_mb(k_range+h6b-1),7,5,2,8,6,4,3,1,-1.0d0) 303 END IF 304 IF ((p1b .le. p17b) .and. (p17b .lt. p2b) .and. (h16b .lt. h5b)) T 305 &HEN 306 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 307 & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 308 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 309 &17b_1 - noab - 1 + nvab * (p1b_1 - noab - 1))))))))) 310 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 311 &,int_mb(k_range+p17b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 312 &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b 313 &-1),int_mb(k_range+h6b-1),6,5,2,8,7,4,3,1,1.0d0) 314 END IF 315 IF ((p17b .lt. p1b) .and. (h6b .le. h15b)) THEN 316 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 317 &1 - 1 + noab * (h15b_1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 318 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 319 &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1))))))))) 320 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1 321 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 322 &),int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h15b- 323 &1),int_mb(k_range+h16b-1),8,7,1,6,5,4,3,2,-1.0d0) 324 END IF 325 IF ((p17b .lt. p1b) .and. (h5b .le. h15b) .and. (h15b .lt. h6b) .a 326 &nd. (h6b .le. h16b)) THEN 327 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 328 &1 - 1 + noab * (h6b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 329 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 330 &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1))))))))) 331 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1 332 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 333 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h6b- 334 &1),int_mb(k_range+h16b-1),8,6,1,7,5,4,3,2,1.0d0) 335 END IF 336 IF ((p17b .lt. p1b) .and. (h5b .le. h15b) .and. (h16b .lt. h6b)) T 337 &HEN 338 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 339 & - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 + noab * (h5b_1 - 1 340 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 341 &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1))))))))) 342 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1 343 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 344 &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),int_mb(k_range+h16b 345 &-1),int_mb(k_range+h6b-1),7,6,1,8,5,4,3,2,-1.0d0) 346 END IF 347 IF ((p17b .lt. p1b) .and. (h15b .lt. h5b) .and. (h6b .le. h16b)) T 348 &HEN 349 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 350 &1 - 1 + noab * (h6b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 351 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 352 &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1))))))))) 353 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1 354 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 355 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h6b- 356 &1),int_mb(k_range+h16b-1),8,5,1,7,6,4,3,2,-1.0d0) 357 END IF 358 IF ((p17b .lt. p1b) .and. (h15b .lt. h5b) .and. (h5b .le. h16b) .a 359 &nd. (h16b .lt. h6b)) THEN 360 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 361 & - 1 + noab * (h16b_1 - 1 + noab * (h5b_1 - 1 + noab * (h15b_1 - 1 362 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 363 &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1))))))))) 364 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1 365 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 366 &),int_mb(k_range+h15b-1),int_mb(k_range+h5b-1),int_mb(k_range+h16b 367 &-1),int_mb(k_range+h6b-1),7,5,1,8,6,4,3,2,1.0d0) 368 END IF 369 IF ((p17b .lt. p1b) .and. (h16b .lt. h5b)) THEN 370 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h6b_1 371 & - 1 + noab * (h5b_1 - 1 + noab * (h16b_1 - 1 + noab * (h15b_1 - 1 372 & + noab * (p3b_1 - noab - 1 + nvab * (p2b_1 - noab - 1 + nvab * (p 373 &1b_1 - noab - 1 + nvab * (p17b_1 - noab - 1))))))))) 374 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p17b-1 375 &),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1 376 &),int_mb(k_range+h15b-1),int_mb(k_range+h16b-1),int_mb(k_range+h5b 377 &-1),int_mb(k_range+h6b-1),6,5,1,8,7,4,3,2,-1.0d0) 378 END IF 379 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_lr_alpha_15_12',3 380 &,MA_ERR) 381 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 382 & ERRQUIT('ccsdtq_lr_alpha_15_12',4,MA_ERR) 383 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 384 &ccsdtq_lr_alpha_15_12',5,MA_ERR) 385 IF ((h6b .le. p13b)) THEN 386 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 387 & - noab - 1 + nvab * (p2b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 388 &+ nvab * (p13b_2 - noab - 1 + nvab * (h6b_2 - 1 + noab * (h5b_2 - 389 &1))))))) 390 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1) 391 &,int_mb(k_range+h6b-1),int_mb(k_range+p13b-1),int_mb(k_range+p1b-1 392 &),int_mb(k_range+p2b-1),int_mb(k_range+p3b-1),3,2,1,6,5,4,1.0d0) 393 END IF 394 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_lr_alpha_15_12',6 395 &,MA_ERR) 396 nsuperp(1) = 1 397 nsuperp(2) = 1 398 nsuperp(3) = 1 399 isuperp = 1 400 IF (p1b .eq. p2b) THEN 401 nsuperp(isuperp) = nsuperp(isuperp) + 1 402 ELSE 403 isuperp = isuperp + 1 404 END IF 405 IF (p2b .eq. p3b) THEN 406 nsuperp(isuperp) = nsuperp(isuperp) + 1 407 ELSE 408 isuperp = isuperp + 1 409 END IF 410 nsubh(1) = 1 411 nsubh(2) = 1 412 isubh = 1 413 IF (h5b .eq. h6b) THEN 414 nsubh(isubh) = nsubh(isubh) + 1 415 ELSE 416 isubh = isubh + 1 417 END IF 418 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,12.0d0/FACTORIAL 419 &(nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsuperp(3))/FACTORIAL 420 &(nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb( 421 &k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 422 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 423 &12',7,MA_ERR) 424 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 425 &12',8,MA_ERR) 426 END IF 427 END IF 428 END IF 429 END DO 430 END DO 431 END DO 432 END DO 433 END DO 434 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 435 &ccsdtq_lr_alpha_15_12',9,MA_ERR) 436 IF ((p13b .le. p17b)) THEN 437 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p13b-1 438 &),int_mb(k_range+h16b-1),int_mb(k_range+h15b-1),int_mb(k_range+p17 439 &b-1),1,4,3,2,1.0d0/24.0d0) 440 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h16b 441 &- 1 + noab * (h15b - 1 + noab * (p17b - noab - 1 + nvab * (p13b - 442 &noab - 1))))) 443 END IF 444 IF ((p17b .le. p13b)) THEN 445 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p13b-1 446 &),int_mb(k_range+h16b-1),int_mb(k_range+h15b-1),int_mb(k_range+p17 447 &b-1),4,1,3,2,-1.0d0/24.0d0) 448 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h16b 449 &- 1 + noab * (h15b - 1 + noab * (p13b - noab - 1 + nvab * (p17b - 450 &noab - 1))))) 451 END IF 452 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lr_alpha_15_12',1 453 &0,MA_ERR) 454 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 455 &12',11,MA_ERR) 456 END IF 457 END IF 458 END IF 459 next = nxtask(nprocs,1) 460 END IF 461 count = count + 1 462 END DO 463 END DO 464 END DO 465 END DO 466 next = nxtask(-nprocs,1) 467 call GA_SYNC() 468 RETURN 469 END 470