/src/tce/eomccsdtq/eomccsdtq_density1_5_4_7_1.F

https://github.com/nwchemgit/nwchem · FORTRAN Legacy · 217 lines · 187 code · 0 blank · 30 comment · 0 complexity · 78c6bb05b56650b59b3d4e01ad0753f9 MD5 · raw file 

    

  1. SUBROUTINE eomccsdtq_density1_5_4_7_1(d_a,k_a_offset,d_b,k_b_offse
    2. 

  2.      &t,d_c,k_c_offset)
    3. 

  3. C     $Id$
    4. 

  4. C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
    5. 

  5. C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
    6. 

  6. C     i3 ( h2 h5 p3 p4 )_yx + = -1 * Sum ( h8 p7 ) * x ( p7 h8 )_x * y ( h2 h5 h8 p3 p4 p7 )_y
    7. 

  7.       IMPLICIT NONE
    8. 

  8. #include "global.fh"
    9. 

  9. #include "mafdecls.fh"
    10. 

  10. #include "sym.fh"
    11. 

  11. #include "errquit.fh"
    12. 

  12. #include "tce.fh"
    13. 

  13.       INTEGER d_a
    14. 

  14.       INTEGER k_a_offset
    15. 

  15.       INTEGER d_b
    16. 

  16.       INTEGER k_b_offset
    17. 

  17.       INTEGER d_c
    18. 

  18.       INTEGER k_c_offset
    19. 

  19.       INTEGER NXTASK
    20. 

  20.       INTEGER next
    21. 

  21.       INTEGER nprocs
    22. 

  22.       INTEGER count
    23. 

  23.       INTEGER h2b
    24. 

  24.       INTEGER h5b
    25. 

  25.       INTEGER p3b
    26. 

  26.       INTEGER p4b
    27. 

  27.       INTEGER dimc
    28. 

  28.       INTEGER l_c_sort
    29. 

  29.       INTEGER k_c_sort
    30. 

  30.       INTEGER p7b
    31. 

  31.       INTEGER h8b
    32. 

  32.       INTEGER p7b_1
    33. 

  33.       INTEGER h8b_1
    34. 

  34.       INTEGER h2b_2
    35. 

  35.       INTEGER h5b_2
    36. 

  36.       INTEGER h8b_2
    37. 

  37.       INTEGER p3b_2
    38. 

  38.       INTEGER p4b_2
    39. 

  39.       INTEGER p7b_2
    40. 

  40.       INTEGER dim_common
    41. 

  41.       INTEGER dima_sort
    42. 

  42.       INTEGER dima
    43. 

  43.       INTEGER dimb_sort
    44. 

  44.       INTEGER dimb
    45. 

  45.       INTEGER l_a_sort
    46. 

  46.       INTEGER k_a_sort
    47. 

  47.       INTEGER l_a
    48. 

  48.       INTEGER k_a
    49. 

  49.       INTEGER l_b_sort
    50. 

  50.       INTEGER k_b_sort
    51. 

  51.       INTEGER l_b
    52. 

  52.       INTEGER k_b
    53. 

  53.       INTEGER l_c
    54. 

  54.       INTEGER k_c
    55. 

  55.       EXTERNAL NXTASK
    56. 

  56.       nprocs = GA_NNODES()
    57. 

  57.       count = 0
    58. 

  58.       next = NXTASK(nprocs,1)
    59. 

  59.       DO h2b = 1,noab
    60. 

  60.       DO h5b = h2b,noab
    61. 

  61.       DO p3b = noab+1,noab+nvab
    62. 

  62.       DO p4b = p3b,noab+nvab
    63. 

  63.       IF (next.eq.count) THEN
    64. 

  64.       IF ((.not.restricted).or.(int_mb(k_spin+h2b-1)+int_mb(k_spin+h5b-1
    65. 

  65.      &)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p4b-1).ne.8)) THEN
    66. 

  66.       IF (int_mb(k_spin+h2b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p
    67. 

  67.      &3b-1)+int_mb(k_spin+p4b-1)) THEN
    68. 

  68.       IF (ieor(int_mb(k_sym+h2b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
    69. 

  69.      &k_sym+p3b-1),int_mb(k_sym+p4b-1)))) .eq. ieor(irrep_y,irrep_x)) TH
    70. 

  70.      &EN
    71. 

  71.       dimc = int_mb(k_range+h2b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra
    72. 

  72.      &nge+p3b-1) * int_mb(k_range+p4b-1)
    73. 

  73.       IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
    74. 

  74.      & ERRQUIT('eomccsdtq_density1_5_4_7_1',0,MA_ERR)
    75. 

  75.       CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
    76. 

  76.       DO p7b = noab+1,noab+nvab
    77. 

  77.       DO h8b = 1,noab
    78. 

  78.       IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h8b-1)) THEN
    79. 

  79.       IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h8b-1)) .eq. irrep_x) TH
    80. 

  80.      &EN
    81. 

  81.       CALL TCE_RESTRICTED_2(p7b,h8b,p7b_1,h8b_1)
    82. 

  82.       CALL TCE_RESTRICTED_6(h2b,h5b,h8b,p3b,p4b,p7b,h2b_2,h5b_2,h8b_2,p3
    83. 

  83.      &b_2,p4b_2,p7b_2)
    84. 

  84.       dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h8b-1)
    85. 

  85.       dima_sort = 1
    86. 

  86.       dima = dim_common * dima_sort
    87. 

  87.       dimb_sort = int_mb(k_range+h2b-1) * int_mb(k_range+h5b-1) * int_mb
    88. 

  88.      &(k_range+p3b-1) * int_mb(k_range+p4b-1)
    89. 

  89.       dimb = dim_common * dimb_sort
    90. 

  90.       IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
    91. 

  91.       IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
    92. 

  92.      & ERRQUIT('eomccsdtq_density1_5_4_7_1',1,MA_ERR)
    93. 

  93.       IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
    94. 

  94.      &eomccsdtq_density1_5_4_7_1',2,MA_ERR)
    95. 

  95.       CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1
    96. 

  96.      & - 1 + noab * (p7b_1 - noab - 1)))
    97. 

  97.       CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
    98. 

  98.      &,int_mb(k_range+h8b-1),2,1,1.0d0)
    99. 

  99.       IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsdtq_density1_5_4_7
    100. 

  100.      &_1',3,MA_ERR)
    101. 

  101.       IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
    102. 

  102.      & ERRQUIT('eomccsdtq_density1_5_4_7_1',4,MA_ERR)
    103. 

  103.       IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
    104. 

  104.      &eomccsdtq_density1_5_4_7_1',5,MA_ERR)
    105. 

  105.       IF ((h8b .lt. h2b) .and. (p7b .lt. p3b)) THEN
    106. 

  106.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
    107. 

  107.      & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    108. 

  108.      &+ nvab * (h5b_2 - 1 + noab * (h2b_2 - 1 + noab * (h8b_2 - 1)))))))
    109. 

  109.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
    110. 

  110.      &,int_mb(k_range+h2b-1),int_mb(k_range+h5b-1),int_mb(k_range+p7b-1)
    111. 

  111.      &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),6,5,3,2,1,4,1.0d0)
    112. 

  112.       END IF
    113. 

  113.       IF ((h8b .lt. h2b) .and. (p3b .le. p7b) .and. (p7b .lt. p4b)) THEN
    114. 

  114.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
    115. 

  115.      & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    116. 

  116.      &+ nvab * (h5b_2 - 1 + noab * (h2b_2 - 1 + noab * (h8b_2 - 1)))))))
    117. 

  117.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
    118. 

  118.      &,int_mb(k_range+h2b-1),int_mb(k_range+h5b-1),int_mb(k_range+p3b-1)
    119. 

  119.      &,int_mb(k_range+p7b-1),int_mb(k_range+p4b-1),6,4,3,2,1,5,-1.0d0)
    120. 

  120.       END IF
    121. 

  121.       IF ((h8b .lt. h2b) .and. (p4b .le. p7b)) THEN
    122. 

  122.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
    123. 

  123.      & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    124. 

  124.      &+ nvab * (h5b_2 - 1 + noab * (h2b_2 - 1 + noab * (h8b_2 - 1)))))))
    125. 

  125.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1)
    126. 

  126.      &,int_mb(k_range+h2b-1),int_mb(k_range+h5b-1),int_mb(k_range+p3b-1)
    127. 

  127.      &,int_mb(k_range+p4b-1),int_mb(k_range+p7b-1),5,4,3,2,1,6,1.0d0)
    128. 

  128.       END IF
    129. 

  129.       IF ((h2b .le. h8b) .and. (h8b .lt. h5b) .and. (p7b .lt. p3b)) THEN
    130. 

  130.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
    131. 

  131.      & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    132. 

  132.      &+ nvab * (h5b_2 - 1 + noab * (h8b_2 - 1 + noab * (h2b_2 - 1)))))))
    133. 

  133.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
    134. 

  134.      &,int_mb(k_range+h8b-1),int_mb(k_range+h5b-1),int_mb(k_range+p7b-1)
    135. 

  135.      &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),6,5,3,1,2,4,-1.0d0)
    136. 

  136.       END IF
    137. 

  137.       IF ((h2b .le. h8b) .and. (h8b .lt. h5b) .and. (p3b .le. p7b) .and.
    138. 

  138.      & (p7b .lt. p4b)) THEN
    139. 

  139.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
    140. 

  140.      & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    141. 

  141.      &+ nvab * (h5b_2 - 1 + noab * (h8b_2 - 1 + noab * (h2b_2 - 1)))))))
    142. 

  142.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
    143. 

  143.      &,int_mb(k_range+h8b-1),int_mb(k_range+h5b-1),int_mb(k_range+p3b-1)
    144. 

  144.      &,int_mb(k_range+p7b-1),int_mb(k_range+p4b-1),6,4,3,1,2,5,1.0d0)
    145. 

  145.       END IF
    146. 

  146.       IF ((h2b .le. h8b) .and. (h8b .lt. h5b) .and. (p4b .le. p7b)) THEN
    147. 

  147.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
    148. 

  148.      & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    149. 

  149.      &+ nvab * (h5b_2 - 1 + noab * (h8b_2 - 1 + noab * (h2b_2 - 1)))))))
    150. 

  150.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
    151. 

  151.      &,int_mb(k_range+h8b-1),int_mb(k_range+h5b-1),int_mb(k_range+p3b-1)
    152. 

  152.      &,int_mb(k_range+p4b-1),int_mb(k_range+p7b-1),5,4,3,1,2,6,-1.0d0)
    153. 

  153.       END IF
    154. 

  154.       IF ((h5b .le. h8b) .and. (p7b .lt. p3b)) THEN
    155. 

  155.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
    156. 

  156.      & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    157. 

  157.      &+ nvab * (h8b_2 - 1 + noab * (h5b_2 - 1 + noab * (h2b_2 - 1)))))))
    158. 

  158.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
    159. 

  159.      &,int_mb(k_range+h5b-1),int_mb(k_range+h8b-1),int_mb(k_range+p7b-1)
    160. 

  160.      &,int_mb(k_range+p3b-1),int_mb(k_range+p4b-1),6,5,2,1,3,4,1.0d0)
    161. 

  161.       END IF
    162. 

  162.       IF ((h5b .le. h8b) .and. (p3b .le. p7b) .and. (p7b .lt. p4b)) THEN
    163. 

  163.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p4b_2
    164. 

  164.      & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    165. 

  165.      &+ nvab * (h8b_2 - 1 + noab * (h5b_2 - 1 + noab * (h2b_2 - 1)))))))
    166. 

  166.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
    167. 

  167.      &,int_mb(k_range+h5b-1),int_mb(k_range+h8b-1),int_mb(k_range+p3b-1)
    168. 

  168.      &,int_mb(k_range+p7b-1),int_mb(k_range+p4b-1),6,4,2,1,3,5,-1.0d0)
    169. 

  169.       END IF
    170. 

  170.       IF ((h5b .le. h8b) .and. (p4b .le. p7b)) THEN
    171. 

  171.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2
    172. 

  172.      & - noab - 1 + nvab * (p4b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    173. 

  173.      &+ nvab * (h8b_2 - 1 + noab * (h5b_2 - 1 + noab * (h2b_2 - 1)))))))
    174. 

  174.       CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h2b-1)
    175. 

  175.      &,int_mb(k_range+h5b-1),int_mb(k_range+h8b-1),int_mb(k_range+p3b-1)
    176. 

  176.      &,int_mb(k_range+p4b-1),int_mb(k_range+p7b-1),5,4,2,1,3,6,1.0d0)
    177. 

  177.       END IF
    178. 

  178.       IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsdtq_density1_5_4_7
    179. 

  179.      &_1',6,MA_ERR)
    180. 

  180.       CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
    181. 

  181.      &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
    182. 

  182.      &t),dima_sort)
    183. 

  183.       IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsdtq_density1_
    184. 

  184.      &5_4_7_1',7,MA_ERR)
    185. 

  185.       IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsdtq_density1_
    186. 

  186.      &5_4_7_1',8,MA_ERR)
    187. 

  187.       END IF
    188. 

  188.       END IF
    189. 

  189.       END IF
    190. 

  190.       END DO
    191. 

  191.       END DO
    192. 

  192.       IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
    193. 

  193.      &eomccsdtq_density1_5_4_7_1',9,MA_ERR)
    194. 

  194.       CALL TCE_SORT_4(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p4b-1)
    195. 

  195.      &,int_mb(k_range+p3b-1),int_mb(k_range+h5b-1),int_mb(k_range+h2b-1)
    196. 

  196.      &,4,3,2,1,-1.0d0)
    197. 

  197.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p4b -
    198. 

  198.      & noab - 1 + nvab * (p3b - noab - 1 + nvab * (h5b - 1 + noab * (h2b
    199. 

  199.      & - 1)))))
    200. 

  200.       IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsdtq_density1_5_4_7
    201. 

  201.      &_1',10,MA_ERR)
    202. 

  202.       IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsdtq_density1_
    203. 

  203.      &5_4_7_1',11,MA_ERR)
    204. 

  204.       END IF
    205. 

  205.       END IF
    206. 

  206.       END IF
    207. 

  207.       next = NXTASK(nprocs,1)
    208. 

  208.       END IF
    209. 

  209.       count = count + 1
    210. 

  210.       END DO
    211. 

  211.       END DO
    212. 

  212.       END DO
    213. 

  213.       END DO
    214. 

  214.       next = NXTASK(-nprocs,1)
    215. 

  215.       call GA_SYNC()
    216. 

  216.       RETURN
    217. 

  217.       END
    218.