/src/tce/eomccsdtq/eomccsdtq_y1_21_2_1.F

https://github.com/nwchemgit/nwchem · FORTRAN Legacy · 311 lines · 272 code · 0 blank · 39 comment · 0 complexity · f94f76afc32cd287cfbd794849cc32c4 MD5 · raw file 

    

  1. SUBROUTINE eomccsdtq_y1_21_2_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k
    2. 

  2.      &_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     i2 ( h5 h6 h14 h15 p1 p3 )_yt + = 1 * Sum ( h9 p8 p7 ) * t ( p7 p8 h9 h15 )_t * i3 ( h5 h6 h9 h14 p1 p3 p7 p8 )_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 h5b
    24. 

  24.       INTEGER h6b
    25. 

  25.       INTEGER h14b
    26. 

  26.       INTEGER p1b
    27. 

  27.       INTEGER h15b
    28. 

  28.       INTEGER p3b
    29. 

  29.       INTEGER dimc
    30. 

  30.       INTEGER l_c_sort
    31. 

  31.       INTEGER k_c_sort
    32. 

  32.       INTEGER p7b
    33. 

  33.       INTEGER p8b
    34. 

  34.       INTEGER h9b
    35. 

  35.       INTEGER p7b_1
    36. 

  36.       INTEGER p8b_1
    37. 

  37.       INTEGER h15b_1
    38. 

  38.       INTEGER h9b_1
    39. 

  39.       INTEGER h5b_2
    40. 

  40.       INTEGER h6b_2
    41. 

  41.       INTEGER h14b_2
    42. 

  42.       INTEGER h9b_2
    43. 

  43.       INTEGER p1b_2
    44. 

  44.       INTEGER p3b_2
    45. 

  45.       INTEGER p7b_2
    46. 

  46.       INTEGER p8b_2
    47. 

  47.       INTEGER dim_common
    48. 

  48.       INTEGER dima_sort
    49. 

  49.       INTEGER dima
    50. 

  50.       INTEGER dimb_sort
    51. 

  51.       INTEGER dimb
    52. 

  52.       INTEGER l_a_sort
    53. 

  53.       INTEGER k_a_sort
    54. 

  54.       INTEGER l_a
    55. 

  55.       INTEGER k_a
    56. 

  56.       INTEGER l_b_sort
    57. 

  57.       INTEGER k_b_sort
    58. 

  58.       INTEGER l_b
    59. 

  59.       INTEGER k_b
    60. 

  60.       INTEGER nsuperp(2)
    61. 

  61.       INTEGER isuperp
    62. 

  62.       INTEGER l_c
    63. 

  63.       INTEGER k_c
    64. 

  64.       DOUBLE PRECISION FACTORIAL
    65. 

  65.       EXTERNAL NXTASK
    66. 

  66.       EXTERNAL FACTORIAL
    67. 

  67.       nprocs = GA_NNODES()
    68. 

  68.       count = 0
    69. 

  69.       next = NXTASK(nprocs,1)
    70. 

  70.       DO h5b = 1,noab
    71. 

  71.       DO h6b = h5b,noab
    72. 

  72.       DO h14b = h6b,noab
    73. 

  73.       DO p1b = noab+1,noab+nvab
    74. 

  74.       DO h15b = 1,noab
    75. 

  75.       DO p3b = noab+1,noab+nvab
    76. 

  76.       IF (next.eq.count) THEN
    77. 

  77.       IF ((.not.restricted).or.(int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1
    78. 

  78.      &)+int_mb(k_spin+h14b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+h15b-1)
    79. 

  79.      &+int_mb(k_spin+p3b-1).ne.12)) THEN
    80. 

  80.       IF (int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)+int_mb(k_spin+h14b-1
    81. 

  81.      &) .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+h15b-1)+int_mb(k_spin+p3
    82. 

  82.      &b-1)) THEN
    83. 

  83.       IF (ieor(int_mb(k_sym+h5b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb(
    84. 

  84.      &k_sym+h14b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+h15b-1),i
    85. 

  85.      &nt_mb(k_sym+p3b-1)))))) .eq. ieor(irrep_y,irrep_t)) THEN
    86. 

  86.       dimc = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra
    87. 

  87.      &nge+h14b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+h15b-1) * int
    88. 

  88.      &_mb(k_range+p3b-1)
    89. 

  89.       IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
    90. 

  90.      & ERRQUIT('eomccsdtq_y1_21_2_1',0,MA_ERR)
    91. 

  91.       CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
    92. 

  92.       DO p7b = noab+1,noab+nvab
    93. 

  93.       DO p8b = p7b,noab+nvab
    94. 

  94.       DO h9b = 1,noab
    95. 

  95.       IF (int_mb(k_spin+p7b-1)+int_mb(k_spin+p8b-1) .eq. int_mb(k_spin+h
    96. 

  96.      &15b-1)+int_mb(k_spin+h9b-1)) THEN
    97. 

  97.       IF (ieor(int_mb(k_sym+p7b-1),ieor(int_mb(k_sym+p8b-1),ieor(int_mb(
    98. 

  98.      &k_sym+h15b-1),int_mb(k_sym+h9b-1)))) .eq. irrep_t) THEN
    99. 

  99.       CALL TCE_RESTRICTED_4(p7b,p8b,h15b,h9b,p7b_1,p8b_1,h15b_1,h9b_1)
    100. 

  100.       CALL TCE_RESTRICTED_8(h5b,h6b,h14b,h9b,p1b,p3b,p7b,p8b,h5b_2,h6b_2
    101. 

  101.      &,h14b_2,h9b_2,p1b_2,p3b_2,p7b_2,p8b_2)
    102. 

  102.       dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+p8b-1) * int_m
    103. 

  103.      &b(k_range+h9b-1)
    104. 

  104.       dima_sort = int_mb(k_range+h15b-1)
    105. 

  105.       dima = dim_common * dima_sort
    106. 

  106.       dimb_sort = int_mb(k_range+h5b-1) * int_mb(k_range+h6b-1) * int_mb
    107. 

  107.      &(k_range+h14b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p3b-1)
    108. 

  108.       dimb = dim_common * dimb_sort
    109. 

  109.       IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
    110. 

  110.       IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
    111. 

  111.      & ERRQUIT('eomccsdtq_y1_21_2_1',1,MA_ERR)
    112. 

  112.       IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
    113. 

  113.      &eomccsdtq_y1_21_2_1',2,MA_ERR)
    114. 

  114.       IF ((h9b .le. h15b)) THEN
    115. 

  115.       CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h15b_
    116. 

  116.      &1 - 1 + noab * (h9b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p7b
    117. 

  117.      &_1 - noab - 1)))))
    118. 

  118.       CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
    119. 

  119.      &,int_mb(k_range+p8b-1),int_mb(k_range+h9b-1),int_mb(k_range+h15b-1
    120. 

  120.      &),4,3,2,1,1.0d0)
    121. 

  121.       END IF
    122. 

  122.       IF ((h15b .lt. h9b)) THEN
    123. 

  123.       CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h9b_1
    124. 

  124.      & - 1 + noab * (h15b_1 - 1 + noab * (p8b_1 - noab - 1 + nvab * (p7b
    125. 

  125.      &_1 - noab - 1)))))
    126. 

  126.       CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p7b-1)
    127. 

  127.      &,int_mb(k_range+p8b-1),int_mb(k_range+h15b-1),int_mb(k_range+h9b-1
    128. 

  128.      &),3,4,2,1,-1.0d0)
    129. 

  129.       END IF
    130. 

  130.       IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('eomccsdtq_y1_21_2_1',3,M
    131. 

  131.      &A_ERR)
    132. 

  132.       IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
    133. 

  133.      & ERRQUIT('eomccsdtq_y1_21_2_1',4,MA_ERR)
    134. 

  134.       IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
    135. 

  135.      &eomccsdtq_y1_21_2_1',5,MA_ERR)
    136. 

  136.       IF ((h9b .lt. h5b) .and. (p8b .lt. p3b)) THEN
    137. 

  137.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
    138. 

  138.      & - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    139. 

  139.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h6b_2 - 
    140. 

  140.      &1 + noab * (h5b_2 - 1 + noab * (h9b_2 - 1)))))))))
    141. 

  141.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
    142. 

  142.      &,int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h14b-1
    143. 

  143.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1
    144. 

  144.      &),int_mb(k_range+p3b-1),8,5,4,3,2,1,7,6,1.0d0)
    145. 

  145.       END IF
    146. 

  146.       IF ((h9b .lt. h5b) .and. (p7b .lt. p3b) .and. (p3b .le. p8b)) THEN
    147. 

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

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

  149.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h6b_2 - 
    150. 

  150.      &1 + noab * (h5b_2 - 1 + noab * (h9b_2 - 1)))))))))
    151. 

  151.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
    152. 

  152.      &,int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h14b-1
    153. 

  153.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1
    154. 

  154.      &),int_mb(k_range+p8b-1),7,5,4,3,2,1,8,6,-1.0d0)
    155. 

  155.       END IF
    156. 

  156.       IF ((h9b .lt. h5b) .and. (p3b .le. p7b)) THEN
    157. 

  157.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
    158. 

  158.      & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    159. 

  159.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h6b_2 - 
    160. 

  160.      &1 + noab * (h5b_2 - 1 + noab * (h9b_2 - 1)))))))))
    161. 

  161.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1)
    162. 

  162.      &,int_mb(k_range+h5b-1),int_mb(k_range+h6b-1),int_mb(k_range+h14b-1
    163. 

  163.      &),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1
    164. 

  164.      &),int_mb(k_range+p8b-1),6,5,4,3,2,1,8,7,1.0d0)
    165. 

  165.       END IF
    166. 

  166.       IF ((h5b .le. h9b) .and. (h9b .lt. h6b) .and. (p8b .lt. p3b)) THEN
    167. 

  167.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
    168. 

  168.      & - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    169. 

  169.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h6b_2 - 
    170. 

  170.      &1 + noab * (h9b_2 - 1 + noab * (h5b_2 - 1)))))))))
    171. 

  171.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    172. 

  172.      &,int_mb(k_range+h9b-1),int_mb(k_range+h6b-1),int_mb(k_range+h14b-1
    173. 

  173.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1
    174. 

  174.      &),int_mb(k_range+p3b-1),8,5,4,3,1,2,7,6,-1.0d0)
    175. 

  175.       END IF
    176. 

  176.       IF ((h5b .le. h9b) .and. (h9b .lt. h6b) .and. (p7b .lt. p3b) .and.
    177. 

  177.      & (p3b .le. p8b)) THEN
    178. 

  178.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
    179. 

  179.      & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    180. 

  180.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h6b_2 - 
    181. 

  181.      &1 + noab * (h9b_2 - 1 + noab * (h5b_2 - 1)))))))))
    182. 

  182.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    183. 

  183.      &,int_mb(k_range+h9b-1),int_mb(k_range+h6b-1),int_mb(k_range+h14b-1
    184. 

  184.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1
    185. 

  185.      &),int_mb(k_range+p8b-1),7,5,4,3,1,2,8,6,1.0d0)
    186. 

  186.       END IF
    187. 

  187.       IF ((h5b .le. h9b) .and. (h9b .lt. h6b) .and. (p3b .le. p7b)) THEN
    188. 

  188.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
    189. 

  189.      & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    190. 

  190.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h6b_2 - 
    191. 

  191.      &1 + noab * (h9b_2 - 1 + noab * (h5b_2 - 1)))))))))
    192. 

  192.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    193. 

  193.      &,int_mb(k_range+h9b-1),int_mb(k_range+h6b-1),int_mb(k_range+h14b-1
    194. 

  194.      &),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1
    195. 

  195.      &),int_mb(k_range+p8b-1),6,5,4,3,1,2,8,7,-1.0d0)
    196. 

  196.       END IF
    197. 

  197.       IF ((h6b .le. h9b) .and. (h9b .le. h14b) .and. (p8b .lt. p3b)) THE
    198. 

  198.      &N
    199. 

  199.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
    200. 

  200.      & - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    201. 

  201.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h9b_2 - 
    202. 

  202.      &1 + noab * (h6b_2 - 1 + noab * (h5b_2 - 1)))))))))
    203. 

  203.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    204. 

  204.      &,int_mb(k_range+h6b-1),int_mb(k_range+h9b-1),int_mb(k_range+h14b-1
    205. 

  205.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1
    206. 

  206.      &),int_mb(k_range+p3b-1),8,5,4,2,1,3,7,6,1.0d0)
    207. 

  207.       END IF
    208. 

  208.       IF ((h6b .le. h9b) .and. (h9b .le. h14b) .and. (p7b .lt. p3b) .and
    209. 

  209.      &. (p3b .le. p8b)) THEN
    210. 

  210.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
    211. 

  211.      & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    212. 

  212.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h9b_2 - 
    213. 

  213.      &1 + noab * (h6b_2 - 1 + noab * (h5b_2 - 1)))))))))
    214. 

  214.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    215. 

  215.      &,int_mb(k_range+h6b-1),int_mb(k_range+h9b-1),int_mb(k_range+h14b-1
    216. 

  216.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1
    217. 

  217.      &),int_mb(k_range+p8b-1),7,5,4,2,1,3,8,6,-1.0d0)
    218. 

  218.       END IF
    219. 

  219.       IF ((h6b .le. h9b) .and. (h9b .le. h14b) .and. (p3b .le. p7b)) THE
    220. 

  220.      &N
    221. 

  221.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
    222. 

  222.      & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    223. 

  223.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h14b_2 - 1 + noab * (h9b_2 - 
    224. 

  224.      &1 + noab * (h6b_2 - 1 + noab * (h5b_2 - 1)))))))))
    225. 

  225.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    226. 

  226.      &,int_mb(k_range+h6b-1),int_mb(k_range+h9b-1),int_mb(k_range+h14b-1
    227. 

  227.      &),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1
    228. 

  228.      &),int_mb(k_range+p8b-1),6,5,4,2,1,3,8,7,1.0d0)
    229. 

  229.       END IF
    230. 

  230.       IF ((h14b .lt. h9b) .and. (p8b .lt. p3b)) THEN
    231. 

  231.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
    232. 

  232.      & - noab - 1 + nvab * (p8b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    233. 

  233.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h9b_2 - 1 + noab * (h14b_2 - 
    234. 

  234.      &1 + noab * (h6b_2 - 1 + noab * (h5b_2 - 1)))))))))
    235. 

  235.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    236. 

  236.      &,int_mb(k_range+h6b-1),int_mb(k_range+h14b-1),int_mb(k_range+h9b-1
    237. 

  237.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p8b-1
    238. 

  238.      &),int_mb(k_range+p3b-1),8,5,3,2,1,4,7,6,-1.0d0)
    239. 

  239.       END IF
    240. 

  240.       IF ((h14b .lt. h9b) .and. (p7b .lt. p3b) .and. (p3b .le. p8b)) THE
    241. 

  241.      &N
    242. 

  242.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
    243. 

  243.      & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p7b_2 - noab - 1 
    244. 

  244.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h9b_2 - 1 + noab * (h14b_2 - 
    245. 

  245.      &1 + noab * (h6b_2 - 1 + noab * (h5b_2 - 1)))))))))
    246. 

  246.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    247. 

  247.      &,int_mb(k_range+h6b-1),int_mb(k_range+h14b-1),int_mb(k_range+h9b-1
    248. 

  248.      &),int_mb(k_range+p1b-1),int_mb(k_range+p7b-1),int_mb(k_range+p3b-1
    249. 

  249.      &),int_mb(k_range+p8b-1),7,5,3,2,1,4,8,6,1.0d0)
    250. 

  250.       END IF
    251. 

  251.       IF ((h14b .lt. h9b) .and. (p3b .le. p7b)) THEN
    252. 

  252.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p8b_2
    253. 

  253.      & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 
    254. 

  254.      &+ nvab * (p1b_2 - noab - 1 + nvab * (h9b_2 - 1 + noab * (h14b_2 - 
    255. 

  255.      &1 + noab * (h6b_2 - 1 + noab * (h5b_2 - 1)))))))))
    256. 

  256.       CALL TCE_SORT_8(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h5b-1)
    257. 

  257.      &,int_mb(k_range+h6b-1),int_mb(k_range+h14b-1),int_mb(k_range+h9b-1
    258. 

  258.      &),int_mb(k_range+p1b-1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1
    259. 

  259.      &),int_mb(k_range+p8b-1),6,5,3,2,1,4,8,7,-1.0d0)
    260. 

  260.       END IF
    261. 

  261.       IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('eomccsdtq_y1_21_2_1',6,M
    262. 

  262.      &A_ERR)
    263. 

  263.       nsuperp(1) = 1
    264. 

  264.       nsuperp(2) = 1
    265. 

  265.       isuperp = 1
    266. 

  266.       IF (p7b .eq. p8b) THEN
    267. 

  267.       nsuperp(isuperp) = nsuperp(isuperp) + 1
    268. 

  268.       ELSE
    269. 

  269.       isuperp = isuperp + 1
    270. 

  270.       END IF
    271. 

  271.       CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL(
    272. 

  272.      &nsuperp(1))/FACTORIAL(nsuperp(2)),dbl_mb(k_a_sort),dim_common,dbl_
    273. 

  273.      &mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort)
    274. 

  274.       IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('eomccsdtq_y1_21_2_1
    275. 

  275.      &',7,MA_ERR)
    276. 

  276.       IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('eomccsdtq_y1_21_2_1
    277. 

  277.      &',8,MA_ERR)
    278. 

  278.       END IF
    279. 

  279.       END IF
    280. 

  280.       END IF
    281. 

  281.       END DO
    282. 

  282.       END DO
    283. 

  283.       END DO
    284. 

  284.       IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
    285. 

  285.      &eomccsdtq_y1_21_2_1',9,MA_ERR)
    286. 

  286.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    287. 

  287.      &,int_mb(k_range+p1b-1),int_mb(k_range+h14b-1),int_mb(k_range+h6b-1
    288. 

  288.      &),int_mb(k_range+h5b-1),int_mb(k_range+h15b-1),5,4,3,2,6,1,1.0d0)
    289. 

  289.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
    290. 

  290.      & noab - 1 + nvab * (h15b - 1 + noab * (p1b - noab - 1 + nvab * (h1
    291. 

  291.      &4b - 1 + noab * (h6b - 1 + noab * (h5b - 1)))))))
    292. 

  292.       IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('eomccsdtq_y1_21_2_1',10,
    293. 

  293.      &MA_ERR)
    294. 

  294.       IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('eomccsdtq_y1_21_2_1
    295. 

  295.      &',11,MA_ERR)
    296. 

  296.       END IF
    297. 

  297.       END IF
    298. 

  298.       END IF
    299. 

  299.       next = NXTASK(nprocs,1)
    300. 

  300.       END IF
    301. 

  301.       count = count + 1
    302. 

  302.       END DO
    303. 

  303.       END DO
    304. 

  304.       END DO
    305. 

  305.       END DO
    306. 

  306.       END DO
    307. 

  307.       END DO
    308. 

  308.       next = NXTASK(-nprocs,1)
    309. 

  309.       call GA_SYNC()
    310. 

  310.       RETURN
    311. 

  311.       END
    312.