1 SUBROUTINE ccsdtq_lambda1_14_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k 2 &_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 ( h2 p13 h14 h16 )_yt + = 1/12 * Sum ( h8 h7 p5 p4 p3 ) * t ( p3 p4 p5 p13 h7 h8 h14 h16 )_t * y ( h2 h7 h8 p3 p4 p5 )_y 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 h2b 24 INTEGER p13b 25 INTEGER h14b 26 INTEGER h16b 27 INTEGER dimc 28 INTEGER l_c_sort 29 INTEGER k_c_sort 30 INTEGER p3b 31 INTEGER p4b 32 INTEGER p5b 33 INTEGER h7b 34 INTEGER h8b 35 INTEGER p13b_1 36 INTEGER p3b_1 37 INTEGER p4b_1 38 INTEGER p5b_1 39 INTEGER h14b_1 40 INTEGER h16b_1 41 INTEGER h7b_1 42 INTEGER h8b_1 43 INTEGER h2b_2 44 INTEGER h7b_2 45 INTEGER h8b_2 46 INTEGER p3b_2 47 INTEGER p4b_2 48 INTEGER p5b_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 h2b = 1,noab 75 DO p13b = noab+1,noab+nvab 76 DO h14b = 1,noab 77 DO h16b = h14b,noab 78 IF (next.eq.count) THEN 79 IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+p13b- 80 &1)+int_mb(k_spin+h14b-1)+int_mb(k_spin+h16b-1).ne.8)) THEN 81 IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+p13b-1) .eq. int_mb(k_spin+ 82 &h14b-1)+int_mb(k_spin+h16b-1)) THEN 83 IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+p13b-1),ieor(int_mb 84 &(k_sym+h14b-1),int_mb(k_sym+h16b-1)))) .eq. ieor(irrep_y,irrep_t)) 85 & THEN 86 dimc = int_mb(k_range+h2b-1) * int_mb(k_range+p13b-1) * int_mb(k_r 87 &ange+h14b-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_lambda1_14_3',0,MA_ERR) 90 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 91 DO p3b = noab+1,noab+nvab 92 DO p4b = p3b,noab+nvab 93 DO p5b = p4b,noab+nvab 94 DO h7b = 1,noab 95 DO h8b = h7b,noab 96 IF (int_mb(k_spin+p13b-1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1 97 &)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h14b-1)+int_mb(k_spin+h1 98 &6b-1)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h8b-1)) THEN 99 IF (ieor(int_mb(k_sym+p13b-1),ieor(int_mb(k_sym+p3b-1),ieor(int_mb 100 &(k_sym+p4b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb(k_sym+h14b-1),i 101 &eor(int_mb(k_sym+h16b-1),ieor(int_mb(k_sym+h7b-1),int_mb(k_sym+h8b 102 &-1)))))))) .eq. irrep_t) THEN 103 CALL TCE_RESTRICTED_8(p13b,p3b,p4b,p5b,h14b,h16b,h7b,h8b,p13b_1,p3 104 &b_1,p4b_1,p5b_1,h14b_1,h16b_1,h7b_1,h8b_1) 105 CALL TCE_RESTRICTED_6(h2b,h7b,h8b,p3b,p4b,p5b,h2b_2,h7b_2,h8b_2,p3 106 &b_2,p4b_2,p5b_2) 107 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+p4b-1) * int_m 108 &b(k_range+p5b-1) * int_mb(k_range+h7b-1) * int_mb(k_range+h8b-1) 109 dima_sort = int_mb(k_range+p13b-1) * int_mb(k_range+h14b-1) * int_ 110 &mb(k_range+h16b-1) 111 dima = dim_common * dima_sort 112 dimb_sort = int_mb(k_range+h2b-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_lambda1_14_3',1,MA_ERR) 117 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 118 &ccsdtq_lambda1_14_3',2,MA_ERR) 119 IF ((p5b .le. p13b) .and. (h8b .le. h14b)) THEN 120 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 121 &1 - 1 + noab * (h14b_1 - 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1 122 & + noab * (p13b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * ( 123 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 124 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 125 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p13b-1 126 &),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h14b- 127 &1),int_mb(k_range+h16b-1),8,7,4,6,5,3,2,1,1.0d0) 128 END IF 129 IF ((p5b .le. p13b) .and. (h7b .le. h14b) .and. (h14b .lt. h8b) .a 130 &nd. (h8b .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 * (h8b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 133 & + noab * (p13b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * ( 134 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 135 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 136 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p13b-1 137 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h8b- 138 &1),int_mb(k_range+h16b-1),8,6,4,7,5,3,2,1,-1.0d0) 139 END IF 140 IF ((p5b .le. p13b) .and. (h7b .le. h14b) .and. (h16b .lt. h8b)) T 141 &HEN 142 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 143 & - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 144 & + noab * (p13b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * ( 145 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 146 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 147 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p13b-1 148 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h16b 149 &-1),int_mb(k_range+h8b-1),7,6,4,8,5,3,2,1,1.0d0) 150 END IF 151 IF ((p5b .le. p13b) .and. (h14b .lt. h7b) .and. (h8b .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 * (h8b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 155 & + noab * (p13b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * ( 156 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 157 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 158 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p13b-1 159 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b- 160 &1),int_mb(k_range+h16b-1),8,5,4,7,6,3,2,1,1.0d0) 161 END IF 162 IF ((p5b .le. p13b) .and. (h14b .lt. h7b) .and. (h7b .le. h16b) .a 163 &nd. (h16b .lt. h8b)) THEN 164 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 165 & - 1 + noab * (h16b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 166 & + noab * (p13b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * ( 167 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 168 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 169 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p13b-1 170 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h16b 171 &-1),int_mb(k_range+h8b-1),7,5,4,8,6,3,2,1,-1.0d0) 172 END IF 173 IF ((p5b .le. p13b) .and. (h16b .lt. h7b)) THEN 174 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 175 & - 1 + noab * (h7b_1 - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 176 & + noab * (p13b_1 - noab - 1 + nvab * (p5b_1 - noab - 1 + nvab * ( 177 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 178 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 179 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p13b-1 180 &),int_mb(k_range+h14b-1),int_mb(k_range+h16b-1),int_mb(k_range+h7b 181 &-1),int_mb(k_range+h8b-1),6,5,4,8,7,3,2,1,1.0d0) 182 END IF 183 IF ((p4b .le. p13b) .and. (p13b .lt. p5b) .and. (h8b .le. h14b)) 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 * (h14b_1 - 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1 187 & + noab * (p5b_1 - noab - 1 + nvab * (p13b_1 - noab - 1 + nvab * ( 188 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 189 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 190 &,int_mb(k_range+p4b-1),int_mb(k_range+p13b-1),int_mb(k_range+p5b-1 191 &),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h14b- 192 &1),int_mb(k_range+h16b-1),8,7,3,6,5,4,2,1,-1.0d0) 193 END IF 194 IF ((p4b .le. p13b) .and. (p13b .lt. p5b) .and. (h7b .le. h14b) .a 195 &nd. (h14b .lt. h8b) .and. (h8b .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 * (h8b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 198 & + noab * (p5b_1 - noab - 1 + nvab * (p13b_1 - noab - 1 + nvab * ( 199 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 200 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 201 &,int_mb(k_range+p4b-1),int_mb(k_range+p13b-1),int_mb(k_range+p5b-1 202 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h8b- 203 &1),int_mb(k_range+h16b-1),8,6,3,7,5,4,2,1,1.0d0) 204 END IF 205 IF ((p4b .le. p13b) .and. (p13b .lt. p5b) .and. (h7b .le. h14b) .a 206 &nd. (h16b .lt. h8b)) THEN 207 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 208 & - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 209 & + noab * (p5b_1 - noab - 1 + nvab * (p13b_1 - noab - 1 + nvab * ( 210 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 211 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 212 &,int_mb(k_range+p4b-1),int_mb(k_range+p13b-1),int_mb(k_range+p5b-1 213 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h16b 214 &-1),int_mb(k_range+h8b-1),7,6,3,8,5,4,2,1,-1.0d0) 215 END IF 216 IF ((p4b .le. p13b) .and. (p13b .lt. p5b) .and. (h14b .lt. h7b) .a 217 &nd. (h8b .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 * (h8b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 220 & + noab * (p5b_1 - noab - 1 + nvab * (p13b_1 - noab - 1 + nvab * ( 221 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 222 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 223 &,int_mb(k_range+p4b-1),int_mb(k_range+p13b-1),int_mb(k_range+p5b-1 224 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b- 225 &1),int_mb(k_range+h16b-1),8,5,3,7,6,4,2,1,-1.0d0) 226 END IF 227 IF ((p4b .le. p13b) .and. (p13b .lt. p5b) .and. (h14b .lt. h7b) .a 228 &nd. (h7b .le. h16b) .and. (h16b .lt. h8b)) THEN 229 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 230 & - 1 + noab * (h16b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 231 & + noab * (p5b_1 - noab - 1 + nvab * (p13b_1 - noab - 1 + nvab * ( 232 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 233 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 234 &,int_mb(k_range+p4b-1),int_mb(k_range+p13b-1),int_mb(k_range+p5b-1 235 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h16b 236 &-1),int_mb(k_range+h8b-1),7,5,3,8,6,4,2,1,1.0d0) 237 END IF 238 IF ((p4b .le. p13b) .and. (p13b .lt. p5b) .and. (h16b .lt. h7b)) T 239 &HEN 240 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 241 & - 1 + noab * (h7b_1 - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 242 & + noab * (p5b_1 - noab - 1 + nvab * (p13b_1 - noab - 1 + nvab * ( 243 &p4b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 244 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 245 &,int_mb(k_range+p4b-1),int_mb(k_range+p13b-1),int_mb(k_range+p5b-1 246 &),int_mb(k_range+h14b-1),int_mb(k_range+h16b-1),int_mb(k_range+h7b 247 &-1),int_mb(k_range+h8b-1),6,5,3,8,7,4,2,1,-1.0d0) 248 END IF 249 IF ((p3b .le. p13b) .and. (p13b .lt. p4b) .and. (h8b .le. h14b)) 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 * (h14b_1 - 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1 253 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 254 &13b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 255 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 256 &,int_mb(k_range+p13b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 257 &),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h14b- 258 &1),int_mb(k_range+h16b-1),8,7,2,6,5,4,3,1,1.0d0) 259 END IF 260 IF ((p3b .le. p13b) .and. (p13b .lt. p4b) .and. (h7b .le. h14b) .a 261 &nd. (h14b .lt. h8b) .and. (h8b .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 * (h8b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 264 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 265 &13b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 266 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 267 &,int_mb(k_range+p13b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 268 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h8b- 269 &1),int_mb(k_range+h16b-1),8,6,2,7,5,4,3,1,-1.0d0) 270 END IF 271 IF ((p3b .le. p13b) .and. (p13b .lt. p4b) .and. (h7b .le. h14b) .a 272 &nd. (h16b .lt. h8b)) THEN 273 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 274 & - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 275 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 276 &13b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 277 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 278 &,int_mb(k_range+p13b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 279 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h16b 280 &-1),int_mb(k_range+h8b-1),7,6,2,8,5,4,3,1,1.0d0) 281 END IF 282 IF ((p3b .le. p13b) .and. (p13b .lt. p4b) .and. (h14b .lt. h7b) .a 283 &nd. (h8b .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 * (h8b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 286 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 287 &13b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 288 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 289 &,int_mb(k_range+p13b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 290 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b- 291 &1),int_mb(k_range+h16b-1),8,5,2,7,6,4,3,1,1.0d0) 292 END IF 293 IF ((p3b .le. p13b) .and. (p13b .lt. p4b) .and. (h14b .lt. h7b) .a 294 &nd. (h7b .le. h16b) .and. (h16b .lt. h8b)) THEN 295 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 296 & - 1 + noab * (h16b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 297 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 298 &13b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 299 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 300 &,int_mb(k_range+p13b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 301 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h16b 302 &-1),int_mb(k_range+h8b-1),7,5,2,8,6,4,3,1,-1.0d0) 303 END IF 304 IF ((p3b .le. p13b) .and. (p13b .lt. p4b) .and. (h16b .lt. h7b)) T 305 &HEN 306 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 307 & - 1 + noab * (h7b_1 - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 308 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 309 &13b_1 - noab - 1 + nvab * (p3b_1 - noab - 1))))))))) 310 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 311 &,int_mb(k_range+p13b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 312 &),int_mb(k_range+h14b-1),int_mb(k_range+h16b-1),int_mb(k_range+h7b 313 &-1),int_mb(k_range+h8b-1),6,5,2,8,7,4,3,1,1.0d0) 314 END IF 315 IF ((p13b .lt. p3b) .and. (h8b .le. h14b)) THEN 316 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h16b_ 317 &1 - 1 + noab * (h14b_1 - 1 + noab * (h8b_1 - 1 + noab * (h7b_1 - 1 318 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 319 &3b_1 - noab - 1 + nvab * (p13b_1 - noab - 1))))))))) 320 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p13b-1 321 &),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 322 &),int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h14b- 323 &1),int_mb(k_range+h16b-1),8,7,1,6,5,4,3,2,-1.0d0) 324 END IF 325 IF ((p13b .lt. p3b) .and. (h7b .le. h14b) .and. (h14b .lt. h8b) .a 326 &nd. (h8b .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 * (h8b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 329 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 330 &3b_1 - noab - 1 + nvab * (p13b_1 - noab - 1))))))))) 331 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p13b-1 332 &),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 333 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h8b- 334 &1),int_mb(k_range+h16b-1),8,6,1,7,5,4,3,2,1.0d0) 335 END IF 336 IF ((p13b .lt. p3b) .and. (h7b .le. h14b) .and. (h16b .lt. h8b)) T 337 &HEN 338 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 339 & - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 + noab * (h7b_1 - 1 340 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 341 &3b_1 - noab - 1 + nvab * (p13b_1 - noab - 1))))))))) 342 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p13b-1 343 &),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 344 &),int_mb(k_range+h7b-1),int_mb(k_range+h14b-1),int_mb(k_range+h16b 345 &-1),int_mb(k_range+h8b-1),7,6,1,8,5,4,3,2,-1.0d0) 346 END IF 347 IF ((p13b .lt. p3b) .and. (h14b .lt. h7b) .and. (h8b .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 * (h8b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 351 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 352 &3b_1 - noab - 1 + nvab * (p13b_1 - noab - 1))))))))) 353 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p13b-1 354 &),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 355 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h8b- 356 &1),int_mb(k_range+h16b-1),8,5,1,7,6,4,3,2,-1.0d0) 357 END IF 358 IF ((p13b .lt. p3b) .and. (h14b .lt. h7b) .and. (h7b .le. h16b) .a 359 &nd. (h16b .lt. h8b)) THEN 360 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 361 & - 1 + noab * (h16b_1 - 1 + noab * (h7b_1 - 1 + noab * (h14b_1 - 1 362 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 363 &3b_1 - noab - 1 + nvab * (p13b_1 - noab - 1))))))))) 364 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p13b-1 365 &),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 366 &),int_mb(k_range+h14b-1),int_mb(k_range+h7b-1),int_mb(k_range+h16b 367 &-1),int_mb(k_range+h8b-1),7,5,1,8,6,4,3,2,1.0d0) 368 END IF 369 IF ((p13b .lt. p3b) .and. (h16b .lt. h7b)) THEN 370 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 371 & - 1 + noab * (h7b_1 - 1 + noab * (h16b_1 - 1 + noab * (h14b_1 - 1 372 & + noab * (p5b_1 - noab - 1 + nvab * (p4b_1 - noab - 1 + nvab * (p 373 &3b_1 - noab - 1 + nvab * (p13b_1 - noab - 1))))))))) 374 CALL TCE_SORT_8(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p13b-1 375 &),int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),int_mb(k_range+p5b-1 376 &),int_mb(k_range+h14b-1),int_mb(k_range+h16b-1),int_mb(k_range+h7b 377 &-1),int_mb(k_range+h8b-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_lambda1_14_3',3,M 380 &A_ERR) 381 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 382 & ERRQUIT('ccsdtq_lambda1_14_3',4,MA_ERR) 383 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 384 &ccsdtq_lambda1_14_3',5,MA_ERR) 385 IF ((h8b .lt. h2b)) THEN 386 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 387 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 388 &+ nvab * (h2b_2 - 1 + noab * (h8b_2 - 1 + noab * (h7b_2 - 1))))))) 389 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 390 &,int_mb(k_range+h8b-1),int_mb(k_range+h2b-1),int_mb(k_range+p3b-1) 391 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),3,2,1,6,5,4,1.0d0) 392 END IF 393 IF ((h7b .lt. h2b) .and. (h2b .le. h8b)) THEN 394 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 395 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 396 &+ nvab * (h8b_2 - 1 + noab * (h2b_2 - 1 + noab * (h7b_2 - 1))))))) 397 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h7b-1) 398 &,int_mb(k_range+h2b-1),int_mb(k_range+h8b-1),int_mb(k_range+p3b-1) 399 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),2,3,1,6,5,4,-1.0d0) 400 END IF 401 IF ((h2b .le. h7b)) THEN 402 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 403 & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 404 &+ nvab * (h8b_2 - 1 + noab * (h7b_2 - 1 + noab * (h2b_2 - 1))))))) 405 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1) 406 &,int_mb(k_range+h7b-1),int_mb(k_range+h8b-1),int_mb(k_range+p3b-1) 407 &,int_mb(k_range+p4b-1),int_mb(k_range+p5b-1),1,3,2,6,5,4,1.0d0) 408 END IF 409 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_lambda1_14_3',6,M 410 &A_ERR) 411 nsuperp(1) = 1 412 nsuperp(2) = 1 413 nsuperp(3) = 1 414 isuperp = 1 415 IF (p3b .eq. p4b) THEN 416 nsuperp(isuperp) = nsuperp(isuperp) + 1 417 ELSE 418 isuperp = isuperp + 1 419 END IF 420 IF (p4b .eq. p5b) THEN 421 nsuperp(isuperp) = nsuperp(isuperp) + 1 422 ELSE 423 isuperp = isuperp + 1 424 END IF 425 nsubh(1) = 1 426 nsubh(2) = 1 427 isubh = 1 428 IF (h7b .eq. h8b) THEN 429 nsubh(isubh) = nsubh(isubh) + 1 430 ELSE 431 isubh = isubh + 1 432 END IF 433 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,12.0d0/FACTORIAL 434 &(nsuperp(1))/FACTORIAL(nsuperp(2))/FACTORIAL(nsuperp(3))/FACTORIAL 435 &(nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb( 436 &k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 437 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_lambda1_14_3 438 &',7,MA_ERR) 439 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lambda1_14_3 440 &',8,MA_ERR) 441 END IF 442 END IF 443 END IF 444 END DO 445 END DO 446 END DO 447 END DO 448 END DO 449 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 450 &ccsdtq_lambda1_14_3',9,MA_ERR) 451 CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h2b-1) 452 &,int_mb(k_range+h16b-1),int_mb(k_range+h14b-1),int_mb(k_range+p13b 453 &-1),1,4,3,2,1.0d0/12.0d0) 454 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h16b 455 &- 1 + noab * (h14b - 1 + noab * (p13b - noab - 1 + nvab * (h2b - 1 456 &))))) 457 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lambda1_14_3',10, 458 &MA_ERR) 459 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_lambda1_14_3 460 &',11,MA_ERR) 461 END IF 462 END IF 463 END IF 464 next = NXTASK(nprocs,1) 465 END IF 466 count = count + 1 467 END DO 468 END DO 469 END DO 470 END DO 471 next = NXTASK(-nprocs,1) 472 call GA_SYNC() 473 RETURN 474 END 475