1 SUBROUTINE ccsdt_y_tr2_23_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_ 2 &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 ( h3 h4 p11 h8 h10 p1 )_yttr + = 1 * tr ( p11 h10 )_tr * i2 ( h3 h4 h8 p1 )_yt 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 p11b 26 INTEGER p1b 27 INTEGER h10b 28 INTEGER h8b 29 INTEGER dimc 30 INTEGER l_c_sort 31 INTEGER k_c_sort 32 INTEGER p11b_1 33 INTEGER h10b_1 34 INTEGER h3b_2 35 INTEGER h4b_2 36 INTEGER p1b_2 37 INTEGER h8b_2 38 INTEGER dim_common 39 INTEGER dima_sort 40 INTEGER dima 41 INTEGER dimb_sort 42 INTEGER dimb 43 INTEGER l_a_sort 44 INTEGER k_a_sort 45 INTEGER l_a 46 INTEGER k_a 47 INTEGER l_b_sort 48 INTEGER k_b_sort 49 INTEGER l_b 50 INTEGER k_b 51 INTEGER l_c 52 INTEGER k_c 53 EXTERNAL nxtask 54 nprocs = GA_NNODES() 55 count = 0 56 next = nxtask(nprocs,1) 57 DO h3b = 1,noab 58 DO h4b = h3b,noab 59 DO p11b = noab+1,noab+nvab 60 DO p1b = noab+1,noab+nvab 61 DO h10b = 1,noab 62 DO h8b = 1,noab 63 IF (next.eq.count) THEN 64 IF ((.not.restricted).or.(int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1 65 &)+int_mb(k_spin+p11b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h8b-1)+ 66 &int_mb(k_spin+h10b-1).ne.12)) THEN 67 IF (int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)+int_mb(k_spin+p11b-1 68 &) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+h8b-1)+int_mb(k_spin+h10 69 &b-1)) THEN 70 IF (ieor(int_mb(k_sym+h3b-1),ieor(int_mb(k_sym+h4b-1),ieor(int_mb( 71 &k_sym+p11b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+h8b-1),in 72 &t_mb(k_sym+h10b-1)))))) .eq. ieor(irrep_y,ieor(irrep_t,irrep_tr))) 73 & THEN 74 dimc = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb(k_ra 75 &nge+p11b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+h8b-1) * int_ 76 &mb(k_range+h10b-1) 77 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 78 & ERRQUIT('ccsdt_y_tr2_23_2',0,MA_ERR) 79 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 80 IF (int_mb(k_spin+p11b-1) .eq. int_mb(k_spin+h10b-1)) THEN 81 IF (ieor(int_mb(k_sym+p11b-1),int_mb(k_sym+h10b-1)) .eq. irrep_tr) 82 & THEN 83 CALL TCE_RESTRICTED_2(p11b,h10b,p11b_1,h10b_1) 84 CALL TCE_RESTRICTED_4(h3b,h4b,p1b,h8b,h3b_2,h4b_2,p1b_2,h8b_2) 85 dim_common = 1 86 dima_sort = int_mb(k_range+p11b-1) * int_mb(k_range+h10b-1) 87 dima = dim_common * dima_sort 88 dimb_sort = int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1) * int_mb 89 &(k_range+p1b-1) * int_mb(k_range+h8b-1) 90 dimb = dim_common * dimb_sort 91 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 92 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 93 & ERRQUIT('ccsdt_y_tr2_23_2',1,MA_ERR) 94 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 95 &ccsdt_y_tr2_23_2',2,MA_ERR) 96 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h10b_ 97 &1 - 1 + noab * (p11b_1 - noab - 1))) 98 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p11b-1 99 &),int_mb(k_range+h10b-1),2,1,1.0d0) 100 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_y_tr2_23_2',3,MA_E 101 &RR) 102 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 103 & ERRQUIT('ccsdt_y_tr2_23_2',4,MA_ERR) 104 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 105 &ccsdt_y_tr2_23_2',5,MA_ERR) 106 IF ((h8b .le. p1b)) THEN 107 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 108 & - noab - 1 + nvab * (h8b_2 - 1 + noab * (h4b_2 - 1 + noab * (h3b_ 109 &2 - 1))))) 110 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 111 &,int_mb(k_range+h4b-1),int_mb(k_range+h8b-1),int_mb(k_range+p1b-1) 112 &,3,4,2,1,1.0d0) 113 END IF 114 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_y_tr2_23_2',6,MA_E 115 &RR) 116 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 117 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 118 &t),dima_sort) 119 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdt_y_tr2_23_2',7 120 &,MA_ERR) 121 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_y_tr2_23_2',8 122 &,MA_ERR) 123 END IF 124 END IF 125 END IF 126 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 127 &ccsdt_y_tr2_23_2',9,MA_ERR) 128 IF ((h8b .le. h10b)) THEN 129 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1) 130 &,int_mb(k_range+p1b-1),int_mb(k_range+h4b-1),int_mb(k_range+h3b-1) 131 &,int_mb(k_range+h10b-1),int_mb(k_range+p11b-1),4,3,6,2,1,5,1.0d0/2 132 &.0d0) 133 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h10b 134 &- 1 + noab * (h8b - 1 + noab * (p1b - noab - 1 + nvab * (p11b - no 135 &ab - 1 + nvab * (h4b - 1 + noab * (h3b - 1))))))) 136 END IF 137 IF ((h10b .le. h8b)) THEN 138 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+h8b-1) 139 &,int_mb(k_range+p1b-1),int_mb(k_range+h4b-1),int_mb(k_range+h3b-1) 140 &,int_mb(k_range+h10b-1),int_mb(k_range+p11b-1),4,3,6,2,5,1,-1.0d0/ 141 &2.0d0) 142 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h8b - 143 & 1 + noab * (h10b - 1 + noab * (p1b - noab - 1 + nvab * (p11b - no 144 &ab - 1 + nvab * (h4b - 1 + noab * (h3b - 1))))))) 145 END IF 146 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_y_tr2_23_2',10,MA_ 147 &ERR) 148 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_y_tr2_23_2',1 149 &1,MA_ERR) 150 END IF 151 END IF 152 END IF 153 next = nxtask(nprocs,1) 154 END IF 155 count = count + 1 156 END DO 157 END DO 158 END DO 159 END DO 160 END DO 161 END DO 162 next = nxtask(-nprocs,1) 163 call GA_SYNC() 164 RETURN 165 END 166