1! PR middle-end/68251 2! Reduced testcase by Joost VandeVondele <Joost.VandeVondele@mat.ethz.ch> 3 4! { dg-do compile } 5! { dg-options "-O3" } 6 7MODULE hfx_contract_block 8 INTEGER, PARAMETER :: dp=8 9CONTAINS 10 SUBROUTINE contract_block(ma_max,mb_max,mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 11 REAL(KIND=dp) :: kbd(mb_max*md_max), kbc(mb_max*mc_max), & 12 kad(ma_max*md_max), kac(ma_max*mc_max), pbd(mb_max*md_max), & 13 pbc(mb_max*mc_max), pad(ma_max*md_max), pac(ma_max*mc_max), & 14 prim(ma_max*mb_max*mc_max*md_max), scale 15 SELECT CASE(ma_max) 16 CASE(1) 17 SELECT CASE(mb_max) 18 CASE(1) 19 SELECT CASE(mc_max) 20 CASE(1) 21 SELECT CASE(md_max) 22 CASE(1) 23 CALL block_1_1_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 24 CALL block_1_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 25 CALL block_1_1_11(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 26 END SELECT 27 END SELECT 28 SELECT CASE(mc_max) 29 CASE(1) 30 SELECT CASE(md_max) 31 CASE(2) 32 CALL block_1_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 33 CALL block_1_2_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 34 CALL block_1_2_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 35 CALL block_1_2_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 36 CALL block_1_2_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 37 CALL block_1_2_1_7(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 38 CALL block_1_2_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 39 CALL block_1_2_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 40 CALL block_1_2_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 41 CALL block_1_2_6_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 42 END SELECT 43 SELECT CASE(md_max) 44 CASE(1) 45 CALL block_1_2_7_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 46 END SELECT 47 END SELECT 48 SELECT CASE(mc_max) 49 CASE(1) 50 SELECT CASE(md_max) 51 CASE(1) 52 CALL block_1_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 53 CALL block_1_3_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 54 CALL block_1_3_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 55 CALL block_1_3_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 56 CALL block_1_3_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 57 CALL block_1_3_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 58 CALL block_1_3_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 59 CALL block_1_3_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 60 CALL block_1_3_2_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 61 END SELECT 62 SELECT CASE(md_max) 63 CASE(1) 64 CALL block_1_3_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 65 CALL block_1_3_3_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 66 END SELECT 67 SELECT CASE(md_max) 68 CASE(1) 69 CALL block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 70 CALL block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 71 END SELECT 72 END SELECT 73 SELECT CASE(mc_max) 74 CASE(1) 75 SELECT CASE(md_max) 76 CASE(1) 77 CALL block_1_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 78 CALL block_1_4_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 79 CALL block_1_4_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 80 END SELECT 81 SELECT CASE(md_max) 82 CASE(1) 83 CALL block_1_4_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 84 CALL block_1_4_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 85 CALL block_1_4_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 86 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 87 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 88 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 89 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 90 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 91 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 92 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 93 CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 94 CALL block_1_4_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 95 CALL block_1_4_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 96 END SELECT 97 SELECT CASE(md_max) 98 CASE(1) 99 CALL block_1_5_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 100 CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 101 CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 102 CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 103 CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 104 CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 105 CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 106 CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 107 END SELECT 108 SELECT CASE(md_max) 109 CASE(1) 110 CALL block_1_6_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 111 CALL block_1_6_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 112 CALL block_1_6_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 113 END SELECT 114 SELECT CASE(md_max) 115 CASE(1) 116 CALL block_1_6_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 117 END SELECT 118 END SELECT 119 SELECT CASE(mc_max) 120 CASE(1) 121 SELECT CASE(md_max) 122 END SELECT 123 END SELECT 124 END SELECT 125 SELECT CASE(mb_max) 126 CASE(1) 127 SELECT CASE(mc_max) 128 CASE(1) 129 SELECT CASE(md_max) 130 CASE(1) 131 CALL block_2_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 132 CALL block_2_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 133 CALL block_2_1_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 134 CALL block_2_1_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 135 CALL block_2_1_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 136 CALL block_2_1_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 137 CALL block_2_1_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 138 END SELECT 139 END SELECT 140 SELECT CASE(mc_max) 141 CASE(1) 142 SELECT CASE(md_max) 143 CASE(1) 144 CALL block_2_2_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 145 CALL block_2_2_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 146 CALL block_2_2_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 147 END SELECT 148 END SELECT 149 SELECT CASE(mc_max) 150 CASE(1) 151 SELECT CASE(md_max) 152 CASE(7) 153 CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 154 CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 155 CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 156 CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 157 CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 158 END SELECT 159 END SELECT 160 SELECT CASE(mc_max) 161 CASE(1) 162 SELECT CASE(md_max) 163 CASE(1) 164 CALL block_3_5_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 165 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 166 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 167 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 168 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 169 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 170 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 171 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 172 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 173 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 174 CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 175 END SELECT 176 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 177 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 178 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 179 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 180 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 181 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 182 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 183 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 184 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 185 CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 186 END SELECT 187 CALL block_3_9(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 188 END SELECT 189 SELECT CASE(mb_max) 190 CASE(1) 191 SELECT CASE(mc_max) 192 CASE(1) 193 SELECT CASE(md_max) 194 CASE(1) 195 CALL block_4_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 196 CALL block_4_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 197 CALL block_4_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 198 CALL block_4_1_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 199 CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 200 CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 201 CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 202 CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 203 CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 204 CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 205 CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 206 END SELECT 207 END SELECT 208 SELECT CASE(mc_max) 209 CASE(1) 210 SELECT CASE(md_max) 211 CASE(1) 212 CALL block_4_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 213 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 214 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 215 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 216 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 217 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 218 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 219 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 220 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 221 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 222 CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 223 END SELECT 224 SELECT CASE(md_max) 225 CASE(1) 226 CALL block_4_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 227 END SELECT 228 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 229 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 230 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 231 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 232 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 233 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 234 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 235 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 236 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 237 CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 238 SELECT CASE(md_max) 239 CASE(1) 240 CALL block_4_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 241 END SELECT 242 END SELECT 243 SELECT CASE(mc_max) 244 CASE(1) 245 SELECT CASE(md_max) 246 END SELECT 247 END SELECT 248 END SELECT 249 SELECT CASE(mb_max) 250 CASE(1) 251 CALL block_15_15(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 252 END SELECT 253 END SELECT 254 END SUBROUTINE contract_block 255 SUBROUTINE block_1_1_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 256 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(1*1), kac(1*1), pbd(1*1), & 257 pbc(1*1), pad(1*1), pac(1*1), prim(1*1*1*1), scale 258 DO md = 1,1 259 DO mc = 1,1 260 DO mb = 1,1 261 DO ma = 1,1 262 kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc 263 END DO 264 END DO 265 END DO 266 END DO 267 END SUBROUTINE block_1_1_1_1 268 SUBROUTINE block_1_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 269 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(1*2), kac(1*1), pbd(1*2), & 270 pbc(1*1), pad(1*2), pac(1*1), prim(1*1*1*2), scale 271 DO md = 1,2 272 DO mc = 1,1 273 DO mb = 1,1 274 DO ma = 1,1 275 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 276 END DO 277 END DO 278 END DO 279 END DO 280 END SUBROUTINE block_1_1_1_2 281 SUBROUTINE block_1_1_11(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 282 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*11), kad(1*md_max), kac(1*11), & 283 pbd(1*md_max), pbc(1*11), pad(1*md_max), pac(1*11), & 284 prim(1*1*11*md_max), scale 285 DO md = 1,md_max 286 DO mc = 1,11 287 DO mb = 1,1 288 kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc 289 END DO 290 END DO 291 END DO 292 END SUBROUTINE block_1_1_11 293 SUBROUTINE block_1_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 294 REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(1*2), kac(1*1), pbd(2*2), & 295 pbc(2*1), pad(1*2), pac(1*1), prim(1*2*1*2), scale 296 DO md = 1,2 297 DO mc = 1,1 298 DO mb = 1,2 299 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 300 END DO 301 END DO 302 END DO 303 END SUBROUTINE block_1_2_1_2 304 SUBROUTINE block_1_2_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 305 REAL(KIND=dp) :: kbd(2*3), kbc(2*1), kad(1*3), kac(1*1), pbd(2*3), & 306 pbc(2*1), pad(1*3), pac(1*1), prim(1*2*1*3), scale 307 DO md = 1,3 308 DO mc = 1,1 309 DO mb = 1,2 310 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 311 END DO 312 END DO 313 END DO 314 END SUBROUTINE block_1_2_1_3 315 SUBROUTINE block_1_2_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 316 REAL(KIND=dp) :: kbd(2*4), kbc(2*1), kad(1*4), kac(1*1), pbd(2*4), & 317 pbc(2*1), pad(1*4), pac(1*1), prim(1*2*1*4), scale 318 DO md = 1,4 319 DO mc = 1,1 320 DO mb = 1,2 321 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 322 END DO 323 END DO 324 END DO 325 END SUBROUTINE block_1_2_1_4 326 SUBROUTINE block_1_2_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 327 REAL(KIND=dp) :: kbd(2*5), kbc(2*1), kad(1*5), kac(1*1), pbd(2*5), & 328 pbc(2*1), pad(1*5), pac(1*1), prim(1*2*1*5), scale 329 DO md = 1,5 330 DO mc = 1,1 331 DO mb = 1,2 332 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 333 END DO 334 END DO 335 END DO 336 END SUBROUTINE block_1_2_1_5 337 SUBROUTINE block_1_2_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 338 REAL(KIND=dp) :: kbd(2*6), kbc(2*1), kad(1*6), kac(1*1), pbd(2*6), & 339 pbc(2*1), pad(1*6), pac(1*1), prim(1*2*1*6), scale 340 DO md = 1,6 341 DO mc = 1,1 342 DO mb = 1,2 343 DO ma = 1,1 344 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 345 END DO 346 END DO 347 END DO 348 END DO 349 END SUBROUTINE block_1_2_1_6 350 SUBROUTINE block_1_2_1_7(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 351 REAL(KIND=dp) :: kbd(2*7), kbc(2*1), kad(1*7), kac(1*1), pbd(2*7), & 352 pbc(2*1), pad(1*7), pac(1*1), prim(1*2*1*7), scale 353 DO md = 1,7 354 DO mc = 1,1 355 DO mb = 1,2 356 DO ma = 1,1 357 kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc 358 END DO 359 END DO 360 END DO 361 END DO 362 END SUBROUTINE block_1_2_1_7 363 SUBROUTINE block_1_2_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 364 REAL(KIND=dp) :: kbd(2*2), kbc(2*2), kad(1*2), kac(1*2), pbd(2*2), & 365 pbc(2*2), pad(1*2), pac(1*2), prim(1*2*2*2), scale 366 DO md = 1,2 367 DO mc = 1,2 368 DO mb = 1,2 369 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 370 END DO 371 END DO 372 END DO 373 END SUBROUTINE block_1_2_2_2 374 SUBROUTINE block_1_2_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 375 REAL(KIND=dp) :: kbd(2*4), kbc(2*2), kad(1*4), kac(1*2), pbd(2*4), & 376 pbc(2*2), pad(1*4), pac(1*2), prim(1*2*2*4), scale 377 DO md = 1,4 378 DO mc = 1,2 379 DO mb = 1,2 380 kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd 381 END DO 382 END DO 383 END DO 384 END SUBROUTINE block_1_2_2_4 385 SUBROUTINE block_1_2_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 386 REAL(KIND=dp) :: kbd(2*1), kbc(2*4), kad(1*1), kac(1*4), pbd(2*1), & 387 pbc(2*4), pad(1*1), pac(1*4), prim(1*2*4*1), scale 388 DO md = 1,1 389 DO mc = 1,4 390 DO mb = 1,2 391 kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd 392 END DO 393 END DO 394 END DO 395 END SUBROUTINE block_1_2_4_1 396 SUBROUTINE block_1_2_6_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 397 REAL(KIND=dp) :: kbd(2*1), kbc(2*6), kad(1*1), kac(1*6), pbd(2*1), & 398 pbc(2*6), pad(1*1), pac(1*6), prim(1*2*6*1), scale 399 DO md = 1,1 400 DO mc = 1,6 401 DO mb = 1,2 402 DO ma = 1,1 403 kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc 404 END DO 405 END DO 406 END DO 407 END DO 408 END SUBROUTINE block_1_2_6_1 409 SUBROUTINE block_1_2_7_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 410 REAL(KIND=dp) :: kbd(2*1), kbc(2*7), kad(1*1), kac(1*7), pbd(2*1), & 411 pbc(2*7), pad(1*1), pac(1*7), prim(1*2*7*1), scale 412 DO md = 1,1 413 DO mc = 1,7 414 DO mb = 1,2 415 DO ma = 1,1 416 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 417 END DO 418 END DO 419 END DO 420 END DO 421 END SUBROUTINE block_1_2_7_1 422 SUBROUTINE block_1_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 423 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(1*1), kac(1*1), pbd(3*1), & 424 pbc(3*1), pad(1*1), pac(1*1), prim(1*3*1*1), scale 425 DO md = 1,1 426 DO mc = 1,1 427 DO mb = 1,3 428 kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc 429 END DO 430 END DO 431 END DO 432 END SUBROUTINE block_1_3_1_1 433 SUBROUTINE block_1_3_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 434 REAL(KIND=dp) :: kbd(3*3), kbc(3*1), kad(1*3), kac(1*1), pbd(3*3), & 435 pbc(3*1), pad(1*3), pac(1*1), prim(1*3*1*3), scale 436 DO md = 1,3 437 DO mc = 1,1 438 DO mb = 1,3 439 DO ma = 1,1 440 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 441 END DO 442 END DO 443 END DO 444 END DO 445 END SUBROUTINE block_1_3_1_3 446 SUBROUTINE block_1_3_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 447 REAL(KIND=dp) :: kbd(3*4), kbc(3*1), kad(1*4), kac(1*1), pbd(3*4), & 448 pbc(3*1), pad(1*4), pac(1*1), prim(1*3*1*4), scale 449 DO md = 1,4 450 DO mc = 1,1 451 DO mb = 1,3 452 kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc 453 END DO 454 END DO 455 END DO 456 END SUBROUTINE block_1_3_1_4 457 SUBROUTINE block_1_3_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 458 REAL(KIND=dp) :: kbd(3*5), kbc(3*1), kad(1*5), kac(1*1), pbd(3*5), & 459 pbc(3*1), pad(1*5), pac(1*1), prim(1*3*1*5), scale 460 DO md = 1,5 461 DO mc = 1,1 462 DO mb = 1,3 463 DO ma = 1,1 464 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 465 END DO 466 END DO 467 END DO 468 END DO 469 END SUBROUTINE block_1_3_1_5 470 SUBROUTINE block_1_3_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 471 REAL(KIND=dp) :: kbd(3*6), kbc(3*1), kad(1*6), kac(1*1), pbd(3*6), & 472 pbc(3*1), pad(1*6), pac(1*1), prim(1*3*1*6), scale 473 DO md = 1,6 474 DO mc = 1,1 475 DO mb = 1,3 476 DO ma = 1,1 477 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 478 END DO 479 END DO 480 END DO 481 END DO 482 END SUBROUTINE block_1_3_1_6 483 SUBROUTINE block_1_3_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 484 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(1*md_max), kac(1*1), & 485 pbd(3*md_max), pbc(3*1), pad(1*md_max), pac(1*1), prim(1*3*1*md_max), & 486 scale 487 DO md = 1,md_max 488 DO mc = 1,1 489 DO mb = 1,3 490 DO ma = 1,1 491 kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc 492 END DO 493 END DO 494 END DO 495 END DO 496 END SUBROUTINE block_1_3_1 497 SUBROUTINE block_1_3_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 498 REAL(KIND=dp) :: kbd(3*1), kbc(3*2), kad(1*1), kac(1*2), pbd(3*1), & 499 pbc(3*2), pad(1*1), pac(1*2), prim(1*3*2*1), scale 500 DO md = 1,1 501 DO mc = 1,2 502 DO mb = 1,3 503 kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc 504 END DO 505 END DO 506 END DO 507 END SUBROUTINE block_1_3_2_1 508 SUBROUTINE block_1_3_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 509 REAL(KIND=dp) :: kbd(3*2), kbc(3*2), kad(1*2), kac(1*2), pbd(3*2), & 510 pbc(3*2), pad(1*2), pac(1*2), prim(1*3*2*2), scale 511 DO md = 1,2 512 DO mc = 1,2 513 DO mb = 1,3 514 DO ma = 1,1 515 kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc 516 END DO 517 END DO 518 END DO 519 END DO 520 END SUBROUTINE block_1_3_2_2 521 SUBROUTINE block_1_3_2_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 522 REAL(KIND=dp) :: kbd(3*3), kbc(3*2), kad(1*3), kac(1*2), pbd(3*3), & 523 pbc(3*2), pad(1*3), pac(1*2), prim(1*3*2*3), scale 524 kbc(1:3*2) = 0.0_dp 525 DO md = 1,3 526 DO mc = 1,2 527 DO mb = 1,3 528 kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc 529 END DO 530 END DO 531 END DO 532 END SUBROUTINE block_1_3_2_3 533 SUBROUTINE block_1_3_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 534 REAL(KIND=dp) :: kbd(3*1), kbc(3*3), kad(1*1), kac(1*3), pbd(3*1), & 535 pbc(3*3), pad(1*1), pac(1*3), prim(1*3*3*1), scale 536 DO md = 1,1 537 DO mc = 1,3 538 DO mb = 1,3 539 kbd((md-1)*3+mb) = kbd((md-1)*3+mb) - ks_bd 540 END DO 541 END DO 542 END DO 543 END SUBROUTINE block_1_3_3_1 544 SUBROUTINE block_1_3_3_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 545 REAL(KIND=dp) :: kbd(3*2), kbc(3*3), kad(1*2), kac(1*3), pbd(3*2), & 546 pbc(3*3), pad(1*2), pac(1*3), prim(1*3*3*2), scale 547 DO md = 1,2 548 DO mc = 1,3 549 DO mb = 1,3 550 kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc 551 END DO 552 END DO 553 END DO 554 END SUBROUTINE block_1_3_3_2 555 SUBROUTINE block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 556 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*5), kad(1*md_max), kac(1*5), & 557 pbd(3*md_max), pbc(3*5), pad(1*md_max), pac(1*5), prim(1*3*5*md_max), & 558 scale 559 kbd(1:3*md_max) = 0.0_dp 560 DO md = 1,md_max 561 END DO 562 END SUBROUTINE block_1_3_5 563 SUBROUTINE block_1_3_6(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 564 DO md = 1,md_max 565 END DO 566 END SUBROUTINE block_1_3_6 567 SUBROUTINE block_1_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 568 REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(1*1), kac(1*1), pbd(4*1), & 569 pbc(4*1), pad(1*1), pac(1*1), prim(1*4*1*1), scale 570 DO md = 1,1 571 DO mc = 1,1 572 DO mb = 1,4 573 DO ma = 1,1 574 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 575 END DO 576 END DO 577 END DO 578 END DO 579 END SUBROUTINE block_1_4_1_1 580 SUBROUTINE block_1_4_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 581 REAL(KIND=dp) :: kbd(4*2), kbc(4*1), kad(1*2), kac(1*1), pbd(4*2), & 582 pbc(4*1), pad(1*2), pac(1*1), prim(1*4*1*2), scale 583 DO md = 1,2 584 DO mc = 1,1 585 DO mb = 1,4 586 kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc 587 END DO 588 END DO 589 END DO 590 END SUBROUTINE block_1_4_1_2 591 SUBROUTINE block_1_4_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 592 REAL(KIND=dp) :: kbd(4*3), kbc(4*1), kad(1*3), kac(1*1), pbd(4*3), & 593 pbc(4*1), pad(1*3), pac(1*1), prim(1*4*1*3), scale 594 DO md = 1,3 595 DO mc = 1,1 596 DO mb = 1,4 597 kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc 598 END DO 599 END DO 600 END DO 601 END SUBROUTINE block_1_4_1_3 602 SUBROUTINE block_1_4_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 603 REAL(KIND=dp) :: kbd(4*1), kbc(4*2), kad(1*1), kac(1*2), pbd(4*1), & 604 pbc(4*2), pad(1*1), pac(1*2), prim(1*4*2*1), scale 605 DO md = 1,1 606 DO mc = 1,2 607 DO mb = 1,4 608 kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc 609 END DO 610 END DO 611 END DO 612 END SUBROUTINE block_1_4_2_1 613 SUBROUTINE block_1_4_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 614 REAL(KIND=dp) :: kbd(4*2), kbc(4*2), kad(1*2), kac(1*2), pbd(4*2), & 615 pbc(4*2), pad(1*2), pac(1*2), prim(1*4*2*2), scale 616 DO md = 1,2 617 DO mc = 1,2 618 DO mb = 1,4 619 DO ma = 1,1 620 kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc 621 END DO 622 END DO 623 END DO 624 END DO 625 END SUBROUTINE block_1_4_2_2 626 SUBROUTINE block_1_4_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 627 REAL(KIND=dp) :: kbd(4*1), kbc(4*3), kad(1*1), kac(1*3), pbd(4*1), & 628 pbc(4*3), pad(1*1), pac(1*3), prim(1*4*3*1), scale 629 DO md = 1,1 630 DO mc = 1,3 631 DO mb = 1,4 632 kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc 633 END DO 634 END DO 635 END DO 636 END SUBROUTINE block_1_4_3_1 637 SUBROUTINE block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 638 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*3), kad(1*md_max), kac(1*3), & 639 pbd(4*md_max), pbc(4*3), pad(1*md_max), pac(1*3), prim(1*4*3*md_max), & 640 scale 641 DO md = 1,md_max 642 DO mc = 1,3 643 DO mb = 1,4 644 kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc 645 END DO 646 END DO 647 END DO 648 END SUBROUTINE block_1_4_3 649 SUBROUTINE block_1_4_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 650 REAL(KIND=dp) :: kbd(4*1), kbc(4*4), kad(1*1), kac(1*4), pbd(4*1), & 651 pbc(4*4), pad(1*1), pac(1*4), prim(1*4*4*1), scale 652 DO md = 1,1 653 DO mc = 1,4 654 DO mb = 1,4 655 kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc 656 END DO 657 END DO 658 END DO 659 END SUBROUTINE block_1_4_4_1 660 SUBROUTINE block_1_4_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 661 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*4), kad(1*md_max), kac(1*4), & 662 pbd(4*md_max), pbc(4*4), pad(1*md_max), pac(1*4), prim(1*4*4*md_max), & 663 scale 664 DO md = 1,md_max 665 DO mc = 1,4 666 DO mb = 1,4 667 DO ma = 1,1 668 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 669 END DO 670 END DO 671 END DO 672 END DO 673 END SUBROUTINE block_1_4_4 674 SUBROUTINE block_1_5_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 675 REAL(KIND=dp) :: kbd(5*3), kbc(5*1), kad(1*3), kac(1*1), pbd(5*3), & 676 pbc(5*1), pad(1*3), pac(1*1), prim(1*5*1*3), scale 677 DO md = 1,3 678 DO mc = 1,1 679 DO mb = 1,5 680 DO ma = 1,1 681 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 682 END DO 683 END DO 684 END DO 685 END DO 686 END SUBROUTINE block_1_5_1_3 687 SUBROUTINE block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 688 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(1*md_max), kac(1*1), & 689 pbd(5*md_max), pbc(5*1), pad(1*md_max), pac(1*1), prim(1*5*1*md_max), & 690 scale 691 DO md = 1,md_max 692 DO mc = 1,1 693 DO mb = 1,5 694 kbc((mc-1)*5+mb) = kbc((mc-1)*5+mb) - ks_bc 695 END DO 696 END DO 697 END DO 698 END SUBROUTINE block_1_5_1 699 SUBROUTINE block_1_6_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 700 REAL(KIND=dp) :: kbd(6*1), kbc(6*1), kad(1*1), kac(1*1), pbd(6*1), & 701 pbc(6*1), pad(1*1), pac(1*1), prim(1*6*1*1), scale 702 DO md = 1,1 703 DO mc = 1,1 704 DO mb = 1,6 705 DO ma = 1,1 706 kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd 707 END DO 708 END DO 709 END DO 710 END DO 711 END SUBROUTINE block_1_6_1_1 712 SUBROUTINE block_1_6_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 713 REAL(KIND=dp) :: kbd(6*2), kbc(6*1), kad(1*2), kac(1*1), pbd(6*2), & 714 pbc(6*1), pad(1*2), pac(1*1), prim(1*6*1*2), scale 715 DO md = 1,2 716 DO mc = 1,1 717 DO mb = 1,6 718 DO ma = 1,1 719 kad((md-1)*1+ma) = kad((md-1)*1+ma)-tmp*p_bc 720 END DO 721 END DO 722 END DO 723 END DO 724 END SUBROUTINE block_1_6_1_2 725 SUBROUTINE block_1_6_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 726 REAL(KIND=dp) :: kbd(6*3), kbc(6*1), kad(1*3), kac(1*1), pbd(6*3), & 727 pbc(6*1), pad(1*3), pac(1*1), prim(1*6*1*3), scale 728 DO md = 1,3 729 DO mc = 1,1 730 DO mb = 1,6 731 kbc((mc-1)*6+mb) = kbc((mc-1)*6+mb) - ks_bc 732 END DO 733 END DO 734 END DO 735 END SUBROUTINE block_1_6_1_3 736 SUBROUTINE block_1_6_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 737 REAL(KIND=dp) :: kbd(6*1), kbc(6*2), kad(1*1), kac(1*2), pbd(6*1), & 738 pbc(6*2), pad(1*1), pac(1*2), prim(1*6*2*1), scale 739 DO md = 1,1 740 DO mc = 1,2 741 DO mb = 1,6 742 kbc((mc-1)*6+mb) = kbc((mc-1)*6+mb) - ks_bc 743 END DO 744 END DO 745 END DO 746 END SUBROUTINE block_1_6_2_1 747 SUBROUTINE block_2_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 748 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(2*3), kac(2*1), pbd(1*3), & 749 pbc(1*1), pad(2*3), pac(2*1), prim(2*1*1*3), scale 750 DO md = 1,3 751 DO mc = 1,1 752 DO mb = 1,1 753 DO ma = 1,2 754 kac((mc-1)*2+ma) = kac((mc-1)*2+ma)-tmp*p_bd 755 END DO 756 END DO 757 END DO 758 END DO 759 END SUBROUTINE block_2_1_1_3 760 SUBROUTINE block_2_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 761 REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(2*4), kac(2*1), pbd(1*4), & 762 pbc(1*1), pad(2*4), pac(2*1), prim(2*1*1*4), scale 763 DO md = 1,4 764 DO mc = 1,1 765 DO mb = 1,1 766 kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc 767 END DO 768 END DO 769 END DO 770 END SUBROUTINE block_2_1_1_4 771 SUBROUTINE block_2_1_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 772 REAL(KIND=dp) :: kbd(1*5), kbc(1*1), kad(2*5), kac(2*1), pbd(1*5), & 773 pbc(1*1), pad(2*5), pac(2*1), prim(2*1*1*5), scale 774 DO md = 1,5 775 DO mc = 1,1 776 DO mb = 1,1 777 kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc 778 END DO 779 END DO 780 END DO 781 END SUBROUTINE block_2_1_1_5 782 SUBROUTINE block_2_1_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 783 REAL(KIND=dp) :: kbd(1*6), kbc(1*1), kad(2*6), kac(2*1), pbd(1*6), & 784 pbc(1*1), pad(2*6), pac(2*1), prim(2*1*1*6), scale 785 DO md = 1,6 786 DO mc = 1,1 787 DO mb = 1,1 788 DO ma = 1,2 789 kad((md-1)*2+ma) = kad((md-1)*2+ma)-tmp*p_bc 790 END DO 791 END DO 792 END DO 793 END DO 794 END SUBROUTINE block_2_1_1_6 795 SUBROUTINE block_2_1_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 796 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(2*1), kac(2*2), pbd(1*1), & 797 pbc(1*2), pad(2*1), pac(2*2), prim(2*1*2*1), scale 798 DO md = 1,1 799 DO mc = 1,2 800 DO mb = 1,1 801 DO ma = 1,2 802 kac((mc-1)*2+ma) = kac((mc-1)*2+ma)-tmp*p_bd 803 END DO 804 END DO 805 END DO 806 END DO 807 END SUBROUTINE block_2_1_2_1 808 SUBROUTINE block_2_1_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 809 REAL(KIND=dp) :: kbd(1*2), kbc(1*2), kad(2*2), kac(2*2), pbd(1*2), & 810 pbc(1*2), pad(2*2), pac(2*2), prim(2*1*2*2), scale 811 DO md = 1,2 812 DO mc = 1,2 813 DO mb = 1,1 814 kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc 815 END DO 816 END DO 817 END DO 818 END SUBROUTINE block_2_1_2_2 819 SUBROUTINE block_2_1_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 820 REAL(KIND=dp) :: kbd(1*4), kbc(1*2), kad(2*4), kac(2*2), pbd(1*4), & 821 pbc(1*2), pad(2*4), pac(2*2), prim(2*1*2*4), scale 822 DO md = 1,4 823 DO mc = 1,2 824 DO mb = 1,1 825 kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc 826 END DO 827 END DO 828 END DO 829 END SUBROUTINE block_2_1_2_4 830 SUBROUTINE block_2_2_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 831 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(2*1), kac(2*1), pbd(2*1), & 832 pbc(2*1), pad(2*1), pac(2*1), prim(2*2*1*1), scale 833 DO md = 1,1 834 DO mc = 1,1 835 DO mb = 1,2 836 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 837 END DO 838 END DO 839 END DO 840 END SUBROUTINE block_2_2_1_1 841 SUBROUTINE block_2_2_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 842 REAL(KIND=dp) :: kbd(2*1), kbc(2*2), kad(2*1), kac(2*2), pbd(2*1), & 843 pbc(2*2), pad(2*1), pac(2*2), prim(2*2*2*1), scale 844 DO md = 1,1 845 DO mc = 1,2 846 DO mb = 1,2 847 kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd 848 END DO 849 END DO 850 END DO 851 END SUBROUTINE block_2_2_2_1 852 SUBROUTINE block_2_2_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 853 REAL(KIND=dp) :: kbd(2*1), kbc(2*3), kad(2*1), kac(2*3), pbd(2*1), & 854 pbc(2*3), pad(2*1), pac(2*3), prim(2*2*3*1), scale 855 DO md = 1,1 856 DO mc = 1,3 857 DO mb = 1,2 858 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 859 END DO 860 END DO 861 END DO 862 END SUBROUTINE block_2_2_3_1 863 SUBROUTINE block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 864 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(3*md_max), kac(3*1), & 865 pbd(2*md_max), pbc(2*1), pad(3*md_max), pac(3*1), prim(3*2*1*md_max), & 866 scale 867 DO md = 1,md_max 868 DO mc = 1,1 869 DO mb = 1,2 870 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 871 END DO 872 END DO 873 END DO 874 END SUBROUTINE block_3_2_1 875 SUBROUTINE block_3_5_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 876 REAL(KIND=dp) :: kbd(5*1), kbc(5*1), kad(3*1), kac(3*1), pbd(5*1), & 877 pbc(5*1), pad(3*1), pac(3*1), prim(3*5*1*1), scale 878 DO md = 1,1 879 DO mc = 1,1 880 DO mb = 1,5 881 DO ma = 1,3 882 kad((md-1)*3+ma) = kad((md-1)*3+ma)-tmp*p_bc 883 END DO 884 END DO 885 END DO 886 END DO 887 END SUBROUTINE block_3_5_1_1 888 SUBROUTINE block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 889 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(3*md_max), kac(3*1), & 890 pbd(5*md_max), pbc(5*1), pad(3*md_max), pac(3*1), prim(3*5*1*md_max), & 891 scale 892 DO md = 1,md_max 893 DO mc = 1,1 894 DO mb = 1,5 895 kbc((mc-1)*5+mb) = kbc((mc-1)*5+mb) - ks_bc 896 END DO 897 END DO 898 END DO 899 END SUBROUTINE block_3_5_1 900 SUBROUTINE block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 901 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(3*md_max), & 902 kac(3*mc_max), pbd(6*md_max), pbc(6*mc_max), pad(3*md_max), & 903 pac(3*mc_max), prim(3*6*mc_max*md_max), scale 904 kbd(1:6*md_max) = 0.0_dp 905 END SUBROUTINE block_3_6 906 SUBROUTINE block_3_9(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 907 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(3*md_max), & 908 kac(3*mc_max), pbd(9*md_max), pbc(9*mc_max), pad(3*md_max), & 909 pac(3*mc_max), prim(3*9*mc_max*md_max), scale 910 DO md = 1,md_max 911 DO mc = 1,mc_max 912 DO mb = 1,9 913 DO ma = 1,3 914 kac((mc-1)*3+ma) = kac((mc-1)*3+ma)-tmp*p_bd 915 END DO 916 END DO 917 END DO 918 END DO 919 END SUBROUTINE block_3_9 920 SUBROUTINE block_4_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 921 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(4*2), kac(4*1), pbd(1*2), & 922 pbc(1*1), pad(4*2), pac(4*1), prim(4*1*1*2), scale 923 DO md = 1,2 924 DO mc = 1,1 925 DO mb = 1,1 926 DO ma = 1,4 927 kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd 928 END DO 929 END DO 930 END DO 931 END DO 932 END SUBROUTINE block_4_1_1_2 933 SUBROUTINE block_4_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 934 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(4*3), kac(4*1), pbd(1*3), & 935 pbc(1*1), pad(4*3), pac(4*1), prim(4*1*1*3), scale 936 DO md = 1,3 937 DO mc = 1,1 938 DO mb = 1,1 939 kbd((md-1)*1+mb) = kbd((md-1)*1+mb) - ks_bd 940 END DO 941 END DO 942 END DO 943 END SUBROUTINE block_4_1_1_3 944 SUBROUTINE block_4_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 945 REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(4*4), kac(4*1), pbd(1*4), & 946 pbc(1*1), pad(4*4), pac(4*1), prim(4*1*1*4), scale 947 DO md = 1,4 948 DO mc = 1,1 949 DO mb = 1,1 950 kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc 951 END DO 952 END DO 953 END DO 954 END SUBROUTINE block_4_1_1_4 955 SUBROUTINE block_4_1_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 956 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(4*md_max), kac(4*1), & 957 pbd(1*md_max), pbc(1*1), pad(4*md_max), pac(4*1), prim(4*1*1*md_max), & 958 scale 959 DO md = 1,md_max 960 DO mc = 1,1 961 DO mb = 1,1 962 kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc 963 END DO 964 END DO 965 END DO 966 END SUBROUTINE block_4_1_1 967 SUBROUTINE block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 968 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*4), kad(4*md_max), kac(4*4), & 969 pbd(1*md_max), pbc(1*4), pad(4*md_max), pac(4*4), prim(4*1*4*md_max), & 970 scale 971 kbd(1:1*md_max) = 0.0_dp 972 END SUBROUTINE block_4_1_4 973 SUBROUTINE block_4_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 974 REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(4*2), kac(4*1), pbd(2*2), & 975 pbc(2*1), pad(4*2), pac(4*1), prim(4*2*1*2), scale 976 DO md = 1,2 977 DO mc = 1,1 978 DO mb = 1,2 979 DO ma = 1,4 980 kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd 981 END DO 982 END DO 983 END DO 984 END DO 985 END SUBROUTINE block_4_2_1_2 986 SUBROUTINE block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 987 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*2), kad(4*md_max), kac(4*2), & 988 pbd(2*md_max), pbc(2*2), pad(4*md_max), pac(4*2), prim(4*2*2*md_max), & 989 scale 990 DO md = 1,md_max 991 DO mc = 1,2 992 DO mb = 1,2 993 kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc 994 END DO 995 END DO 996 END DO 997 END SUBROUTINE block_4_2_2 998 SUBROUTINE block_4_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 999 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(4*1), kac(4*1), pbd(3*1), & 1000 pbc(3*1), pad(4*1), pac(4*1), prim(4*3*1*1), scale 1001 DO md = 1,1 1002 DO mc = 1,1 1003 DO mb = 1,3 1004 DO ma = 1,4 1005 kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd 1006 END DO 1007 END DO 1008 END DO 1009 END DO 1010 END SUBROUTINE block_4_3_1_1 1011 SUBROUTINE block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 1012 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(4*md_max), & 1013 kac(4*mc_max), pbd(3*md_max), pbc(3*mc_max), pad(4*md_max), & 1014 pac(4*mc_max), prim(4*3*mc_max*md_max), scale 1015 DO md = 1,md_max 1016 DO mc = 1,mc_max 1017 DO mb = 1,3 1018 kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc 1019 END DO 1020 END DO 1021 END DO 1022 END SUBROUTINE block_4_3 1023 SUBROUTINE block_4_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 1024 REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(4*1), kac(4*1), pbd(4*1), & 1025 pbc(4*1), pad(4*1), pac(4*1), prim(4*4*1*1), scale 1026 DO md = 1,1 1027 DO mc = 1,1 1028 DO mb = 1,4 1029 DO ma = 1,4 1030 kad((md-1)*4+ma) = kad((md-1)*4+ma)-tmp*p_bc 1031 END DO 1032 END DO 1033 END DO 1034 END DO 1035 END SUBROUTINE block_4_4_1_1 1036 SUBROUTINE block_15_15(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale) 1037 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(15*md_max), & 1038 kac(15*mc_max), pbd(15*md_max), pbc(15*mc_max), pad(15*md_max), & 1039 pac(15*mc_max), prim(15*15*mc_max*md_max), scale 1040 DO md = 1,md_max 1041 DO mc = 1,mc_max 1042 DO mb = 1,15 1043 kbc((mc-1)*15+mb) = kbc((mc-1)*15+mb) - ks_bc 1044 END DO 1045 END DO 1046 END DO 1047 END SUBROUTINE block_15_15 1048END MODULE hfx_contract_block 1049