1 SUBROUTINE ccsdt_lr_alpha_offdiag_15_21_1_1(d_a,k_a_offset,d_b,k_b 2 &_offset,d_c,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 i3 ( h3 h4 h7 h15 p1 p5 )_yt + = -1 * Sum ( p9 ) * t ( p9 h15 )_t * y ( h3 h4 h7 p1 p5 p9 )_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 h3b 24 INTEGER h4b 25 INTEGER h7b 26 INTEGER h15b 27 INTEGER p1b 28 INTEGER p5b 29 INTEGER dimc 30 INTEGER l_c_sort 31 INTEGER k_c_sort 32 INTEGER p9b 33 INTEGER p9b_1 34 INTEGER h15b_1 35 INTEGER h3b_2 36 INTEGER h4b_2 37 INTEGER h7b_2 38 INTEGER p1b_2 39 INTEGER p5b_2 40 INTEGER p9b_2 41 INTEGER dim_common 42 INTEGER dima_sort 43 INTEGER dima 44 INTEGER dimb_sort 45 INTEGER dimb 46 INTEGER l_a_sort 47 INTEGER k_a_sort 48 INTEGER l_a 49 INTEGER k_a 50 INTEGER l_b_sort 51 INTEGER k_b_sort 52 INTEGER l_b 53 INTEGER k_b 54 INTEGER l_c 55 INTEGER k_c 56 EXTERNAL nxtask 57 nprocs = GA_NNODES() 58 count = 0 59 next = nxtask(nprocs,1) 60 DO h3b = 1,noab 61 DO h4b = h3b,noab 62 DO h7b = h4b,noab 63 DO h15b = 1,noab 64 DO p1b = noab+1,noab+nvab 65 DO p5b = p1b,noab+nvab 66 IF (next.eq.count) THEN 67 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1 68 &)+int_mb(k_spin+h7b-1)+int_mb(k_spin+h15b-1)+int_mb(k_spin+p1b-1)+ 69 &int_mb(k_spin+p5b-1).ne.12)) THEN 70 IF (int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)+int_mb(k_spin+h7b-1) 71 & .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p5b 72 &-1)) THEN 73 IF (ieor(int_mb(k_sym+h3b-1),ieor(int_mb(k_sym+h4b-1),ieor(int_mb( 74 &k_sym+h7b-1),ieor(int_mb(k_sym+h15b-1),ieor(int_mb(k_sym+p1b-1),in 75 &t_mb(k_sym+p5b-1)))))) .eq. ieor(irrep_y,irrep_t)) THEN 76 dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb(k_ra 77 &nge+h7b-1) * int_mb(k_range+h15b-1) * int_mb(k_range+p1b-1) * int_ 78 &mb(k_range+p5b-1) 79 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 80 & ERRQUIT('ccsdt_lr_alpha_offdiag_15_21_1_1',0,MA_ERR) 81 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 82 DO p9b = noab+1,noab+nvab 83 IF (int_mb(k_spin+p9b-1) .eq. int_mb(k_spin+h15b-1)) THEN 84 IF (ieor(int_mb(k_sym+p9b-1),int_mb(k_sym+h15b-1)) .eq. irrep_t) T 85 &HEN 86 CALL TCE_RESTRICTED_2(p9b,h15b,p9b_1,h15b_1) 87 CALL TCE_RESTRICTED_6(h3b,h4b,h7b,p1b,p5b,p9b,h3b_2,h4b_2,h7b_2,p1 88 &b_2,p5b_2,p9b_2) 89 dim_common = int_mb(k_range+p9b-1) 90 dima_sort = int_mb(k_range+h15b-1) 91 dima = dim_common * dima_sort 92 dimb_sort = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb 93 &(k_range+h7b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p5b-1) 94 dimb = dim_common * dimb_sort 95 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 96 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 97 & ERRQUIT('ccsdt_lr_alpha_offdiag_15_21_1_1',1,MA_ERR) 98 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 99 &ccsdt_lr_alpha_offdiag_15_21_1_1',2,MA_ERR) 100 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h15b_ 101 &1 - 1 + noab * (p9b_1 - noab - 1))) 102 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p9b-1) 103 &,int_mb(k_range+h15b-1),2,1,1.0d0) 104 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1 105 &5_21_1_1',3,MA_ERR) 106 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 107 & ERRQUIT('ccsdt_lr_alpha_offdiag_15_21_1_1',4,MA_ERR) 108 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 109 &ccsdt_lr_alpha_offdiag_15_21_1_1',5,MA_ERR) 110 IF ((p9b .lt. p1b)) THEN 111 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 112 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p9b_2 - noab - 1 113 &+ nvab * (h7b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_2 - 1))))))) 114 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 115 &,int_mb(k_range+h4b-1),int_mb(k_range+h7b-1),int_mb(k_range+p9b-1) 116 &,int_mb(k_range+p1b-1),int_mb(k_range+p5b-1),6,5,3,2,1,4,1.0d0) 117 END IF 118 IF ((p1b .le. p9b) .and. (p9b .lt. p5b)) THEN 119 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 120 & - noab - 1 + nvab * (p9b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 121 &+ nvab * (h7b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_2 - 1))))))) 122 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 123 &,int_mb(k_range+h4b-1),int_mb(k_range+h7b-1),int_mb(k_range+p1b-1) 124 &,int_mb(k_range+p9b-1),int_mb(k_range+p5b-1),6,4,3,2,1,5,-1.0d0) 125 END IF 126 IF ((p5b .le. p9b)) THEN 127 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p9b_2 128 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 129 &+ nvab * (h7b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_2 - 1))))))) 130 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 131 &,int_mb(k_range+h4b-1),int_mb(k_range+h7b-1),int_mb(k_range+p1b-1) 132 &,int_mb(k_range+p5b-1),int_mb(k_range+p9b-1),5,4,3,2,1,6,1.0d0) 133 END IF 134 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1 135 &5_21_1_1',6,MA_ERR) 136 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 137 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 138 &t),dima_sort) 139 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd 140 &iag_15_21_1_1',7,MA_ERR) 141 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd 142 &iag_15_21_1_1',8,MA_ERR) 143 END IF 144 END IF 145 END IF 146 END DO 147 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 148 &ccsdt_lr_alpha_offdiag_15_21_1_1',9,MA_ERR) 149 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 150 &,int_mb(k_range+p1b-1),int_mb(k_range+h7b-1),int_mb(k_range+h4b-1) 151 &,int_mb(k_range+h3b-1),int_mb(k_range+h15b-1),5,4,3,6,2,1,-1.0d0) 152 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 153 & noab - 1 + nvab * (p1b - noab - 1 + nvab * (h15b - 1 + noab * (h7 154 &b - 1 + noab * (h4b - 1 + noab * (h3b - 1))))))) 155 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1 156 &5_21_1_1',10,MA_ERR) 157 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd 158 &iag_15_21_1_1',11,MA_ERR) 159 END IF 160 END IF 161 END IF 162 next = nxtask(nprocs,1) 163 END IF 164 count = count + 1 165 END DO 166 END DO 167 END DO 168 END DO 169 END DO 170 END DO 171 next = nxtask(-nprocs,1) 172 call GA_SYNC() 173 RETURN 174 END 175