1!--------------------------------------------------------------------------------------------------! 2! CP2K: A general program to perform molecular dynamics simulations ! 3! Copyright (C) 2000 - 2019 CP2K developers group ! 4!--------------------------------------------------------------------------------------------------! 5! ************************************************************************************************** 6!> \brief routines to contract density matrix blocks with the for center 7!> integrals to yield the Kohn-Sham matrix. The specialized routines 8!> are about 1.2-2.0 as fast as the default one. 9!> \par History 10!> 10.2009 created [Joost VandeVondele] 11!> \author Joost VandeVondele 12! ************************************************************************************************** 13MODULE hfx_contract_block 14 USE kinds, ONLY: dp 15#include "../base/base_uses.f90" 16 17 IMPLICIT NONE 18 PRIVATE 19 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'hfx_contract_block' 20 PUBLIC :: contract_block 21CONTAINS 22! ************************************************************************************************** 23!> \brief ... 24!> \param ma_max ... 25!> \param mb_max ... 26!> \param mc_max ... 27!> \param md_max ... 28!> \param kbd ... 29!> \param kbc ... 30!> \param kad ... 31!> \param kac ... 32!> \param pbd ... 33!> \param pbc ... 34!> \param pad ... 35!> \param pac ... 36!> \param prim ... 37!> \param scale ... 38! ************************************************************************************************** 39 SUBROUTINE contract_block(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 40 INTEGER :: ma_max, mb_max, mc_max, md_max 41 REAL(KIND=dp) :: kbd(mb_max*md_max), kbc(mb_max*mc_max), & 42 kad(ma_max*md_max), kac(ma_max*mc_max), pbd(mb_max*md_max), & 43 pbc(mb_max*mc_max), pad(ma_max*md_max), pac(ma_max*mc_max), & 44 prim(ma_max*mb_max*mc_max*md_max), scale 45 46#if !defined (__LIBINT) 47 MARK_USED(ma_max) 48 MARK_USED(mb_max) 49 MARK_USED(mc_max) 50 MARK_USED(md_max) 51 MARK_USED(kbd) 52 MARK_USED(kbc) 53 MARK_USED(kad) 54 MARK_USED(kac) 55 MARK_USED(pbd) 56 MARK_USED(pbc) 57 MARK_USED(pad) 58 MARK_USED(pac) 59 MARK_USED(prim) 60 MARK_USED(scale) 61 CPABORT("libint not compiled in") 62#else 63 SELECT CASE (ma_max) 64 CASE (1) 65 SELECT CASE (mb_max) 66 CASE (1) 67 SELECT CASE (mc_max) 68 CASE (1) 69 SELECT CASE (md_max) 70 CASE (1) 71 CALL block_1_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 72 CASE (2) 73 CALL block_1_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 74 CASE (3) 75 CALL block_1_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 76 CASE (4) 77 CALL block_1_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 78 CASE (5) 79 CALL block_1_1_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 80 CASE (6) 81 CALL block_1_1_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 82 CASE (7) 83 CALL block_1_1_1_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 84 CASE (9) 85 CALL block_1_1_1_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 86 CASE (10) 87 CALL block_1_1_1_10(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 88 CASE (11) 89 CALL block_1_1_1_11(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 90 CASE (15) 91 CALL block_1_1_1_15(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 92 CASE DEFAULT 93 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 94 END SELECT 95 CASE (2) 96 SELECT CASE (md_max) 97 CASE (1) 98 CALL block_1_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 99 CASE (2) 100 CALL block_1_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 101 CASE (3) 102 CALL block_1_1_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 103 CASE (4) 104 CALL block_1_1_2_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 105 CASE (5) 106 CALL block_1_1_2_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 107 CASE (6) 108 CALL block_1_1_2_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 109 CASE (7) 110 CALL block_1_1_2_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 111 CASE (9) 112 CALL block_1_1_2_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 113 CASE (10) 114 CALL block_1_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 115 CASE (11) 116 CALL block_1_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 117 CASE (15) 118 CALL block_1_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 119 CASE DEFAULT 120 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 121 END SELECT 122 CASE (3) 123 SELECT CASE (md_max) 124 CASE (1) 125 CALL block_1_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 126 CASE (2) 127 CALL block_1_1_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 128 CASE (3) 129 CALL block_1_1_3_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 130 CASE (4) 131 CALL block_1_1_3_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 132 CASE (5) 133 CALL block_1_1_3_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 134 CASE (6) 135 CALL block_1_1_3_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 136 CASE (7) 137 CALL block_1_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 138 CASE (9) 139 CALL block_1_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 140 CASE (10) 141 CALL block_1_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 142 CASE (11) 143 CALL block_1_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 144 CASE (15) 145 CALL block_1_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 146 CASE DEFAULT 147 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 148 END SELECT 149 CASE (4) 150 SELECT CASE (md_max) 151 CASE (1) 152 CALL block_1_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 153 CASE (2) 154 CALL block_1_1_4_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 155 CASE (3) 156 CALL block_1_1_4_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 157 CASE (4) 158 CALL block_1_1_4_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 159 CASE (5) 160 CALL block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 161 CASE (6) 162 CALL block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 163 CASE (7) 164 CALL block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 165 CASE (9) 166 CALL block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 167 CASE (10) 168 CALL block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 169 CASE (11) 170 CALL block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 171 CASE (15) 172 CALL block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 173 CASE DEFAULT 174 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 175 END SELECT 176 CASE (5) 177 SELECT CASE (md_max) 178 CASE (1) 179 CALL block_1_1_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 180 CASE (2) 181 CALL block_1_1_5_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 182 CASE (3) 183 CALL block_1_1_5_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 184 CASE (4) 185 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 186 CASE (5) 187 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 188 CASE (6) 189 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 190 CASE (7) 191 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 192 CASE (9) 193 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 194 CASE (10) 195 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 196 CASE (11) 197 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 198 CASE (15) 199 CALL block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 200 CASE DEFAULT 201 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 202 END SELECT 203 CASE (6) 204 SELECT CASE (md_max) 205 CASE (1) 206 CALL block_1_1_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 207 CASE (2) 208 CALL block_1_1_6_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 209 CASE (3) 210 CALL block_1_1_6_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 211 CASE (4) 212 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 213 CASE (5) 214 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 215 CASE (6) 216 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 217 CASE (7) 218 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 219 CASE (9) 220 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 221 CASE (10) 222 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 223 CASE (11) 224 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 225 CASE (15) 226 CALL block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 227 CASE DEFAULT 228 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 229 END SELECT 230 CASE (7) 231 SELECT CASE (md_max) 232 CASE (1) 233 CALL block_1_1_7_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 234 CASE (2) 235 CALL block_1_1_7_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 236 CASE (3) 237 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 238 CASE (4) 239 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 240 CASE (5) 241 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 242 CASE (6) 243 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 244 CASE (7) 245 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 246 CASE (9) 247 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 248 CASE (10) 249 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 250 CASE (11) 251 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 252 CASE (15) 253 CALL block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 254 CASE DEFAULT 255 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 256 END SELECT 257 CASE (9) 258 SELECT CASE (md_max) 259 CASE (1) 260 CALL block_1_1_9_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 261 CASE (2) 262 CALL block_1_1_9_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 263 CASE (3) 264 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 265 CASE (4) 266 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 267 CASE (5) 268 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 269 CASE (6) 270 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 271 CASE (7) 272 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 273 CASE (9) 274 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 275 CASE (10) 276 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 277 CASE (11) 278 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 279 CASE (15) 280 CALL block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 281 CASE DEFAULT 282 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 283 END SELECT 284 CASE (10) 285 SELECT CASE (md_max) 286 CASE (1) 287 CALL block_1_1_10_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 288 CASE (2) 289 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 290 CASE (3) 291 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 292 CASE (4) 293 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 294 CASE (5) 295 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 296 CASE (6) 297 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 298 CASE (7) 299 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 300 CASE (9) 301 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 302 CASE (10) 303 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 304 CASE (11) 305 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 306 CASE (15) 307 CALL block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 308 CASE DEFAULT 309 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 310 END SELECT 311 CASE (11) 312 SELECT CASE (md_max) 313 CASE (1) 314 CALL block_1_1_11_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 315 CASE (2) 316 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 317 CASE (3) 318 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 319 CASE (4) 320 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 321 CASE (5) 322 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 323 CASE (6) 324 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 325 CASE (7) 326 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 327 CASE (9) 328 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 329 CASE (10) 330 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 331 CASE (11) 332 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 333 CASE (15) 334 CALL block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 335 CASE DEFAULT 336 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 337 END SELECT 338 CASE (15) 339 SELECT CASE (md_max) 340 CASE (1) 341 CALL block_1_1_15_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 342 CASE (2) 343 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 344 CASE (3) 345 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 346 CASE (4) 347 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 348 CASE (5) 349 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 350 CASE (6) 351 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 352 CASE (7) 353 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 354 CASE (9) 355 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 356 CASE (10) 357 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 358 CASE (11) 359 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 360 CASE (15) 361 CALL block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 362 CASE DEFAULT 363 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 364 END SELECT 365 CASE DEFAULT 366 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 367 END SELECT 368 CASE (2) 369 SELECT CASE (mc_max) 370 CASE (1) 371 SELECT CASE (md_max) 372 CASE (1) 373 CALL block_1_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 374 CASE (2) 375 CALL block_1_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 376 CASE (3) 377 CALL block_1_2_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 378 CASE (4) 379 CALL block_1_2_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 380 CASE (5) 381 CALL block_1_2_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 382 CASE (6) 383 CALL block_1_2_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 384 CASE (7) 385 CALL block_1_2_1_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 386 CASE (9) 387 CALL block_1_2_1_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 388 CASE (10) 389 CALL block_1_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 390 CASE (11) 391 CALL block_1_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 392 CASE (15) 393 CALL block_1_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 394 CASE DEFAULT 395 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 396 END SELECT 397 CASE (2) 398 SELECT CASE (md_max) 399 CASE (1) 400 CALL block_1_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 401 CASE (2) 402 CALL block_1_2_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 403 CASE (3) 404 CALL block_1_2_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 405 CASE (4) 406 CALL block_1_2_2_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 407 CASE (5) 408 CALL block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 409 CASE (6) 410 CALL block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 411 CASE (7) 412 CALL block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 413 CASE (9) 414 CALL block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 415 CASE (10) 416 CALL block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 417 CASE (11) 418 CALL block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 419 CASE (15) 420 CALL block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 421 CASE DEFAULT 422 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 423 END SELECT 424 CASE (3) 425 SELECT CASE (md_max) 426 CASE (1) 427 CALL block_1_2_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 428 CASE (2) 429 CALL block_1_2_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 430 CASE (3) 431 CALL block_1_2_3_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 432 CASE (4) 433 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 434 CASE (5) 435 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 436 CASE (6) 437 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 438 CASE (7) 439 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 440 CASE (9) 441 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 442 CASE (10) 443 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 444 CASE (11) 445 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 446 CASE (15) 447 CALL block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 448 CASE DEFAULT 449 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 450 END SELECT 451 CASE (4) 452 SELECT CASE (md_max) 453 CASE (1) 454 CALL block_1_2_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 455 CASE (2) 456 CALL block_1_2_4_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 457 CASE (3) 458 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 459 CASE (4) 460 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 461 CASE (5) 462 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 463 CASE (6) 464 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 465 CASE (7) 466 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 467 CASE (9) 468 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 469 CASE (10) 470 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 471 CASE (11) 472 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 473 CASE (15) 474 CALL block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 475 CASE DEFAULT 476 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 477 END SELECT 478 CASE (5) 479 SELECT CASE (md_max) 480 CASE (1) 481 CALL block_1_2_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 482 CASE (2) 483 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 484 CASE (3) 485 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 486 CASE (4) 487 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 488 CASE (5) 489 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 490 CASE (6) 491 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 492 CASE (7) 493 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 494 CASE (9) 495 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 496 CASE (10) 497 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 498 CASE (11) 499 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 500 CASE (15) 501 CALL block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 502 CASE DEFAULT 503 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 504 END SELECT 505 CASE (6) 506 SELECT CASE (md_max) 507 CASE (1) 508 CALL block_1_2_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 509 CASE (2) 510 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 511 CASE (3) 512 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 513 CASE (4) 514 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 515 CASE (5) 516 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 517 CASE (6) 518 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 519 CASE (7) 520 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 521 CASE (9) 522 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 523 CASE (10) 524 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 525 CASE (11) 526 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 527 CASE (15) 528 CALL block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 529 CASE DEFAULT 530 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 531 END SELECT 532 CASE (7) 533 SELECT CASE (md_max) 534 CASE (1) 535 CALL block_1_2_7_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 536 CASE (2) 537 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 538 CASE (3) 539 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 540 CASE (4) 541 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 542 CASE (5) 543 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 544 CASE (6) 545 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 546 CASE (7) 547 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 548 CASE (9) 549 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 550 CASE (10) 551 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 552 CASE (11) 553 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 554 CASE (15) 555 CALL block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 556 CASE DEFAULT 557 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 558 END SELECT 559 CASE (9) 560 SELECT CASE (md_max) 561 CASE (1) 562 CALL block_1_2_9_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 563 CASE (2) 564 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 565 CASE (3) 566 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 567 CASE (4) 568 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 569 CASE (5) 570 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 571 CASE (6) 572 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 573 CASE (7) 574 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 575 CASE (9) 576 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 577 CASE (10) 578 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 579 CASE (11) 580 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 581 CASE (15) 582 CALL block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 583 CASE DEFAULT 584 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 585 END SELECT 586 CASE (10) 587 CALL block_1_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 588 CASE (11) 589 CALL block_1_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 590 CASE (15) 591 CALL block_1_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 592 CASE DEFAULT 593 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 594 END SELECT 595 CASE (3) 596 SELECT CASE (mc_max) 597 CASE (1) 598 SELECT CASE (md_max) 599 CASE (1) 600 CALL block_1_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 601 CASE (2) 602 CALL block_1_3_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 603 CASE (3) 604 CALL block_1_3_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 605 CASE (4) 606 CALL block_1_3_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 607 CASE (5) 608 CALL block_1_3_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 609 CASE (6) 610 CALL block_1_3_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 611 CASE (7) 612 CALL block_1_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 613 CASE (9) 614 CALL block_1_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 615 CASE (10) 616 CALL block_1_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 617 CASE (11) 618 CALL block_1_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 619 CASE (15) 620 CALL block_1_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 621 CASE DEFAULT 622 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 623 END SELECT 624 CASE (2) 625 SELECT CASE (md_max) 626 CASE (1) 627 CALL block_1_3_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 628 CASE (2) 629 CALL block_1_3_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 630 CASE (3) 631 CALL block_1_3_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 632 CASE (4) 633 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 634 CASE (5) 635 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 636 CASE (6) 637 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 638 CASE (7) 639 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 640 CASE (9) 641 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 642 CASE (10) 643 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 644 CASE (11) 645 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 646 CASE (15) 647 CALL block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 648 CASE DEFAULT 649 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 650 END SELECT 651 CASE (3) 652 SELECT CASE (md_max) 653 CASE (1) 654 CALL block_1_3_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 655 CASE (2) 656 CALL block_1_3_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 657 CASE (3) 658 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 659 CASE (4) 660 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 661 CASE (5) 662 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 663 CASE (6) 664 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 665 CASE (7) 666 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 667 CASE (9) 668 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 669 CASE (10) 670 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 671 CASE (11) 672 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 673 CASE (15) 674 CALL block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 675 CASE DEFAULT 676 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 677 END SELECT 678 CASE (4) 679 SELECT CASE (md_max) 680 CASE (1) 681 CALL block_1_3_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 682 CASE (2) 683 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 684 CASE (3) 685 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 686 CASE (4) 687 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 688 CASE (5) 689 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 690 CASE (6) 691 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 692 CASE (7) 693 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 694 CASE (9) 695 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 696 CASE (10) 697 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 698 CASE (11) 699 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 700 CASE (15) 701 CALL block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 702 CASE DEFAULT 703 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 704 END SELECT 705 CASE (5) 706 SELECT CASE (md_max) 707 CASE (1) 708 CALL block_1_3_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 709 CASE (2) 710 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 711 CASE (3) 712 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 713 CASE (4) 714 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 715 CASE (5) 716 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 717 CASE (6) 718 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 719 CASE (7) 720 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 721 CASE (9) 722 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 723 CASE (10) 724 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 725 CASE (11) 726 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 727 CASE (15) 728 CALL block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 729 CASE DEFAULT 730 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 731 END SELECT 732 CASE (6) 733 SELECT CASE (md_max) 734 CASE (1) 735 CALL block_1_3_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 736 CASE (2) 737 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 738 CASE (3) 739 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 740 CASE (4) 741 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 742 CASE (5) 743 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 744 CASE (6) 745 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 746 CASE (7) 747 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 748 CASE (9) 749 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 750 CASE (10) 751 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 752 CASE (11) 753 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 754 CASE (15) 755 CALL block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 756 CASE DEFAULT 757 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 758 END SELECT 759 CASE (7) 760 CALL block_1_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 761 CASE (9) 762 CALL block_1_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 763 CASE (10) 764 CALL block_1_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 765 CASE (11) 766 CALL block_1_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 767 CASE (15) 768 CALL block_1_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 769 CASE DEFAULT 770 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 771 END SELECT 772 CASE (4) 773 SELECT CASE (mc_max) 774 CASE (1) 775 SELECT CASE (md_max) 776 CASE (1) 777 CALL block_1_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 778 CASE (2) 779 CALL block_1_4_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 780 CASE (3) 781 CALL block_1_4_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 782 CASE (4) 783 CALL block_1_4_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 784 CASE (5) 785 CALL block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 786 CASE (6) 787 CALL block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 788 CASE (7) 789 CALL block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 790 CASE (9) 791 CALL block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 792 CASE (10) 793 CALL block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 794 CASE (11) 795 CALL block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 796 CASE (15) 797 CALL block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 798 CASE DEFAULT 799 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 800 END SELECT 801 CASE (2) 802 SELECT CASE (md_max) 803 CASE (1) 804 CALL block_1_4_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 805 CASE (2) 806 CALL block_1_4_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 807 CASE (3) 808 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 809 CASE (4) 810 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 811 CASE (5) 812 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 813 CASE (6) 814 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 815 CASE (7) 816 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 817 CASE (9) 818 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 819 CASE (10) 820 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 821 CASE (11) 822 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 823 CASE (15) 824 CALL block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 825 CASE DEFAULT 826 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 827 END SELECT 828 CASE (3) 829 SELECT CASE (md_max) 830 CASE (1) 831 CALL block_1_4_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 832 CASE (2) 833 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 834 CASE (3) 835 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 836 CASE (4) 837 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 838 CASE (5) 839 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 840 CASE (6) 841 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 842 CASE (7) 843 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 844 CASE (9) 845 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 846 CASE (10) 847 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 848 CASE (11) 849 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 850 CASE (15) 851 CALL block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 852 CASE DEFAULT 853 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 854 END SELECT 855 CASE (4) 856 SELECT CASE (md_max) 857 CASE (1) 858 CALL block_1_4_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 859 CASE (2) 860 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 861 CASE (3) 862 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 863 CASE (4) 864 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 865 CASE (5) 866 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 867 CASE (6) 868 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 869 CASE (7) 870 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 871 CASE (9) 872 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 873 CASE (10) 874 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 875 CASE (11) 876 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 877 CASE (15) 878 CALL block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 879 CASE DEFAULT 880 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 881 END SELECT 882 CASE (5) 883 CALL block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 884 CASE (6) 885 CALL block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 886 CASE (7) 887 CALL block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 888 CASE (9) 889 CALL block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 890 CASE (10) 891 CALL block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 892 CASE (11) 893 CALL block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 894 CASE (15) 895 CALL block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 896 CASE DEFAULT 897 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 898 END SELECT 899 CASE (5) 900 SELECT CASE (mc_max) 901 CASE (1) 902 SELECT CASE (md_max) 903 CASE (1) 904 CALL block_1_5_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 905 CASE (2) 906 CALL block_1_5_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 907 CASE (3) 908 CALL block_1_5_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 909 CASE (4) 910 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 911 CASE (5) 912 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 913 CASE (6) 914 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 915 CASE (7) 916 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 917 CASE (9) 918 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 919 CASE (10) 920 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 921 CASE (11) 922 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 923 CASE (15) 924 CALL block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 925 CASE DEFAULT 926 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 927 END SELECT 928 CASE (2) 929 SELECT CASE (md_max) 930 CASE (1) 931 CALL block_1_5_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 932 CASE (2) 933 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 934 CASE (3) 935 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 936 CASE (4) 937 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 938 CASE (5) 939 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 940 CASE (6) 941 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 942 CASE (7) 943 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 944 CASE (9) 945 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 946 CASE (10) 947 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 948 CASE (11) 949 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 950 CASE (15) 951 CALL block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 952 CASE DEFAULT 953 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 954 END SELECT 955 CASE (3) 956 SELECT CASE (md_max) 957 CASE (1) 958 CALL block_1_5_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 959 CASE (2) 960 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 961 CASE (3) 962 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 963 CASE (4) 964 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 965 CASE (5) 966 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 967 CASE (6) 968 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 969 CASE (7) 970 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 971 CASE (9) 972 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 973 CASE (10) 974 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 975 CASE (11) 976 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 977 CASE (15) 978 CALL block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 979 CASE DEFAULT 980 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 981 END SELECT 982 CASE (4) 983 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 984 CASE (5) 985 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 986 CASE (6) 987 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 988 CASE (7) 989 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 990 CASE (9) 991 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 992 CASE (10) 993 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 994 CASE (11) 995 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 996 CASE (15) 997 CALL block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 998 CASE DEFAULT 999 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1000 END SELECT 1001 CASE (6) 1002 SELECT CASE (mc_max) 1003 CASE (1) 1004 SELECT CASE (md_max) 1005 CASE (1) 1006 CALL block_1_6_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1007 CASE (2) 1008 CALL block_1_6_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1009 CASE (3) 1010 CALL block_1_6_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1011 CASE (4) 1012 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1013 CASE (5) 1014 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1015 CASE (6) 1016 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1017 CASE (7) 1018 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1019 CASE (9) 1020 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1021 CASE (10) 1022 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1023 CASE (11) 1024 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1025 CASE (15) 1026 CALL block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1027 CASE DEFAULT 1028 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1029 END SELECT 1030 CASE (2) 1031 SELECT CASE (md_max) 1032 CASE (1) 1033 CALL block_1_6_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1034 CASE (2) 1035 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1036 CASE (3) 1037 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1038 CASE (4) 1039 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1040 CASE (5) 1041 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1042 CASE (6) 1043 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1044 CASE (7) 1045 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1046 CASE (9) 1047 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1048 CASE (10) 1049 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1050 CASE (11) 1051 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1052 CASE (15) 1053 CALL block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1054 CASE DEFAULT 1055 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1056 END SELECT 1057 CASE (3) 1058 SELECT CASE (md_max) 1059 CASE (1) 1060 CALL block_1_6_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1061 CASE (2) 1062 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1063 CASE (3) 1064 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1065 CASE (4) 1066 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1067 CASE (5) 1068 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1069 CASE (6) 1070 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1071 CASE (7) 1072 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1073 CASE (9) 1074 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1075 CASE (10) 1076 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1077 CASE (11) 1078 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1079 CASE (15) 1080 CALL block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1081 CASE DEFAULT 1082 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1083 END SELECT 1084 CASE (4) 1085 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1086 CASE (5) 1087 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1088 CASE (6) 1089 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1090 CASE (7) 1091 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1092 CASE (9) 1093 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1094 CASE (10) 1095 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1096 CASE (11) 1097 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1098 CASE (15) 1099 CALL block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1100 CASE DEFAULT 1101 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1102 END SELECT 1103 CASE (7) 1104 SELECT CASE (mc_max) 1105 CASE (1) 1106 SELECT CASE (md_max) 1107 CASE (1) 1108 CALL block_1_7_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1109 CASE (2) 1110 CALL block_1_7_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1111 CASE (3) 1112 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1113 CASE (4) 1114 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1115 CASE (5) 1116 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1117 CASE (6) 1118 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1119 CASE (7) 1120 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1121 CASE (9) 1122 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1123 CASE (10) 1124 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1125 CASE (11) 1126 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1127 CASE (15) 1128 CALL block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1129 CASE DEFAULT 1130 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1131 END SELECT 1132 CASE (2) 1133 SELECT CASE (md_max) 1134 CASE (1) 1135 CALL block_1_7_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1136 CASE (2) 1137 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1138 CASE (3) 1139 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1140 CASE (4) 1141 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1142 CASE (5) 1143 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1144 CASE (6) 1145 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1146 CASE (7) 1147 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1148 CASE (9) 1149 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1150 CASE (10) 1151 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1152 CASE (11) 1153 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1154 CASE (15) 1155 CALL block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1156 CASE DEFAULT 1157 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1158 END SELECT 1159 CASE (3) 1160 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1161 CASE (4) 1162 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1163 CASE (5) 1164 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1165 CASE (6) 1166 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1167 CASE (7) 1168 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1169 CASE (9) 1170 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1171 CASE (10) 1172 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1173 CASE (11) 1174 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1175 CASE (15) 1176 CALL block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1177 CASE DEFAULT 1178 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1179 END SELECT 1180 CASE (9) 1181 SELECT CASE (mc_max) 1182 CASE (1) 1183 SELECT CASE (md_max) 1184 CASE (1) 1185 CALL block_1_9_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1186 CASE (2) 1187 CALL block_1_9_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1188 CASE (3) 1189 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1190 CASE (4) 1191 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1192 CASE (5) 1193 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1194 CASE (6) 1195 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1196 CASE (7) 1197 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1198 CASE (9) 1199 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1200 CASE (10) 1201 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1202 CASE (11) 1203 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1204 CASE (15) 1205 CALL block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1206 CASE DEFAULT 1207 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1208 END SELECT 1209 CASE (2) 1210 SELECT CASE (md_max) 1211 CASE (1) 1212 CALL block_1_9_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1213 CASE (2) 1214 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1215 CASE (3) 1216 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1217 CASE (4) 1218 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1219 CASE (5) 1220 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1221 CASE (6) 1222 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1223 CASE (7) 1224 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1225 CASE (9) 1226 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1227 CASE (10) 1228 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1229 CASE (11) 1230 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1231 CASE (15) 1232 CALL block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1233 CASE DEFAULT 1234 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1235 END SELECT 1236 CASE (3) 1237 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1238 CASE (4) 1239 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1240 CASE (5) 1241 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1242 CASE (6) 1243 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1244 CASE (7) 1245 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1246 CASE (9) 1247 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1248 CASE (10) 1249 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1250 CASE (11) 1251 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1252 CASE (15) 1253 CALL block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1254 CASE DEFAULT 1255 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1256 END SELECT 1257 CASE (10) 1258 SELECT CASE (mc_max) 1259 CASE (1) 1260 SELECT CASE (md_max) 1261 CASE (1) 1262 CALL block_1_10_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1263 CASE (2) 1264 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1265 CASE (3) 1266 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1267 CASE (4) 1268 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1269 CASE (5) 1270 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1271 CASE (6) 1272 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1273 CASE (7) 1274 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1275 CASE (9) 1276 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1277 CASE (10) 1278 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1279 CASE (11) 1280 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1281 CASE (15) 1282 CALL block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1283 CASE DEFAULT 1284 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1285 END SELECT 1286 CASE (2) 1287 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1288 CASE (3) 1289 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1290 CASE (4) 1291 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1292 CASE (5) 1293 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1294 CASE (6) 1295 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1296 CASE (7) 1297 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1298 CASE (9) 1299 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1300 CASE (10) 1301 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1302 CASE (11) 1303 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1304 CASE (15) 1305 CALL block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1306 CASE DEFAULT 1307 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1308 END SELECT 1309 CASE (11) 1310 SELECT CASE (mc_max) 1311 CASE (1) 1312 SELECT CASE (md_max) 1313 CASE (1) 1314 CALL block_1_11_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1315 CASE (2) 1316 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1317 CASE (3) 1318 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1319 CASE (4) 1320 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1321 CASE (5) 1322 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1323 CASE (6) 1324 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1325 CASE (7) 1326 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1327 CASE (9) 1328 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1329 CASE (10) 1330 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1331 CASE (11) 1332 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1333 CASE (15) 1334 CALL block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1335 CASE DEFAULT 1336 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1337 END SELECT 1338 CASE (2) 1339 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1340 CASE (3) 1341 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1342 CASE (4) 1343 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1344 CASE (5) 1345 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1346 CASE (6) 1347 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1348 CASE (7) 1349 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1350 CASE (9) 1351 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1352 CASE (10) 1353 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1354 CASE (11) 1355 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1356 CASE (15) 1357 CALL block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1358 CASE DEFAULT 1359 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1360 END SELECT 1361 CASE (15) 1362 SELECT CASE (mc_max) 1363 CASE (1) 1364 SELECT CASE (md_max) 1365 CASE (1) 1366 CALL block_1_15_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1367 CASE (2) 1368 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1369 CASE (3) 1370 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1371 CASE (4) 1372 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1373 CASE (5) 1374 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1375 CASE (6) 1376 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1377 CASE (7) 1378 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1379 CASE (9) 1380 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1381 CASE (10) 1382 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1383 CASE (11) 1384 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1385 CASE (15) 1386 CALL block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1387 CASE DEFAULT 1388 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1389 END SELECT 1390 CASE (2) 1391 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1392 CASE (3) 1393 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1394 CASE (4) 1395 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1396 CASE (5) 1397 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1398 CASE (6) 1399 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1400 CASE (7) 1401 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1402 CASE (9) 1403 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1404 CASE (10) 1405 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1406 CASE (11) 1407 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1408 CASE (15) 1409 CALL block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1410 CASE DEFAULT 1411 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1412 END SELECT 1413 CASE DEFAULT 1414 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1415 END SELECT 1416 CASE (2) 1417 SELECT CASE (mb_max) 1418 CASE (1) 1419 SELECT CASE (mc_max) 1420 CASE (1) 1421 SELECT CASE (md_max) 1422 CASE (1) 1423 CALL block_2_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1424 CASE (2) 1425 CALL block_2_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1426 CASE (3) 1427 CALL block_2_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1428 CASE (4) 1429 CALL block_2_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1430 CASE (5) 1431 CALL block_2_1_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1432 CASE (6) 1433 CALL block_2_1_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1434 CASE (7) 1435 CALL block_2_1_1_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1436 CASE (9) 1437 CALL block_2_1_1_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1438 CASE (10) 1439 CALL block_2_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1440 CASE (11) 1441 CALL block_2_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1442 CASE (15) 1443 CALL block_2_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1444 CASE DEFAULT 1445 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1446 END SELECT 1447 CASE (2) 1448 SELECT CASE (md_max) 1449 CASE (1) 1450 CALL block_2_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1451 CASE (2) 1452 CALL block_2_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1453 CASE (3) 1454 CALL block_2_1_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1455 CASE (4) 1456 CALL block_2_1_2_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1457 CASE (5) 1458 CALL block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1459 CASE (6) 1460 CALL block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1461 CASE (7) 1462 CALL block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1463 CASE (9) 1464 CALL block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1465 CASE (10) 1466 CALL block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1467 CASE (11) 1468 CALL block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1469 CASE (15) 1470 CALL block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1471 CASE DEFAULT 1472 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1473 END SELECT 1474 CASE (3) 1475 SELECT CASE (md_max) 1476 CASE (1) 1477 CALL block_2_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1478 CASE (2) 1479 CALL block_2_1_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1480 CASE (3) 1481 CALL block_2_1_3_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1482 CASE (4) 1483 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1484 CASE (5) 1485 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1486 CASE (6) 1487 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1488 CASE (7) 1489 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1490 CASE (9) 1491 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1492 CASE (10) 1493 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1494 CASE (11) 1495 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1496 CASE (15) 1497 CALL block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1498 CASE DEFAULT 1499 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1500 END SELECT 1501 CASE (4) 1502 SELECT CASE (md_max) 1503 CASE (1) 1504 CALL block_2_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1505 CASE (2) 1506 CALL block_2_1_4_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1507 CASE (3) 1508 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1509 CASE (4) 1510 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1511 CASE (5) 1512 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1513 CASE (6) 1514 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1515 CASE (7) 1516 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1517 CASE (9) 1518 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1519 CASE (10) 1520 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1521 CASE (11) 1522 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1523 CASE (15) 1524 CALL block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1525 CASE DEFAULT 1526 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1527 END SELECT 1528 CASE (5) 1529 SELECT CASE (md_max) 1530 CASE (1) 1531 CALL block_2_1_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1532 CASE (2) 1533 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1534 CASE (3) 1535 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1536 CASE (4) 1537 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1538 CASE (5) 1539 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1540 CASE (6) 1541 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1542 CASE (7) 1543 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1544 CASE (9) 1545 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1546 CASE (10) 1547 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1548 CASE (11) 1549 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1550 CASE (15) 1551 CALL block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1552 CASE DEFAULT 1553 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1554 END SELECT 1555 CASE (6) 1556 SELECT CASE (md_max) 1557 CASE (1) 1558 CALL block_2_1_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1559 CASE (2) 1560 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1561 CASE (3) 1562 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1563 CASE (4) 1564 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1565 CASE (5) 1566 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1567 CASE (6) 1568 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1569 CASE (7) 1570 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1571 CASE (9) 1572 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1573 CASE (10) 1574 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1575 CASE (11) 1576 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1577 CASE (15) 1578 CALL block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1579 CASE DEFAULT 1580 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1581 END SELECT 1582 CASE (7) 1583 SELECT CASE (md_max) 1584 CASE (1) 1585 CALL block_2_1_7_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1586 CASE (2) 1587 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1588 CASE (3) 1589 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1590 CASE (4) 1591 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1592 CASE (5) 1593 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1594 CASE (6) 1595 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1596 CASE (7) 1597 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1598 CASE (9) 1599 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1600 CASE (10) 1601 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1602 CASE (11) 1603 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1604 CASE (15) 1605 CALL block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1606 CASE DEFAULT 1607 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1608 END SELECT 1609 CASE (9) 1610 SELECT CASE (md_max) 1611 CASE (1) 1612 CALL block_2_1_9_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1613 CASE (2) 1614 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1615 CASE (3) 1616 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1617 CASE (4) 1618 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1619 CASE (5) 1620 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1621 CASE (6) 1622 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1623 CASE (7) 1624 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1625 CASE (9) 1626 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1627 CASE (10) 1628 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1629 CASE (11) 1630 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1631 CASE (15) 1632 CALL block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1633 CASE DEFAULT 1634 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1635 END SELECT 1636 CASE (10) 1637 CALL block_2_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1638 CASE (11) 1639 CALL block_2_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1640 CASE (15) 1641 CALL block_2_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1642 CASE DEFAULT 1643 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1644 END SELECT 1645 CASE (2) 1646 SELECT CASE (mc_max) 1647 CASE (1) 1648 SELECT CASE (md_max) 1649 CASE (1) 1650 CALL block_2_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1651 CASE (2) 1652 CALL block_2_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1653 CASE (3) 1654 CALL block_2_2_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1655 CASE (4) 1656 CALL block_2_2_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1657 CASE (5) 1658 CALL block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1659 CASE (6) 1660 CALL block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1661 CASE (7) 1662 CALL block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1663 CASE (9) 1664 CALL block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1665 CASE (10) 1666 CALL block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1667 CASE (11) 1668 CALL block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1669 CASE (15) 1670 CALL block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1671 CASE DEFAULT 1672 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1673 END SELECT 1674 CASE (2) 1675 SELECT CASE (md_max) 1676 CASE (1) 1677 CALL block_2_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1678 CASE (2) 1679 CALL block_2_2_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1680 CASE (3) 1681 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1682 CASE (4) 1683 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1684 CASE (5) 1685 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1686 CASE (6) 1687 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1688 CASE (7) 1689 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1690 CASE (9) 1691 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1692 CASE (10) 1693 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1694 CASE (11) 1695 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1696 CASE (15) 1697 CALL block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1698 CASE DEFAULT 1699 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1700 END SELECT 1701 CASE (3) 1702 SELECT CASE (md_max) 1703 CASE (1) 1704 CALL block_2_2_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1705 CASE (2) 1706 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1707 CASE (3) 1708 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1709 CASE (4) 1710 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1711 CASE (5) 1712 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1713 CASE (6) 1714 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1715 CASE (7) 1716 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1717 CASE (9) 1718 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1719 CASE (10) 1720 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1721 CASE (11) 1722 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1723 CASE (15) 1724 CALL block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1725 CASE DEFAULT 1726 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1727 END SELECT 1728 CASE (4) 1729 SELECT CASE (md_max) 1730 CASE (1) 1731 CALL block_2_2_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1732 CASE (2) 1733 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1734 CASE (3) 1735 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1736 CASE (4) 1737 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1738 CASE (5) 1739 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1740 CASE (6) 1741 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1742 CASE (7) 1743 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1744 CASE (9) 1745 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1746 CASE (10) 1747 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1748 CASE (11) 1749 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1750 CASE (15) 1751 CALL block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1752 CASE DEFAULT 1753 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1754 END SELECT 1755 CASE (5) 1756 CALL block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1757 CASE (6) 1758 CALL block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1759 CASE (7) 1760 CALL block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1761 CASE (9) 1762 CALL block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1763 CASE (10) 1764 CALL block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1765 CASE (11) 1766 CALL block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1767 CASE (15) 1768 CALL block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1769 CASE DEFAULT 1770 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1771 END SELECT 1772 CASE (3) 1773 SELECT CASE (mc_max) 1774 CASE (1) 1775 SELECT CASE (md_max) 1776 CASE (1) 1777 CALL block_2_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1778 CASE (2) 1779 CALL block_2_3_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1780 CASE (3) 1781 CALL block_2_3_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1782 CASE (4) 1783 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1784 CASE (5) 1785 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1786 CASE (6) 1787 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1788 CASE (7) 1789 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1790 CASE (9) 1791 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1792 CASE (10) 1793 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1794 CASE (11) 1795 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1796 CASE (15) 1797 CALL block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1798 CASE DEFAULT 1799 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1800 END SELECT 1801 CASE (2) 1802 SELECT CASE (md_max) 1803 CASE (1) 1804 CALL block_2_3_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1805 CASE (2) 1806 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1807 CASE (3) 1808 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1809 CASE (4) 1810 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1811 CASE (5) 1812 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1813 CASE (6) 1814 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1815 CASE (7) 1816 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1817 CASE (9) 1818 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1819 CASE (10) 1820 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1821 CASE (11) 1822 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1823 CASE (15) 1824 CALL block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1825 CASE DEFAULT 1826 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1827 END SELECT 1828 CASE (3) 1829 SELECT CASE (md_max) 1830 CASE (1) 1831 CALL block_2_3_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1832 CASE (2) 1833 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1834 CASE (3) 1835 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1836 CASE (4) 1837 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1838 CASE (5) 1839 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1840 CASE (6) 1841 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1842 CASE (7) 1843 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1844 CASE (9) 1845 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1846 CASE (10) 1847 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1848 CASE (11) 1849 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1850 CASE (15) 1851 CALL block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1852 CASE DEFAULT 1853 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1854 END SELECT 1855 CASE (4) 1856 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1857 CASE (5) 1858 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1859 CASE (6) 1860 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1861 CASE (7) 1862 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1863 CASE (9) 1864 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1865 CASE (10) 1866 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1867 CASE (11) 1868 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1869 CASE (15) 1870 CALL block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1871 CASE DEFAULT 1872 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1873 END SELECT 1874 CASE (4) 1875 SELECT CASE (mc_max) 1876 CASE (1) 1877 SELECT CASE (md_max) 1878 CASE (1) 1879 CALL block_2_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1880 CASE (2) 1881 CALL block_2_4_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1882 CASE (3) 1883 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1884 CASE (4) 1885 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1886 CASE (5) 1887 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1888 CASE (6) 1889 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1890 CASE (7) 1891 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1892 CASE (9) 1893 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1894 CASE (10) 1895 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1896 CASE (11) 1897 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1898 CASE (15) 1899 CALL block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1900 CASE DEFAULT 1901 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1902 END SELECT 1903 CASE (2) 1904 SELECT CASE (md_max) 1905 CASE (1) 1906 CALL block_2_4_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1907 CASE (2) 1908 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1909 CASE (3) 1910 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1911 CASE (4) 1912 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1913 CASE (5) 1914 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1915 CASE (6) 1916 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1917 CASE (7) 1918 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1919 CASE (9) 1920 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1921 CASE (10) 1922 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1923 CASE (11) 1924 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1925 CASE (15) 1926 CALL block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1927 CASE DEFAULT 1928 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1929 END SELECT 1930 CASE (3) 1931 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1932 CASE (4) 1933 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1934 CASE (5) 1935 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1936 CASE (6) 1937 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1938 CASE (7) 1939 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1940 CASE (9) 1941 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1942 CASE (10) 1943 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1944 CASE (11) 1945 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1946 CASE (15) 1947 CALL block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1948 CASE DEFAULT 1949 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1950 END SELECT 1951 CASE (5) 1952 SELECT CASE (mc_max) 1953 CASE (1) 1954 SELECT CASE (md_max) 1955 CASE (1) 1956 CALL block_2_5_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1957 CASE (2) 1958 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1959 CASE (3) 1960 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1961 CASE (4) 1962 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1963 CASE (5) 1964 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1965 CASE (6) 1966 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1967 CASE (7) 1968 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1969 CASE (9) 1970 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1971 CASE (10) 1972 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1973 CASE (11) 1974 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1975 CASE (15) 1976 CALL block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1977 CASE DEFAULT 1978 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1979 END SELECT 1980 CASE (2) 1981 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1982 CASE (3) 1983 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1984 CASE (4) 1985 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1986 CASE (5) 1987 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1988 CASE (6) 1989 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1990 CASE (7) 1991 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1992 CASE (9) 1993 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1994 CASE (10) 1995 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1996 CASE (11) 1997 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 1998 CASE (15) 1999 CALL block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2000 CASE DEFAULT 2001 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2002 END SELECT 2003 CASE (6) 2004 SELECT CASE (mc_max) 2005 CASE (1) 2006 SELECT CASE (md_max) 2007 CASE (1) 2008 CALL block_2_6_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2009 CASE (2) 2010 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2011 CASE (3) 2012 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2013 CASE (4) 2014 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2015 CASE (5) 2016 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2017 CASE (6) 2018 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2019 CASE (7) 2020 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2021 CASE (9) 2022 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2023 CASE (10) 2024 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2025 CASE (11) 2026 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2027 CASE (15) 2028 CALL block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2029 CASE DEFAULT 2030 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2031 END SELECT 2032 CASE (2) 2033 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2034 CASE (3) 2035 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2036 CASE (4) 2037 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2038 CASE (5) 2039 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2040 CASE (6) 2041 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2042 CASE (7) 2043 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2044 CASE (9) 2045 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2046 CASE (10) 2047 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2048 CASE (11) 2049 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2050 CASE (15) 2051 CALL block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2052 CASE DEFAULT 2053 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2054 END SELECT 2055 CASE (7) 2056 SELECT CASE (mc_max) 2057 CASE (1) 2058 SELECT CASE (md_max) 2059 CASE (1) 2060 CALL block_2_7_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2061 CASE (2) 2062 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2063 CASE (3) 2064 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2065 CASE (4) 2066 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2067 CASE (5) 2068 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2069 CASE (6) 2070 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2071 CASE (7) 2072 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2073 CASE (9) 2074 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2075 CASE (10) 2076 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2077 CASE (11) 2078 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2079 CASE (15) 2080 CALL block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2081 CASE DEFAULT 2082 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2083 END SELECT 2084 CASE (2) 2085 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2086 CASE (3) 2087 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2088 CASE (4) 2089 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2090 CASE (5) 2091 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2092 CASE (6) 2093 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2094 CASE (7) 2095 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2096 CASE (9) 2097 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2098 CASE (10) 2099 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2100 CASE (11) 2101 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2102 CASE (15) 2103 CALL block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2104 CASE DEFAULT 2105 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2106 END SELECT 2107 CASE (9) 2108 SELECT CASE (mc_max) 2109 CASE (1) 2110 SELECT CASE (md_max) 2111 CASE (1) 2112 CALL block_2_9_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2113 CASE (2) 2114 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2115 CASE (3) 2116 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2117 CASE (4) 2118 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2119 CASE (5) 2120 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2121 CASE (6) 2122 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2123 CASE (7) 2124 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2125 CASE (9) 2126 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2127 CASE (10) 2128 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2129 CASE (11) 2130 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2131 CASE (15) 2132 CALL block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2133 CASE DEFAULT 2134 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2135 END SELECT 2136 CASE (2) 2137 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2138 CASE (3) 2139 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2140 CASE (4) 2141 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2142 CASE (5) 2143 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2144 CASE (6) 2145 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2146 CASE (7) 2147 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2148 CASE (9) 2149 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2150 CASE (10) 2151 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2152 CASE (11) 2153 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2154 CASE (15) 2155 CALL block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2156 CASE DEFAULT 2157 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2158 END SELECT 2159 CASE (10) 2160 CALL block_2_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2161 CASE (11) 2162 CALL block_2_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2163 CASE (15) 2164 CALL block_2_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2165 CASE DEFAULT 2166 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2167 END SELECT 2168 CASE (3) 2169 SELECT CASE (mb_max) 2170 CASE (1) 2171 SELECT CASE (mc_max) 2172 CASE (1) 2173 SELECT CASE (md_max) 2174 CASE (1) 2175 CALL block_3_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2176 CASE (2) 2177 CALL block_3_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2178 CASE (3) 2179 CALL block_3_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2180 CASE (4) 2181 CALL block_3_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2182 CASE (5) 2183 CALL block_3_1_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2184 CASE (6) 2185 CALL block_3_1_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2186 CASE (7) 2187 CALL block_3_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2188 CASE (9) 2189 CALL block_3_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2190 CASE (10) 2191 CALL block_3_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2192 CASE (11) 2193 CALL block_3_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2194 CASE (15) 2195 CALL block_3_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2196 CASE DEFAULT 2197 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2198 END SELECT 2199 CASE (2) 2200 SELECT CASE (md_max) 2201 CASE (1) 2202 CALL block_3_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2203 CASE (2) 2204 CALL block_3_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2205 CASE (3) 2206 CALL block_3_1_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2207 CASE (4) 2208 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2209 CASE (5) 2210 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2211 CASE (6) 2212 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2213 CASE (7) 2214 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2215 CASE (9) 2216 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2217 CASE (10) 2218 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2219 CASE (11) 2220 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2221 CASE (15) 2222 CALL block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2223 CASE DEFAULT 2224 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2225 END SELECT 2226 CASE (3) 2227 SELECT CASE (md_max) 2228 CASE (1) 2229 CALL block_3_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2230 CASE (2) 2231 CALL block_3_1_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2232 CASE (3) 2233 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2234 CASE (4) 2235 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2236 CASE (5) 2237 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2238 CASE (6) 2239 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2240 CASE (7) 2241 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2242 CASE (9) 2243 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2244 CASE (10) 2245 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2246 CASE (11) 2247 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2248 CASE (15) 2249 CALL block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2250 CASE DEFAULT 2251 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2252 END SELECT 2253 CASE (4) 2254 SELECT CASE (md_max) 2255 CASE (1) 2256 CALL block_3_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2257 CASE (2) 2258 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2259 CASE (3) 2260 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2261 CASE (4) 2262 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2263 CASE (5) 2264 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2265 CASE (6) 2266 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2267 CASE (7) 2268 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2269 CASE (9) 2270 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2271 CASE (10) 2272 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2273 CASE (11) 2274 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2275 CASE (15) 2276 CALL block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2277 CASE DEFAULT 2278 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2279 END SELECT 2280 CASE (5) 2281 SELECT CASE (md_max) 2282 CASE (1) 2283 CALL block_3_1_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2284 CASE (2) 2285 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2286 CASE (3) 2287 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2288 CASE (4) 2289 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2290 CASE (5) 2291 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2292 CASE (6) 2293 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2294 CASE (7) 2295 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2296 CASE (9) 2297 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2298 CASE (10) 2299 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2300 CASE (11) 2301 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2302 CASE (15) 2303 CALL block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2304 CASE DEFAULT 2305 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2306 END SELECT 2307 CASE (6) 2308 SELECT CASE (md_max) 2309 CASE (1) 2310 CALL block_3_1_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2311 CASE (2) 2312 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2313 CASE (3) 2314 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2315 CASE (4) 2316 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2317 CASE (5) 2318 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2319 CASE (6) 2320 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2321 CASE (7) 2322 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2323 CASE (9) 2324 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2325 CASE (10) 2326 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2327 CASE (11) 2328 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2329 CASE (15) 2330 CALL block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2331 CASE DEFAULT 2332 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2333 END SELECT 2334 CASE (7) 2335 CALL block_3_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2336 CASE (9) 2337 CALL block_3_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2338 CASE (10) 2339 CALL block_3_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2340 CASE (11) 2341 CALL block_3_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2342 CASE (15) 2343 CALL block_3_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2344 CASE DEFAULT 2345 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2346 END SELECT 2347 CASE (2) 2348 SELECT CASE (mc_max) 2349 CASE (1) 2350 SELECT CASE (md_max) 2351 CASE (1) 2352 CALL block_3_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2353 CASE (2) 2354 CALL block_3_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2355 CASE (3) 2356 CALL block_3_2_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2357 CASE (4) 2358 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2359 CASE (5) 2360 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2361 CASE (6) 2362 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2363 CASE (7) 2364 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2365 CASE (9) 2366 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2367 CASE (10) 2368 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2369 CASE (11) 2370 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2371 CASE (15) 2372 CALL block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2373 CASE DEFAULT 2374 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2375 END SELECT 2376 CASE (2) 2377 SELECT CASE (md_max) 2378 CASE (1) 2379 CALL block_3_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2380 CASE (2) 2381 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2382 CASE (3) 2383 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2384 CASE (4) 2385 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2386 CASE (5) 2387 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2388 CASE (6) 2389 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2390 CASE (7) 2391 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2392 CASE (9) 2393 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2394 CASE (10) 2395 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2396 CASE (11) 2397 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2398 CASE (15) 2399 CALL block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2400 CASE DEFAULT 2401 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2402 END SELECT 2403 CASE (3) 2404 SELECT CASE (md_max) 2405 CASE (1) 2406 CALL block_3_2_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2407 CASE (2) 2408 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2409 CASE (3) 2410 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2411 CASE (4) 2412 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2413 CASE (5) 2414 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2415 CASE (6) 2416 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2417 CASE (7) 2418 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2419 CASE (9) 2420 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2421 CASE (10) 2422 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2423 CASE (11) 2424 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2425 CASE (15) 2426 CALL block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2427 CASE DEFAULT 2428 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2429 END SELECT 2430 CASE (4) 2431 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2432 CASE (5) 2433 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2434 CASE (6) 2435 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2436 CASE (7) 2437 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2438 CASE (9) 2439 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2440 CASE (10) 2441 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2442 CASE (11) 2443 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2444 CASE (15) 2445 CALL block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2446 CASE DEFAULT 2447 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2448 END SELECT 2449 CASE (3) 2450 SELECT CASE (mc_max) 2451 CASE (1) 2452 SELECT CASE (md_max) 2453 CASE (1) 2454 CALL block_3_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2455 CASE (2) 2456 CALL block_3_3_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2457 CASE (3) 2458 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2459 CASE (4) 2460 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2461 CASE (5) 2462 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2463 CASE (6) 2464 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2465 CASE (7) 2466 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2467 CASE (9) 2468 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2469 CASE (10) 2470 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2471 CASE (11) 2472 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2473 CASE (15) 2474 CALL block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2475 CASE DEFAULT 2476 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2477 END SELECT 2478 CASE (2) 2479 SELECT CASE (md_max) 2480 CASE (1) 2481 CALL block_3_3_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2482 CASE (2) 2483 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2484 CASE (3) 2485 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2486 CASE (4) 2487 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2488 CASE (5) 2489 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2490 CASE (6) 2491 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2492 CASE (7) 2493 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2494 CASE (9) 2495 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2496 CASE (10) 2497 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2498 CASE (11) 2499 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2500 CASE (15) 2501 CALL block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2502 CASE DEFAULT 2503 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2504 END SELECT 2505 CASE (3) 2506 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2507 CASE (4) 2508 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2509 CASE (5) 2510 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2511 CASE (6) 2512 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2513 CASE (7) 2514 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2515 CASE (9) 2516 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2517 CASE (10) 2518 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2519 CASE (11) 2520 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2521 CASE (15) 2522 CALL block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2523 CASE DEFAULT 2524 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2525 END SELECT 2526 CASE (4) 2527 SELECT CASE (mc_max) 2528 CASE (1) 2529 SELECT CASE (md_max) 2530 CASE (1) 2531 CALL block_3_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2532 CASE (2) 2533 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2534 CASE (3) 2535 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2536 CASE (4) 2537 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2538 CASE (5) 2539 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2540 CASE (6) 2541 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2542 CASE (7) 2543 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2544 CASE (9) 2545 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2546 CASE (10) 2547 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2548 CASE (11) 2549 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2550 CASE (15) 2551 CALL block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2552 CASE DEFAULT 2553 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2554 END SELECT 2555 CASE (2) 2556 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2557 CASE (3) 2558 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2559 CASE (4) 2560 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2561 CASE (5) 2562 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2563 CASE (6) 2564 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2565 CASE (7) 2566 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2567 CASE (9) 2568 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2569 CASE (10) 2570 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2571 CASE (11) 2572 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2573 CASE (15) 2574 CALL block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2575 CASE DEFAULT 2576 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2577 END SELECT 2578 CASE (5) 2579 SELECT CASE (mc_max) 2580 CASE (1) 2581 SELECT CASE (md_max) 2582 CASE (1) 2583 CALL block_3_5_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2584 CASE (2) 2585 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2586 CASE (3) 2587 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2588 CASE (4) 2589 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2590 CASE (5) 2591 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2592 CASE (6) 2593 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2594 CASE (7) 2595 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2596 CASE (9) 2597 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2598 CASE (10) 2599 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2600 CASE (11) 2601 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2602 CASE (15) 2603 CALL block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2604 CASE DEFAULT 2605 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2606 END SELECT 2607 CASE (2) 2608 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2609 CASE (3) 2610 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2611 CASE (4) 2612 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2613 CASE (5) 2614 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2615 CASE (6) 2616 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2617 CASE (7) 2618 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2619 CASE (9) 2620 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2621 CASE (10) 2622 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2623 CASE (11) 2624 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2625 CASE (15) 2626 CALL block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2627 CASE DEFAULT 2628 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2629 END SELECT 2630 CASE (6) 2631 SELECT CASE (mc_max) 2632 CASE (1) 2633 SELECT CASE (md_max) 2634 CASE (1) 2635 CALL block_3_6_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2636 CASE (2) 2637 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2638 CASE (3) 2639 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2640 CASE (4) 2641 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2642 CASE (5) 2643 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2644 CASE (6) 2645 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2646 CASE (7) 2647 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2648 CASE (9) 2649 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2650 CASE (10) 2651 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2652 CASE (11) 2653 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2654 CASE (15) 2655 CALL block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2656 CASE DEFAULT 2657 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2658 END SELECT 2659 CASE (2) 2660 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2661 CASE (3) 2662 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2663 CASE (4) 2664 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2665 CASE (5) 2666 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2667 CASE (6) 2668 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2669 CASE (7) 2670 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2671 CASE (9) 2672 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2673 CASE (10) 2674 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2675 CASE (11) 2676 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2677 CASE (15) 2678 CALL block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2679 CASE DEFAULT 2680 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2681 END SELECT 2682 CASE (7) 2683 CALL block_3_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2684 CASE (9) 2685 CALL block_3_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2686 CASE (10) 2687 CALL block_3_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2688 CASE (11) 2689 CALL block_3_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2690 CASE (15) 2691 CALL block_3_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2692 CASE DEFAULT 2693 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2694 END SELECT 2695 CASE (4) 2696 SELECT CASE (mb_max) 2697 CASE (1) 2698 SELECT CASE (mc_max) 2699 CASE (1) 2700 SELECT CASE (md_max) 2701 CASE (1) 2702 CALL block_4_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2703 CASE (2) 2704 CALL block_4_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2705 CASE (3) 2706 CALL block_4_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2707 CASE (4) 2708 CALL block_4_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2709 CASE (5) 2710 CALL block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2711 CASE (6) 2712 CALL block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2713 CASE (7) 2714 CALL block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2715 CASE (9) 2716 CALL block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2717 CASE (10) 2718 CALL block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2719 CASE (11) 2720 CALL block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2721 CASE (15) 2722 CALL block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2723 CASE DEFAULT 2724 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2725 END SELECT 2726 CASE (2) 2727 SELECT CASE (md_max) 2728 CASE (1) 2729 CALL block_4_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2730 CASE (2) 2731 CALL block_4_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2732 CASE (3) 2733 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2734 CASE (4) 2735 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2736 CASE (5) 2737 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2738 CASE (6) 2739 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2740 CASE (7) 2741 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2742 CASE (9) 2743 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2744 CASE (10) 2745 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2746 CASE (11) 2747 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2748 CASE (15) 2749 CALL block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2750 CASE DEFAULT 2751 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2752 END SELECT 2753 CASE (3) 2754 SELECT CASE (md_max) 2755 CASE (1) 2756 CALL block_4_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2757 CASE (2) 2758 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2759 CASE (3) 2760 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2761 CASE (4) 2762 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2763 CASE (5) 2764 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2765 CASE (6) 2766 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2767 CASE (7) 2768 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2769 CASE (9) 2770 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2771 CASE (10) 2772 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2773 CASE (11) 2774 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2775 CASE (15) 2776 CALL block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2777 CASE DEFAULT 2778 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2779 END SELECT 2780 CASE (4) 2781 SELECT CASE (md_max) 2782 CASE (1) 2783 CALL block_4_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2784 CASE (2) 2785 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2786 CASE (3) 2787 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2788 CASE (4) 2789 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2790 CASE (5) 2791 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2792 CASE (6) 2793 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2794 CASE (7) 2795 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2796 CASE (9) 2797 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2798 CASE (10) 2799 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2800 CASE (11) 2801 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2802 CASE (15) 2803 CALL block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2804 CASE DEFAULT 2805 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2806 END SELECT 2807 CASE (5) 2808 CALL block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2809 CASE (6) 2810 CALL block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2811 CASE (7) 2812 CALL block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2813 CASE (9) 2814 CALL block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2815 CASE (10) 2816 CALL block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2817 CASE (11) 2818 CALL block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2819 CASE (15) 2820 CALL block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2821 CASE DEFAULT 2822 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2823 END SELECT 2824 CASE (2) 2825 SELECT CASE (mc_max) 2826 CASE (1) 2827 SELECT CASE (md_max) 2828 CASE (1) 2829 CALL block_4_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2830 CASE (2) 2831 CALL block_4_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2832 CASE (3) 2833 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2834 CASE (4) 2835 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2836 CASE (5) 2837 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2838 CASE (6) 2839 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2840 CASE (7) 2841 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2842 CASE (9) 2843 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2844 CASE (10) 2845 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2846 CASE (11) 2847 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2848 CASE (15) 2849 CALL block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2850 CASE DEFAULT 2851 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2852 END SELECT 2853 CASE (2) 2854 SELECT CASE (md_max) 2855 CASE (1) 2856 CALL block_4_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2857 CASE (2) 2858 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2859 CASE (3) 2860 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2861 CASE (4) 2862 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2863 CASE (5) 2864 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2865 CASE (6) 2866 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2867 CASE (7) 2868 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2869 CASE (9) 2870 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2871 CASE (10) 2872 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2873 CASE (11) 2874 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2875 CASE (15) 2876 CALL block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2877 CASE DEFAULT 2878 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2879 END SELECT 2880 CASE (3) 2881 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2882 CASE (4) 2883 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2884 CASE (5) 2885 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2886 CASE (6) 2887 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2888 CASE (7) 2889 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2890 CASE (9) 2891 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2892 CASE (10) 2893 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2894 CASE (11) 2895 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2896 CASE (15) 2897 CALL block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2898 CASE DEFAULT 2899 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2900 END SELECT 2901 CASE (3) 2902 SELECT CASE (mc_max) 2903 CASE (1) 2904 SELECT CASE (md_max) 2905 CASE (1) 2906 CALL block_4_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2907 CASE (2) 2908 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2909 CASE (3) 2910 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2911 CASE (4) 2912 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2913 CASE (5) 2914 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2915 CASE (6) 2916 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2917 CASE (7) 2918 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2919 CASE (9) 2920 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2921 CASE (10) 2922 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2923 CASE (11) 2924 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2925 CASE (15) 2926 CALL block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2927 CASE DEFAULT 2928 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2929 END SELECT 2930 CASE (2) 2931 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2932 CASE (3) 2933 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2934 CASE (4) 2935 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2936 CASE (5) 2937 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2938 CASE (6) 2939 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2940 CASE (7) 2941 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2942 CASE (9) 2943 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2944 CASE (10) 2945 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2946 CASE (11) 2947 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2948 CASE (15) 2949 CALL block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2950 CASE DEFAULT 2951 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2952 END SELECT 2953 CASE (4) 2954 SELECT CASE (mc_max) 2955 CASE (1) 2956 SELECT CASE (md_max) 2957 CASE (1) 2958 CALL block_4_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2959 CASE (2) 2960 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2961 CASE (3) 2962 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2963 CASE (4) 2964 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2965 CASE (5) 2966 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2967 CASE (6) 2968 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2969 CASE (7) 2970 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2971 CASE (9) 2972 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2973 CASE (10) 2974 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2975 CASE (11) 2976 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2977 CASE (15) 2978 CALL block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2979 CASE DEFAULT 2980 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2981 END SELECT 2982 CASE (2) 2983 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2984 CASE (3) 2985 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2986 CASE (4) 2987 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2988 CASE (5) 2989 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2990 CASE (6) 2991 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2992 CASE (7) 2993 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2994 CASE (9) 2995 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2996 CASE (10) 2997 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 2998 CASE (11) 2999 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3000 CASE (15) 3001 CALL block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3002 CASE DEFAULT 3003 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3004 END SELECT 3005 CASE (5) 3006 CALL block_4_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3007 CASE (6) 3008 CALL block_4_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3009 CASE (7) 3010 CALL block_4_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3011 CASE (9) 3012 CALL block_4_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3013 CASE (10) 3014 CALL block_4_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3015 CASE (11) 3016 CALL block_4_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3017 CASE (15) 3018 CALL block_4_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3019 CASE DEFAULT 3020 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3021 END SELECT 3022 CASE (5) 3023 SELECT CASE (mb_max) 3024 CASE (1) 3025 SELECT CASE (mc_max) 3026 CASE (1) 3027 SELECT CASE (md_max) 3028 CASE (1) 3029 CALL block_5_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3030 CASE (2) 3031 CALL block_5_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3032 CASE (3) 3033 CALL block_5_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3034 CASE (4) 3035 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3036 CASE (5) 3037 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3038 CASE (6) 3039 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3040 CASE (7) 3041 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3042 CASE (9) 3043 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3044 CASE (10) 3045 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3046 CASE (11) 3047 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3048 CASE (15) 3049 CALL block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3050 CASE DEFAULT 3051 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3052 END SELECT 3053 CASE (2) 3054 SELECT CASE (md_max) 3055 CASE (1) 3056 CALL block_5_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3057 CASE (2) 3058 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3059 CASE (3) 3060 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3061 CASE (4) 3062 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3063 CASE (5) 3064 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3065 CASE (6) 3066 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3067 CASE (7) 3068 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3069 CASE (9) 3070 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3071 CASE (10) 3072 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3073 CASE (11) 3074 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3075 CASE (15) 3076 CALL block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3077 CASE DEFAULT 3078 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3079 END SELECT 3080 CASE (3) 3081 SELECT CASE (md_max) 3082 CASE (1) 3083 CALL block_5_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3084 CASE (2) 3085 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3086 CASE (3) 3087 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3088 CASE (4) 3089 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3090 CASE (5) 3091 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3092 CASE (6) 3093 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3094 CASE (7) 3095 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3096 CASE (9) 3097 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3098 CASE (10) 3099 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3100 CASE (11) 3101 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3102 CASE (15) 3103 CALL block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3104 CASE DEFAULT 3105 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3106 END SELECT 3107 CASE (4) 3108 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3109 CASE (5) 3110 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3111 CASE (6) 3112 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3113 CASE (7) 3114 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3115 CASE (9) 3116 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3117 CASE (10) 3118 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3119 CASE (11) 3120 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3121 CASE (15) 3122 CALL block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3123 CASE DEFAULT 3124 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3125 END SELECT 3126 CASE (2) 3127 SELECT CASE (mc_max) 3128 CASE (1) 3129 SELECT CASE (md_max) 3130 CASE (1) 3131 CALL block_5_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3132 CASE (2) 3133 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3134 CASE (3) 3135 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3136 CASE (4) 3137 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3138 CASE (5) 3139 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3140 CASE (6) 3141 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3142 CASE (7) 3143 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3144 CASE (9) 3145 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3146 CASE (10) 3147 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3148 CASE (11) 3149 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3150 CASE (15) 3151 CALL block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3152 CASE DEFAULT 3153 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3154 END SELECT 3155 CASE (2) 3156 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3157 CASE (3) 3158 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3159 CASE (4) 3160 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3161 CASE (5) 3162 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3163 CASE (6) 3164 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3165 CASE (7) 3166 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3167 CASE (9) 3168 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3169 CASE (10) 3170 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3171 CASE (11) 3172 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3173 CASE (15) 3174 CALL block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3175 CASE DEFAULT 3176 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3177 END SELECT 3178 CASE (3) 3179 SELECT CASE (mc_max) 3180 CASE (1) 3181 SELECT CASE (md_max) 3182 CASE (1) 3183 CALL block_5_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3184 CASE (2) 3185 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3186 CASE (3) 3187 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3188 CASE (4) 3189 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3190 CASE (5) 3191 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3192 CASE (6) 3193 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3194 CASE (7) 3195 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3196 CASE (9) 3197 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3198 CASE (10) 3199 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3200 CASE (11) 3201 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3202 CASE (15) 3203 CALL block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3204 CASE DEFAULT 3205 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3206 END SELECT 3207 CASE (2) 3208 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3209 CASE (3) 3210 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3211 CASE (4) 3212 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3213 CASE (5) 3214 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3215 CASE (6) 3216 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3217 CASE (7) 3218 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3219 CASE (9) 3220 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3221 CASE (10) 3222 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3223 CASE (11) 3224 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3225 CASE (15) 3226 CALL block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3227 CASE DEFAULT 3228 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3229 END SELECT 3230 CASE (4) 3231 CALL block_5_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3232 CASE (5) 3233 CALL block_5_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3234 CASE (6) 3235 CALL block_5_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3236 CASE (7) 3237 CALL block_5_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3238 CASE (9) 3239 CALL block_5_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3240 CASE (10) 3241 CALL block_5_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3242 CASE (11) 3243 CALL block_5_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3244 CASE (15) 3245 CALL block_5_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3246 CASE DEFAULT 3247 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3248 END SELECT 3249 CASE (6) 3250 SELECT CASE (mb_max) 3251 CASE (1) 3252 SELECT CASE (mc_max) 3253 CASE (1) 3254 SELECT CASE (md_max) 3255 CASE (1) 3256 CALL block_6_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3257 CASE (2) 3258 CALL block_6_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3259 CASE (3) 3260 CALL block_6_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3261 CASE (4) 3262 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3263 CASE (5) 3264 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3265 CASE (6) 3266 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3267 CASE (7) 3268 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3269 CASE (9) 3270 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3271 CASE (10) 3272 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3273 CASE (11) 3274 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3275 CASE (15) 3276 CALL block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3277 CASE DEFAULT 3278 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3279 END SELECT 3280 CASE (2) 3281 SELECT CASE (md_max) 3282 CASE (1) 3283 CALL block_6_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3284 CASE (2) 3285 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3286 CASE (3) 3287 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3288 CASE (4) 3289 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3290 CASE (5) 3291 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3292 CASE (6) 3293 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3294 CASE (7) 3295 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3296 CASE (9) 3297 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3298 CASE (10) 3299 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3300 CASE (11) 3301 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3302 CASE (15) 3303 CALL block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3304 CASE DEFAULT 3305 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3306 END SELECT 3307 CASE (3) 3308 SELECT CASE (md_max) 3309 CASE (1) 3310 CALL block_6_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3311 CASE (2) 3312 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3313 CASE (3) 3314 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3315 CASE (4) 3316 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3317 CASE (5) 3318 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3319 CASE (6) 3320 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3321 CASE (7) 3322 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3323 CASE (9) 3324 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3325 CASE (10) 3326 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3327 CASE (11) 3328 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3329 CASE (15) 3330 CALL block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3331 CASE DEFAULT 3332 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3333 END SELECT 3334 CASE (4) 3335 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3336 CASE (5) 3337 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3338 CASE (6) 3339 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3340 CASE (7) 3341 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3342 CASE (9) 3343 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3344 CASE (10) 3345 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3346 CASE (11) 3347 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3348 CASE (15) 3349 CALL block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3350 CASE DEFAULT 3351 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3352 END SELECT 3353 CASE (2) 3354 SELECT CASE (mc_max) 3355 CASE (1) 3356 SELECT CASE (md_max) 3357 CASE (1) 3358 CALL block_6_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3359 CASE (2) 3360 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3361 CASE (3) 3362 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3363 CASE (4) 3364 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3365 CASE (5) 3366 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3367 CASE (6) 3368 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3369 CASE (7) 3370 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3371 CASE (9) 3372 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3373 CASE (10) 3374 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3375 CASE (11) 3376 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3377 CASE (15) 3378 CALL block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3379 CASE DEFAULT 3380 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3381 END SELECT 3382 CASE (2) 3383 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3384 CASE (3) 3385 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3386 CASE (4) 3387 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3388 CASE (5) 3389 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3390 CASE (6) 3391 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3392 CASE (7) 3393 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3394 CASE (9) 3395 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3396 CASE (10) 3397 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3398 CASE (11) 3399 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3400 CASE (15) 3401 CALL block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3402 CASE DEFAULT 3403 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3404 END SELECT 3405 CASE (3) 3406 SELECT CASE (mc_max) 3407 CASE (1) 3408 SELECT CASE (md_max) 3409 CASE (1) 3410 CALL block_6_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3411 CASE (2) 3412 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3413 CASE (3) 3414 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3415 CASE (4) 3416 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3417 CASE (5) 3418 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3419 CASE (6) 3420 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3421 CASE (7) 3422 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3423 CASE (9) 3424 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3425 CASE (10) 3426 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3427 CASE (11) 3428 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3429 CASE (15) 3430 CALL block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3431 CASE DEFAULT 3432 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3433 END SELECT 3434 CASE (2) 3435 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3436 CASE (3) 3437 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3438 CASE (4) 3439 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3440 CASE (5) 3441 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3442 CASE (6) 3443 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3444 CASE (7) 3445 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3446 CASE (9) 3447 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3448 CASE (10) 3449 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3450 CASE (11) 3451 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3452 CASE (15) 3453 CALL block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3454 CASE DEFAULT 3455 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3456 END SELECT 3457 CASE (4) 3458 CALL block_6_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3459 CASE (5) 3460 CALL block_6_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3461 CASE (6) 3462 CALL block_6_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3463 CASE (7) 3464 CALL block_6_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3465 CASE (9) 3466 CALL block_6_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3467 CASE (10) 3468 CALL block_6_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3469 CASE (11) 3470 CALL block_6_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3471 CASE (15) 3472 CALL block_6_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3473 CASE DEFAULT 3474 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3475 END SELECT 3476 CASE (7) 3477 SELECT CASE (mb_max) 3478 CASE (1) 3479 SELECT CASE (mc_max) 3480 CASE (1) 3481 SELECT CASE (md_max) 3482 CASE (1) 3483 CALL block_7_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3484 CASE (2) 3485 CALL block_7_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3486 CASE (3) 3487 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3488 CASE (4) 3489 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3490 CASE (5) 3491 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3492 CASE (6) 3493 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3494 CASE (7) 3495 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3496 CASE (9) 3497 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3498 CASE (10) 3499 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3500 CASE (11) 3501 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3502 CASE (15) 3503 CALL block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3504 CASE DEFAULT 3505 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3506 END SELECT 3507 CASE (2) 3508 SELECT CASE (md_max) 3509 CASE (1) 3510 CALL block_7_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3511 CASE (2) 3512 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3513 CASE (3) 3514 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3515 CASE (4) 3516 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3517 CASE (5) 3518 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3519 CASE (6) 3520 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3521 CASE (7) 3522 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3523 CASE (9) 3524 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3525 CASE (10) 3526 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3527 CASE (11) 3528 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3529 CASE (15) 3530 CALL block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3531 CASE DEFAULT 3532 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3533 END SELECT 3534 CASE (3) 3535 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3536 CASE (4) 3537 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3538 CASE (5) 3539 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3540 CASE (6) 3541 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3542 CASE (7) 3543 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3544 CASE (9) 3545 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3546 CASE (10) 3547 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3548 CASE (11) 3549 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3550 CASE (15) 3551 CALL block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3552 CASE DEFAULT 3553 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3554 END SELECT 3555 CASE (2) 3556 SELECT CASE (mc_max) 3557 CASE (1) 3558 SELECT CASE (md_max) 3559 CASE (1) 3560 CALL block_7_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3561 CASE (2) 3562 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3563 CASE (3) 3564 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3565 CASE (4) 3566 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3567 CASE (5) 3568 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3569 CASE (6) 3570 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3571 CASE (7) 3572 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3573 CASE (9) 3574 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3575 CASE (10) 3576 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3577 CASE (11) 3578 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3579 CASE (15) 3580 CALL block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3581 CASE DEFAULT 3582 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3583 END SELECT 3584 CASE (2) 3585 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3586 CASE (3) 3587 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3588 CASE (4) 3589 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3590 CASE (5) 3591 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3592 CASE (6) 3593 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3594 CASE (7) 3595 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3596 CASE (9) 3597 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3598 CASE (10) 3599 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3600 CASE (11) 3601 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3602 CASE (15) 3603 CALL block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3604 CASE DEFAULT 3605 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3606 END SELECT 3607 CASE (3) 3608 CALL block_7_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3609 CASE (4) 3610 CALL block_7_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3611 CASE (5) 3612 CALL block_7_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3613 CASE (6) 3614 CALL block_7_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3615 CASE (7) 3616 CALL block_7_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3617 CASE (9) 3618 CALL block_7_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3619 CASE (10) 3620 CALL block_7_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3621 CASE (11) 3622 CALL block_7_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3623 CASE (15) 3624 CALL block_7_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3625 CASE DEFAULT 3626 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3627 END SELECT 3628 CASE (9) 3629 SELECT CASE (mb_max) 3630 CASE (1) 3631 SELECT CASE (mc_max) 3632 CASE (1) 3633 SELECT CASE (md_max) 3634 CASE (1) 3635 CALL block_9_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3636 CASE (2) 3637 CALL block_9_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3638 CASE (3) 3639 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3640 CASE (4) 3641 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3642 CASE (5) 3643 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3644 CASE (6) 3645 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3646 CASE (7) 3647 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3648 CASE (9) 3649 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3650 CASE (10) 3651 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3652 CASE (11) 3653 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3654 CASE (15) 3655 CALL block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3656 CASE DEFAULT 3657 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3658 END SELECT 3659 CASE (2) 3660 SELECT CASE (md_max) 3661 CASE (1) 3662 CALL block_9_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3663 CASE (2) 3664 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3665 CASE (3) 3666 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3667 CASE (4) 3668 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3669 CASE (5) 3670 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3671 CASE (6) 3672 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3673 CASE (7) 3674 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3675 CASE (9) 3676 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3677 CASE (10) 3678 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3679 CASE (11) 3680 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3681 CASE (15) 3682 CALL block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3683 CASE DEFAULT 3684 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3685 END SELECT 3686 CASE (3) 3687 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3688 CASE (4) 3689 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3690 CASE (5) 3691 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3692 CASE (6) 3693 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3694 CASE (7) 3695 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3696 CASE (9) 3697 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3698 CASE (10) 3699 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3700 CASE (11) 3701 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3702 CASE (15) 3703 CALL block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3704 CASE DEFAULT 3705 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3706 END SELECT 3707 CASE (2) 3708 SELECT CASE (mc_max) 3709 CASE (1) 3710 SELECT CASE (md_max) 3711 CASE (1) 3712 CALL block_9_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3713 CASE (2) 3714 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3715 CASE (3) 3716 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3717 CASE (4) 3718 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3719 CASE (5) 3720 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3721 CASE (6) 3722 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3723 CASE (7) 3724 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3725 CASE (9) 3726 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3727 CASE (10) 3728 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3729 CASE (11) 3730 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3731 CASE (15) 3732 CALL block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3733 CASE DEFAULT 3734 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3735 END SELECT 3736 CASE (2) 3737 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3738 CASE (3) 3739 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3740 CASE (4) 3741 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3742 CASE (5) 3743 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3744 CASE (6) 3745 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3746 CASE (7) 3747 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3748 CASE (9) 3749 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3750 CASE (10) 3751 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3752 CASE (11) 3753 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3754 CASE (15) 3755 CALL block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3756 CASE DEFAULT 3757 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3758 END SELECT 3759 CASE (3) 3760 CALL block_9_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3761 CASE (4) 3762 CALL block_9_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3763 CASE (5) 3764 CALL block_9_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3765 CASE (6) 3766 CALL block_9_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3767 CASE (7) 3768 CALL block_9_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3769 CASE (9) 3770 CALL block_9_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3771 CASE (10) 3772 CALL block_9_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3773 CASE (11) 3774 CALL block_9_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3775 CASE (15) 3776 CALL block_9_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3777 CASE DEFAULT 3778 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3779 END SELECT 3780 CASE (10) 3781 SELECT CASE (mb_max) 3782 CASE (1) 3783 SELECT CASE (mc_max) 3784 CASE (1) 3785 SELECT CASE (md_max) 3786 CASE (1) 3787 CALL block_10_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3788 CASE (2) 3789 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3790 CASE (3) 3791 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3792 CASE (4) 3793 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3794 CASE (5) 3795 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3796 CASE (6) 3797 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3798 CASE (7) 3799 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3800 CASE (9) 3801 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3802 CASE (10) 3803 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3804 CASE (11) 3805 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3806 CASE (15) 3807 CALL block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3808 CASE DEFAULT 3809 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3810 END SELECT 3811 CASE (2) 3812 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3813 CASE (3) 3814 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3815 CASE (4) 3816 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3817 CASE (5) 3818 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3819 CASE (6) 3820 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3821 CASE (7) 3822 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3823 CASE (9) 3824 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3825 CASE (10) 3826 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3827 CASE (11) 3828 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3829 CASE (15) 3830 CALL block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3831 CASE DEFAULT 3832 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3833 END SELECT 3834 CASE (2) 3835 CALL block_10_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3836 CASE (3) 3837 CALL block_10_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3838 CASE (4) 3839 CALL block_10_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3840 CASE (5) 3841 CALL block_10_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3842 CASE (6) 3843 CALL block_10_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3844 CASE (7) 3845 CALL block_10_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3846 CASE (9) 3847 CALL block_10_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3848 CASE (10) 3849 CALL block_10_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3850 CASE (11) 3851 CALL block_10_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3852 CASE (15) 3853 CALL block_10_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3854 CASE DEFAULT 3855 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3856 END SELECT 3857 CASE (11) 3858 SELECT CASE (mb_max) 3859 CASE (1) 3860 SELECT CASE (mc_max) 3861 CASE (1) 3862 SELECT CASE (md_max) 3863 CASE (1) 3864 CALL block_11_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3865 CASE (2) 3866 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3867 CASE (3) 3868 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3869 CASE (4) 3870 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3871 CASE (5) 3872 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3873 CASE (6) 3874 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3875 CASE (7) 3876 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3877 CASE (9) 3878 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3879 CASE (10) 3880 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3881 CASE (11) 3882 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3883 CASE (15) 3884 CALL block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3885 CASE DEFAULT 3886 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3887 END SELECT 3888 CASE (2) 3889 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3890 CASE (3) 3891 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3892 CASE (4) 3893 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3894 CASE (5) 3895 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3896 CASE (6) 3897 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3898 CASE (7) 3899 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3900 CASE (9) 3901 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3902 CASE (10) 3903 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3904 CASE (11) 3905 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3906 CASE (15) 3907 CALL block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3908 CASE DEFAULT 3909 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3910 END SELECT 3911 CASE (2) 3912 CALL block_11_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3913 CASE (3) 3914 CALL block_11_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3915 CASE (4) 3916 CALL block_11_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3917 CASE (5) 3918 CALL block_11_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3919 CASE (6) 3920 CALL block_11_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3921 CASE (7) 3922 CALL block_11_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3923 CASE (9) 3924 CALL block_11_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3925 CASE (10) 3926 CALL block_11_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3927 CASE (11) 3928 CALL block_11_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3929 CASE (15) 3930 CALL block_11_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3931 CASE DEFAULT 3932 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3933 END SELECT 3934 CASE (15) 3935 SELECT CASE (mb_max) 3936 CASE (1) 3937 SELECT CASE (mc_max) 3938 CASE (1) 3939 SELECT CASE (md_max) 3940 CASE (1) 3941 CALL block_15_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3942 CASE (2) 3943 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3944 CASE (3) 3945 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3946 CASE (4) 3947 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3948 CASE (5) 3949 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3950 CASE (6) 3951 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3952 CASE (7) 3953 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3954 CASE (9) 3955 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3956 CASE (10) 3957 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3958 CASE (11) 3959 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3960 CASE (15) 3961 CALL block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3962 CASE DEFAULT 3963 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3964 END SELECT 3965 CASE (2) 3966 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3967 CASE (3) 3968 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3969 CASE (4) 3970 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3971 CASE (5) 3972 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3973 CASE (6) 3974 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3975 CASE (7) 3976 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3977 CASE (9) 3978 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3979 CASE (10) 3980 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3981 CASE (11) 3982 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3983 CASE (15) 3984 CALL block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3985 CASE DEFAULT 3986 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3987 END SELECT 3988 CASE (2) 3989 CALL block_15_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3990 CASE (3) 3991 CALL block_15_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3992 CASE (4) 3993 CALL block_15_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3994 CASE (5) 3995 CALL block_15_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3996 CASE (6) 3997 CALL block_15_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 3998 CASE (7) 3999 CALL block_15_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4000 CASE (9) 4001 CALL block_15_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4002 CASE (10) 4003 CALL block_15_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4004 CASE (11) 4005 CALL block_15_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4006 CASE (15) 4007 CALL block_15_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4008 CASE DEFAULT 4009 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4010 END SELECT 4011 CASE DEFAULT 4012 CALL block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4013 END SELECT 4014#endif 4015 END SUBROUTINE contract_block 4016 4017#if defined (__LIBINT) 4018! ************************************************************************************************** 4019!> \brief ... 4020!> \param ma_max ... 4021!> \param mb_max ... 4022!> \param mc_max ... 4023!> \param md_max ... 4024!> \param kbd ... 4025!> \param kbc ... 4026!> \param kad ... 4027!> \param kac ... 4028!> \param pbd ... 4029!> \param pbc ... 4030!> \param pad ... 4031!> \param pac ... 4032!> \param prim ... 4033!> \param scale ... 4034! ************************************************************************************************** 4035 SUBROUTINE block_default(ma_max, mb_max, mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4036 INTEGER :: ma_max, mb_max, mc_max, md_max 4037 REAL(KIND=dp) :: kbd(mb_max*md_max), kbc(mb_max*mc_max), kad(ma_max*md_max), & 4038 kac(ma_max*mc_max), pbd(mb_max*md_max), pbc(mb_max*mc_max), pad(ma_max*md_max), & 4039 pac(ma_max*mc_max), prim(ma_max*mb_max*mc_max*md_max), scale 4040 4041 INTEGER :: ma, mb, mc, md, p_index 4042 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4043 4044 kbd(1:mb_max*md_max) = 0.0_dp 4045 kbc(1:mb_max*mc_max) = 0.0_dp 4046 kad(1:ma_max*md_max) = 0.0_dp 4047 kac(1:ma_max*mc_max) = 0.0_dp 4048 p_index = 0 4049 DO md = 1, md_max 4050 DO mc = 1, mc_max 4051 DO mb = 1, mb_max 4052 ks_bd = 0.0_dp 4053 ks_bc = 0.0_dp 4054 p_bd = pbd((md - 1)*mb_max + mb) 4055 p_bc = pbc((mc - 1)*mb_max + mb) 4056 DO ma = 1, ma_max 4057 p_index = p_index + 1 4058 tmp = scale*prim(p_index) 4059 ks_bc = ks_bc + tmp*pad((md - 1)*ma_max + ma) 4060 ks_bd = ks_bd + tmp*pac((mc - 1)*ma_max + ma) 4061 kad((md - 1)*ma_max + ma) = kad((md - 1)*ma_max + ma) - tmp*p_bc 4062 kac((mc - 1)*ma_max + ma) = kac((mc - 1)*ma_max + ma) - tmp*p_bd 4063 END DO 4064 kbd((md - 1)*mb_max + mb) = kbd((md - 1)*mb_max + mb) - ks_bd 4065 kbc((mc - 1)*mb_max + mb) = kbc((mc - 1)*mb_max + mb) - ks_bc 4066 END DO 4067 END DO 4068 END DO 4069 END SUBROUTINE block_default 4070! ************************************************************************************************** 4071!> \brief ... 4072!> \param kbd ... 4073!> \param kbc ... 4074!> \param kad ... 4075!> \param kac ... 4076!> \param pbd ... 4077!> \param pbc ... 4078!> \param pad ... 4079!> \param pac ... 4080!> \param prim ... 4081!> \param scale ... 4082! ************************************************************************************************** 4083 SUBROUTINE block_1_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4084 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(1*1), kac(1*1), & 4085 pbd(1*1), pbc(1*1), pad(1*1), & 4086 pac(1*1), prim(1*1*1*1), scale 4087 4088 INTEGER :: ma, mb, mc, md, p_index 4089 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4090 4091 kbd(1:1*1) = 0.0_dp 4092 kbc(1:1*1) = 0.0_dp 4093 kad(1:1*1) = 0.0_dp 4094 kac(1:1*1) = 0.0_dp 4095 p_index = 0 4096 DO md = 1, 1 4097 DO mc = 1, 1 4098 DO mb = 1, 1 4099 ks_bd = 0.0_dp 4100 ks_bc = 0.0_dp 4101 p_bd = pbd((md - 1)*1 + mb) 4102 p_bc = pbc((mc - 1)*1 + mb) 4103 DO ma = 1, 1 4104 p_index = p_index + 1 4105 tmp = scale*prim(p_index) 4106 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4107 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4108 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4109 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4110 END DO 4111 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4112 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4113 END DO 4114 END DO 4115 END DO 4116 END SUBROUTINE block_1_1_1_1 4117! ************************************************************************************************** 4118!> \brief ... 4119!> \param kbd ... 4120!> \param kbc ... 4121!> \param kad ... 4122!> \param kac ... 4123!> \param pbd ... 4124!> \param pbc ... 4125!> \param pad ... 4126!> \param pac ... 4127!> \param prim ... 4128!> \param scale ... 4129! ************************************************************************************************** 4130 SUBROUTINE block_1_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4131 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(1*2), kac(1*1), & 4132 pbd(1*2), pbc(1*1), pad(1*2), & 4133 pac(1*1), prim(1*1*1*2), scale 4134 4135 INTEGER :: ma, mb, mc, md, p_index 4136 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4137 4138 kbd(1:1*2) = 0.0_dp 4139 kbc(1:1*1) = 0.0_dp 4140 kad(1:1*2) = 0.0_dp 4141 kac(1:1*1) = 0.0_dp 4142 p_index = 0 4143 DO md = 1, 2 4144 DO mc = 1, 1 4145 DO mb = 1, 1 4146 ks_bd = 0.0_dp 4147 ks_bc = 0.0_dp 4148 p_bd = pbd((md - 1)*1 + mb) 4149 p_bc = pbc((mc - 1)*1 + mb) 4150 DO ma = 1, 1 4151 p_index = p_index + 1 4152 tmp = scale*prim(p_index) 4153 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4154 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4155 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4156 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4157 END DO 4158 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4159 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4160 END DO 4161 END DO 4162 END DO 4163 END SUBROUTINE block_1_1_1_2 4164! ************************************************************************************************** 4165!> \brief ... 4166!> \param kbd ... 4167!> \param kbc ... 4168!> \param kad ... 4169!> \param kac ... 4170!> \param pbd ... 4171!> \param pbc ... 4172!> \param pad ... 4173!> \param pac ... 4174!> \param prim ... 4175!> \param scale ... 4176! ************************************************************************************************** 4177 SUBROUTINE block_1_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4178 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(1*3), kac(1*1), & 4179 pbd(1*3), pbc(1*1), pad(1*3), & 4180 pac(1*1), prim(1*1*1*3), scale 4181 4182 INTEGER :: ma, mb, mc, md, p_index 4183 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4184 4185 kbd(1:1*3) = 0.0_dp 4186 kbc(1:1*1) = 0.0_dp 4187 kad(1:1*3) = 0.0_dp 4188 kac(1:1*1) = 0.0_dp 4189 p_index = 0 4190 DO md = 1, 3 4191 DO mc = 1, 1 4192 DO mb = 1, 1 4193 ks_bd = 0.0_dp 4194 ks_bc = 0.0_dp 4195 p_bd = pbd((md - 1)*1 + mb) 4196 p_bc = pbc((mc - 1)*1 + mb) 4197 DO ma = 1, 1 4198 p_index = p_index + 1 4199 tmp = scale*prim(p_index) 4200 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4201 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4202 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4203 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4204 END DO 4205 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4206 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4207 END DO 4208 END DO 4209 END DO 4210 END SUBROUTINE block_1_1_1_3 4211! ************************************************************************************************** 4212!> \brief ... 4213!> \param kbd ... 4214!> \param kbc ... 4215!> \param kad ... 4216!> \param kac ... 4217!> \param pbd ... 4218!> \param pbc ... 4219!> \param pad ... 4220!> \param pac ... 4221!> \param prim ... 4222!> \param scale ... 4223! ************************************************************************************************** 4224 SUBROUTINE block_1_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4225 REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(1*4), kac(1*1), & 4226 pbd(1*4), pbc(1*1), pad(1*4), & 4227 pac(1*1), prim(1*1*1*4), scale 4228 4229 INTEGER :: ma, mb, mc, md, p_index 4230 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4231 4232 kbd(1:1*4) = 0.0_dp 4233 kbc(1:1*1) = 0.0_dp 4234 kad(1:1*4) = 0.0_dp 4235 kac(1:1*1) = 0.0_dp 4236 p_index = 0 4237 DO md = 1, 4 4238 DO mc = 1, 1 4239 DO mb = 1, 1 4240 ks_bd = 0.0_dp 4241 ks_bc = 0.0_dp 4242 p_bd = pbd((md - 1)*1 + mb) 4243 p_bc = pbc((mc - 1)*1 + mb) 4244 DO ma = 1, 1 4245 p_index = p_index + 1 4246 tmp = scale*prim(p_index) 4247 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4248 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4249 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4250 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4251 END DO 4252 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4253 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4254 END DO 4255 END DO 4256 END DO 4257 END SUBROUTINE block_1_1_1_4 4258! ************************************************************************************************** 4259!> \brief ... 4260!> \param kbd ... 4261!> \param kbc ... 4262!> \param kad ... 4263!> \param kac ... 4264!> \param pbd ... 4265!> \param pbc ... 4266!> \param pad ... 4267!> \param pac ... 4268!> \param prim ... 4269!> \param scale ... 4270! ************************************************************************************************** 4271 SUBROUTINE block_1_1_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4272 REAL(KIND=dp) :: kbd(1*5), kbc(1*1), kad(1*5), kac(1*1), & 4273 pbd(1*5), pbc(1*1), pad(1*5), & 4274 pac(1*1), prim(1*1*1*5), scale 4275 4276 INTEGER :: ma, mb, mc, md, p_index 4277 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4278 4279 kbd(1:1*5) = 0.0_dp 4280 kbc(1:1*1) = 0.0_dp 4281 kad(1:1*5) = 0.0_dp 4282 kac(1:1*1) = 0.0_dp 4283 p_index = 0 4284 DO md = 1, 5 4285 DO mc = 1, 1 4286 DO mb = 1, 1 4287 ks_bd = 0.0_dp 4288 ks_bc = 0.0_dp 4289 p_bd = pbd((md - 1)*1 + mb) 4290 p_bc = pbc((mc - 1)*1 + mb) 4291 DO ma = 1, 1 4292 p_index = p_index + 1 4293 tmp = scale*prim(p_index) 4294 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4295 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4296 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4297 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4298 END DO 4299 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4300 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4301 END DO 4302 END DO 4303 END DO 4304 END SUBROUTINE block_1_1_1_5 4305! ************************************************************************************************** 4306!> \brief ... 4307!> \param kbd ... 4308!> \param kbc ... 4309!> \param kad ... 4310!> \param kac ... 4311!> \param pbd ... 4312!> \param pbc ... 4313!> \param pad ... 4314!> \param pac ... 4315!> \param prim ... 4316!> \param scale ... 4317! ************************************************************************************************** 4318 SUBROUTINE block_1_1_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4319 REAL(KIND=dp) :: kbd(1*6), kbc(1*1), kad(1*6), kac(1*1), & 4320 pbd(1*6), pbc(1*1), pad(1*6), & 4321 pac(1*1), prim(1*1*1*6), scale 4322 4323 INTEGER :: ma, mb, mc, md, p_index 4324 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4325 4326 kbd(1:1*6) = 0.0_dp 4327 kbc(1:1*1) = 0.0_dp 4328 kad(1:1*6) = 0.0_dp 4329 kac(1:1*1) = 0.0_dp 4330 p_index = 0 4331 DO md = 1, 6 4332 DO mc = 1, 1 4333 DO mb = 1, 1 4334 ks_bd = 0.0_dp 4335 ks_bc = 0.0_dp 4336 p_bd = pbd((md - 1)*1 + mb) 4337 p_bc = pbc((mc - 1)*1 + mb) 4338 DO ma = 1, 1 4339 p_index = p_index + 1 4340 tmp = scale*prim(p_index) 4341 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4342 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4343 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4344 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4345 END DO 4346 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4347 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4348 END DO 4349 END DO 4350 END DO 4351 END SUBROUTINE block_1_1_1_6 4352! ************************************************************************************************** 4353!> \brief ... 4354!> \param kbd ... 4355!> \param kbc ... 4356!> \param kad ... 4357!> \param kac ... 4358!> \param pbd ... 4359!> \param pbc ... 4360!> \param pad ... 4361!> \param pac ... 4362!> \param prim ... 4363!> \param scale ... 4364! ************************************************************************************************** 4365 SUBROUTINE block_1_1_1_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4366 REAL(KIND=dp) :: kbd(1*7), kbc(1*1), kad(1*7), kac(1*1), & 4367 pbd(1*7), pbc(1*1), pad(1*7), & 4368 pac(1*1), prim(1*1*1*7), scale 4369 4370 INTEGER :: ma, mb, mc, md, p_index 4371 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4372 4373 kbd(1:1*7) = 0.0_dp 4374 kbc(1:1*1) = 0.0_dp 4375 kad(1:1*7) = 0.0_dp 4376 kac(1:1*1) = 0.0_dp 4377 p_index = 0 4378 DO md = 1, 7 4379 DO mc = 1, 1 4380 DO mb = 1, 1 4381 ks_bd = 0.0_dp 4382 ks_bc = 0.0_dp 4383 p_bd = pbd((md - 1)*1 + mb) 4384 p_bc = pbc((mc - 1)*1 + mb) 4385 DO ma = 1, 1 4386 p_index = p_index + 1 4387 tmp = scale*prim(p_index) 4388 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4389 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4390 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4391 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4392 END DO 4393 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4394 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4395 END DO 4396 END DO 4397 END DO 4398 END SUBROUTINE block_1_1_1_7 4399! ************************************************************************************************** 4400!> \brief ... 4401!> \param kbd ... 4402!> \param kbc ... 4403!> \param kad ... 4404!> \param kac ... 4405!> \param pbd ... 4406!> \param pbc ... 4407!> \param pad ... 4408!> \param pac ... 4409!> \param prim ... 4410!> \param scale ... 4411! ************************************************************************************************** 4412 SUBROUTINE block_1_1_1_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4413 REAL(KIND=dp) :: kbd(1*9), kbc(1*1), kad(1*9), kac(1*1), & 4414 pbd(1*9), pbc(1*1), pad(1*9), & 4415 pac(1*1), prim(1*1*1*9), scale 4416 4417 INTEGER :: ma, mb, mc, md, p_index 4418 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4419 4420 kbd(1:1*9) = 0.0_dp 4421 kbc(1:1*1) = 0.0_dp 4422 kad(1:1*9) = 0.0_dp 4423 kac(1:1*1) = 0.0_dp 4424 p_index = 0 4425 DO md = 1, 9 4426 DO mc = 1, 1 4427 DO mb = 1, 1 4428 ks_bd = 0.0_dp 4429 ks_bc = 0.0_dp 4430 p_bd = pbd((md - 1)*1 + mb) 4431 p_bc = pbc((mc - 1)*1 + mb) 4432 DO ma = 1, 1 4433 p_index = p_index + 1 4434 tmp = scale*prim(p_index) 4435 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4436 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4437 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4438 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4439 END DO 4440 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4441 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4442 END DO 4443 END DO 4444 END DO 4445 END SUBROUTINE block_1_1_1_9 4446! ************************************************************************************************** 4447!> \brief ... 4448!> \param kbd ... 4449!> \param kbc ... 4450!> \param kad ... 4451!> \param kac ... 4452!> \param pbd ... 4453!> \param pbc ... 4454!> \param pad ... 4455!> \param pac ... 4456!> \param prim ... 4457!> \param scale ... 4458! ************************************************************************************************** 4459 SUBROUTINE block_1_1_1_10(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4460 REAL(KIND=dp) :: kbd(1*10), kbc(1*1), kad(1*10), & 4461 kac(1*1), pbd(1*10), pbc(1*1), & 4462 pad(1*10), pac(1*1), prim(1*1*1*10), & 4463 scale 4464 4465 INTEGER :: ma, mb, mc, md, p_index 4466 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4467 4468 kbd(1:1*10) = 0.0_dp 4469 kbc(1:1*1) = 0.0_dp 4470 kad(1:1*10) = 0.0_dp 4471 kac(1:1*1) = 0.0_dp 4472 p_index = 0 4473 DO md = 1, 10 4474 DO mc = 1, 1 4475 DO mb = 1, 1 4476 ks_bd = 0.0_dp 4477 ks_bc = 0.0_dp 4478 p_bd = pbd((md - 1)*1 + mb) 4479 p_bc = pbc((mc - 1)*1 + mb) 4480 DO ma = 1, 1 4481 p_index = p_index + 1 4482 tmp = scale*prim(p_index) 4483 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4484 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4485 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4486 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4487 END DO 4488 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4489 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4490 END DO 4491 END DO 4492 END DO 4493 END SUBROUTINE block_1_1_1_10 4494! ************************************************************************************************** 4495!> \brief ... 4496!> \param kbd ... 4497!> \param kbc ... 4498!> \param kad ... 4499!> \param kac ... 4500!> \param pbd ... 4501!> \param pbc ... 4502!> \param pad ... 4503!> \param pac ... 4504!> \param prim ... 4505!> \param scale ... 4506! ************************************************************************************************** 4507 SUBROUTINE block_1_1_1_11(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4508 REAL(KIND=dp) :: kbd(1*11), kbc(1*1), kad(1*11), & 4509 kac(1*1), pbd(1*11), pbc(1*1), & 4510 pad(1*11), pac(1*1), prim(1*1*1*11), & 4511 scale 4512 4513 INTEGER :: ma, mb, mc, md, p_index 4514 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4515 4516 kbd(1:1*11) = 0.0_dp 4517 kbc(1:1*1) = 0.0_dp 4518 kad(1:1*11) = 0.0_dp 4519 kac(1:1*1) = 0.0_dp 4520 p_index = 0 4521 DO md = 1, 11 4522 DO mc = 1, 1 4523 DO mb = 1, 1 4524 ks_bd = 0.0_dp 4525 ks_bc = 0.0_dp 4526 p_bd = pbd((md - 1)*1 + mb) 4527 p_bc = pbc((mc - 1)*1 + mb) 4528 DO ma = 1, 1 4529 p_index = p_index + 1 4530 tmp = scale*prim(p_index) 4531 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4532 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4533 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4534 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4535 END DO 4536 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4537 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4538 END DO 4539 END DO 4540 END DO 4541 END SUBROUTINE block_1_1_1_11 4542! ************************************************************************************************** 4543!> \brief ... 4544!> \param kbd ... 4545!> \param kbc ... 4546!> \param kad ... 4547!> \param kac ... 4548!> \param pbd ... 4549!> \param pbc ... 4550!> \param pad ... 4551!> \param pac ... 4552!> \param prim ... 4553!> \param scale ... 4554! ************************************************************************************************** 4555 SUBROUTINE block_1_1_1_15(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4556 REAL(KIND=dp) :: kbd(1*15), kbc(1*1), kad(1*15), & 4557 kac(1*1), pbd(1*15), pbc(1*1), & 4558 pad(1*15), pac(1*1), prim(1*1*1*15), & 4559 scale 4560 4561 INTEGER :: ma, mb, mc, md, p_index 4562 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4563 4564 kbd(1:1*15) = 0.0_dp 4565 kbc(1:1*1) = 0.0_dp 4566 kad(1:1*15) = 0.0_dp 4567 kac(1:1*1) = 0.0_dp 4568 p_index = 0 4569 DO md = 1, 15 4570 DO mc = 1, 1 4571 DO mb = 1, 1 4572 ks_bd = 0.0_dp 4573 ks_bc = 0.0_dp 4574 p_bd = pbd((md - 1)*1 + mb) 4575 p_bc = pbc((mc - 1)*1 + mb) 4576 DO ma = 1, 1 4577 p_index = p_index + 1 4578 tmp = scale*prim(p_index) 4579 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4580 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4581 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4582 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4583 END DO 4584 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4585 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4586 END DO 4587 END DO 4588 END DO 4589 END SUBROUTINE block_1_1_1_15 4590! ************************************************************************************************** 4591!> \brief ... 4592!> \param kbd ... 4593!> \param kbc ... 4594!> \param kad ... 4595!> \param kac ... 4596!> \param pbd ... 4597!> \param pbc ... 4598!> \param pad ... 4599!> \param pac ... 4600!> \param prim ... 4601!> \param scale ... 4602! ************************************************************************************************** 4603 SUBROUTINE block_1_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4604 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(1*1), kac(1*2), & 4605 pbd(1*1), pbc(1*2), pad(1*1), & 4606 pac(1*2), prim(1*1*2*1), scale 4607 4608 INTEGER :: ma, mb, mc, md, p_index 4609 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4610 4611 kbd(1:1*1) = 0.0_dp 4612 kbc(1:1*2) = 0.0_dp 4613 kad(1:1*1) = 0.0_dp 4614 kac(1:1*2) = 0.0_dp 4615 p_index = 0 4616 DO md = 1, 1 4617 DO mc = 1, 2 4618 DO mb = 1, 1 4619 ks_bd = 0.0_dp 4620 ks_bc = 0.0_dp 4621 p_bd = pbd((md - 1)*1 + mb) 4622 p_bc = pbc((mc - 1)*1 + mb) 4623 DO ma = 1, 1 4624 p_index = p_index + 1 4625 tmp = scale*prim(p_index) 4626 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4627 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4628 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4629 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4630 END DO 4631 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4632 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4633 END DO 4634 END DO 4635 END DO 4636 END SUBROUTINE block_1_1_2_1 4637! ************************************************************************************************** 4638!> \brief ... 4639!> \param kbd ... 4640!> \param kbc ... 4641!> \param kad ... 4642!> \param kac ... 4643!> \param pbd ... 4644!> \param pbc ... 4645!> \param pad ... 4646!> \param pac ... 4647!> \param prim ... 4648!> \param scale ... 4649! ************************************************************************************************** 4650 SUBROUTINE block_1_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4651 REAL(KIND=dp) :: kbd(1*2), kbc(1*2), kad(1*2), kac(1*2), & 4652 pbd(1*2), pbc(1*2), pad(1*2), & 4653 pac(1*2), prim(1*1*2*2), scale 4654 4655 INTEGER :: ma, mb, mc, md, p_index 4656 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4657 4658 kbd(1:1*2) = 0.0_dp 4659 kbc(1:1*2) = 0.0_dp 4660 kad(1:1*2) = 0.0_dp 4661 kac(1:1*2) = 0.0_dp 4662 p_index = 0 4663 DO md = 1, 2 4664 DO mc = 1, 2 4665 DO mb = 1, 1 4666 ks_bd = 0.0_dp 4667 ks_bc = 0.0_dp 4668 p_bd = pbd((md - 1)*1 + mb) 4669 p_bc = pbc((mc - 1)*1 + mb) 4670 DO ma = 1, 1 4671 p_index = p_index + 1 4672 tmp = scale*prim(p_index) 4673 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4674 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4675 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4676 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4677 END DO 4678 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4679 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4680 END DO 4681 END DO 4682 END DO 4683 END SUBROUTINE block_1_1_2_2 4684! ************************************************************************************************** 4685!> \brief ... 4686!> \param kbd ... 4687!> \param kbc ... 4688!> \param kad ... 4689!> \param kac ... 4690!> \param pbd ... 4691!> \param pbc ... 4692!> \param pad ... 4693!> \param pac ... 4694!> \param prim ... 4695!> \param scale ... 4696! ************************************************************************************************** 4697 SUBROUTINE block_1_1_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4698 REAL(KIND=dp) :: kbd(1*3), kbc(1*2), kad(1*3), kac(1*2), & 4699 pbd(1*3), pbc(1*2), pad(1*3), & 4700 pac(1*2), prim(1*1*2*3), scale 4701 4702 INTEGER :: ma, mb, mc, md, p_index 4703 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4704 4705 kbd(1:1*3) = 0.0_dp 4706 kbc(1:1*2) = 0.0_dp 4707 kad(1:1*3) = 0.0_dp 4708 kac(1:1*2) = 0.0_dp 4709 p_index = 0 4710 DO md = 1, 3 4711 DO mc = 1, 2 4712 DO mb = 1, 1 4713 ks_bd = 0.0_dp 4714 ks_bc = 0.0_dp 4715 p_bd = pbd((md - 1)*1 + mb) 4716 p_bc = pbc((mc - 1)*1 + mb) 4717 DO ma = 1, 1 4718 p_index = p_index + 1 4719 tmp = scale*prim(p_index) 4720 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4721 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4722 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4723 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4724 END DO 4725 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4726 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4727 END DO 4728 END DO 4729 END DO 4730 END SUBROUTINE block_1_1_2_3 4731! ************************************************************************************************** 4732!> \brief ... 4733!> \param kbd ... 4734!> \param kbc ... 4735!> \param kad ... 4736!> \param kac ... 4737!> \param pbd ... 4738!> \param pbc ... 4739!> \param pad ... 4740!> \param pac ... 4741!> \param prim ... 4742!> \param scale ... 4743! ************************************************************************************************** 4744 SUBROUTINE block_1_1_2_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4745 REAL(KIND=dp) :: kbd(1*4), kbc(1*2), kad(1*4), kac(1*2), & 4746 pbd(1*4), pbc(1*2), pad(1*4), & 4747 pac(1*2), prim(1*1*2*4), scale 4748 4749 INTEGER :: ma, mb, mc, md, p_index 4750 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4751 4752 kbd(1:1*4) = 0.0_dp 4753 kbc(1:1*2) = 0.0_dp 4754 kad(1:1*4) = 0.0_dp 4755 kac(1:1*2) = 0.0_dp 4756 p_index = 0 4757 DO md = 1, 4 4758 DO mc = 1, 2 4759 DO mb = 1, 1 4760 ks_bd = 0.0_dp 4761 ks_bc = 0.0_dp 4762 p_bd = pbd((md - 1)*1 + mb) 4763 p_bc = pbc((mc - 1)*1 + mb) 4764 DO ma = 1, 1 4765 p_index = p_index + 1 4766 tmp = scale*prim(p_index) 4767 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4768 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4769 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4770 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4771 END DO 4772 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4773 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4774 END DO 4775 END DO 4776 END DO 4777 END SUBROUTINE block_1_1_2_4 4778! ************************************************************************************************** 4779!> \brief ... 4780!> \param kbd ... 4781!> \param kbc ... 4782!> \param kad ... 4783!> \param kac ... 4784!> \param pbd ... 4785!> \param pbc ... 4786!> \param pad ... 4787!> \param pac ... 4788!> \param prim ... 4789!> \param scale ... 4790! ************************************************************************************************** 4791 SUBROUTINE block_1_1_2_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4792 REAL(KIND=dp) :: kbd(1*5), kbc(1*2), kad(1*5), kac(1*2), & 4793 pbd(1*5), pbc(1*2), pad(1*5), & 4794 pac(1*2), prim(1*1*2*5), scale 4795 4796 INTEGER :: ma, mb, mc, md, p_index 4797 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4798 4799 kbd(1:1*5) = 0.0_dp 4800 kbc(1:1*2) = 0.0_dp 4801 kad(1:1*5) = 0.0_dp 4802 kac(1:1*2) = 0.0_dp 4803 p_index = 0 4804 DO md = 1, 5 4805 DO mc = 1, 2 4806 DO mb = 1, 1 4807 ks_bd = 0.0_dp 4808 ks_bc = 0.0_dp 4809 p_bd = pbd((md - 1)*1 + mb) 4810 p_bc = pbc((mc - 1)*1 + mb) 4811 DO ma = 1, 1 4812 p_index = p_index + 1 4813 tmp = scale*prim(p_index) 4814 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4815 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4816 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4817 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4818 END DO 4819 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4820 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4821 END DO 4822 END DO 4823 END DO 4824 END SUBROUTINE block_1_1_2_5 4825! ************************************************************************************************** 4826!> \brief ... 4827!> \param kbd ... 4828!> \param kbc ... 4829!> \param kad ... 4830!> \param kac ... 4831!> \param pbd ... 4832!> \param pbc ... 4833!> \param pad ... 4834!> \param pac ... 4835!> \param prim ... 4836!> \param scale ... 4837! ************************************************************************************************** 4838 SUBROUTINE block_1_1_2_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4839 REAL(KIND=dp) :: kbd(1*6), kbc(1*2), kad(1*6), kac(1*2), & 4840 pbd(1*6), pbc(1*2), pad(1*6), & 4841 pac(1*2), prim(1*1*2*6), scale 4842 4843 INTEGER :: ma, mb, mc, md, p_index 4844 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4845 4846 kbd(1:1*6) = 0.0_dp 4847 kbc(1:1*2) = 0.0_dp 4848 kad(1:1*6) = 0.0_dp 4849 kac(1:1*2) = 0.0_dp 4850 p_index = 0 4851 DO md = 1, 6 4852 DO mc = 1, 2 4853 DO mb = 1, 1 4854 ks_bd = 0.0_dp 4855 ks_bc = 0.0_dp 4856 p_bd = pbd((md - 1)*1 + mb) 4857 p_bc = pbc((mc - 1)*1 + mb) 4858 DO ma = 1, 1 4859 p_index = p_index + 1 4860 tmp = scale*prim(p_index) 4861 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4862 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4863 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4864 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4865 END DO 4866 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4867 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4868 END DO 4869 END DO 4870 END DO 4871 END SUBROUTINE block_1_1_2_6 4872! ************************************************************************************************** 4873!> \brief ... 4874!> \param kbd ... 4875!> \param kbc ... 4876!> \param kad ... 4877!> \param kac ... 4878!> \param pbd ... 4879!> \param pbc ... 4880!> \param pad ... 4881!> \param pac ... 4882!> \param prim ... 4883!> \param scale ... 4884! ************************************************************************************************** 4885 SUBROUTINE block_1_1_2_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4886 REAL(KIND=dp) :: kbd(1*7), kbc(1*2), kad(1*7), kac(1*2), & 4887 pbd(1*7), pbc(1*2), pad(1*7), & 4888 pac(1*2), prim(1*1*2*7), scale 4889 4890 INTEGER :: ma, mb, mc, md, p_index 4891 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4892 4893 kbd(1:1*7) = 0.0_dp 4894 kbc(1:1*2) = 0.0_dp 4895 kad(1:1*7) = 0.0_dp 4896 kac(1:1*2) = 0.0_dp 4897 p_index = 0 4898 DO md = 1, 7 4899 DO mc = 1, 2 4900 DO mb = 1, 1 4901 ks_bd = 0.0_dp 4902 ks_bc = 0.0_dp 4903 p_bd = pbd((md - 1)*1 + mb) 4904 p_bc = pbc((mc - 1)*1 + mb) 4905 DO ma = 1, 1 4906 p_index = p_index + 1 4907 tmp = scale*prim(p_index) 4908 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4909 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4910 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4911 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4912 END DO 4913 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4914 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4915 END DO 4916 END DO 4917 END DO 4918 END SUBROUTINE block_1_1_2_7 4919! ************************************************************************************************** 4920!> \brief ... 4921!> \param kbd ... 4922!> \param kbc ... 4923!> \param kad ... 4924!> \param kac ... 4925!> \param pbd ... 4926!> \param pbc ... 4927!> \param pad ... 4928!> \param pac ... 4929!> \param prim ... 4930!> \param scale ... 4931! ************************************************************************************************** 4932 SUBROUTINE block_1_1_2_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4933 REAL(KIND=dp) :: kbd(1*9), kbc(1*2), kad(1*9), kac(1*2), & 4934 pbd(1*9), pbc(1*2), pad(1*9), & 4935 pac(1*2), prim(1*1*2*9), scale 4936 4937 INTEGER :: ma, mb, mc, md, p_index 4938 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4939 4940 kbd(1:1*9) = 0.0_dp 4941 kbc(1:1*2) = 0.0_dp 4942 kad(1:1*9) = 0.0_dp 4943 kac(1:1*2) = 0.0_dp 4944 p_index = 0 4945 DO md = 1, 9 4946 DO mc = 1, 2 4947 DO mb = 1, 1 4948 ks_bd = 0.0_dp 4949 ks_bc = 0.0_dp 4950 p_bd = pbd((md - 1)*1 + mb) 4951 p_bc = pbc((mc - 1)*1 + mb) 4952 DO ma = 1, 1 4953 p_index = p_index + 1 4954 tmp = scale*prim(p_index) 4955 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 4956 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 4957 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 4958 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 4959 END DO 4960 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 4961 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 4962 END DO 4963 END DO 4964 END DO 4965 END SUBROUTINE block_1_1_2_9 4966! ************************************************************************************************** 4967!> \brief ... 4968!> \param md_max ... 4969!> \param kbd ... 4970!> \param kbc ... 4971!> \param kad ... 4972!> \param kac ... 4973!> \param pbd ... 4974!> \param pbc ... 4975!> \param pad ... 4976!> \param pac ... 4977!> \param prim ... 4978!> \param scale ... 4979! ************************************************************************************************** 4980 SUBROUTINE block_1_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 4981 INTEGER :: md_max 4982 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(1*md_max), kac(1*2), pbd(1*md_max), pbc(1*2), & 4983 pad(1*md_max), pac(1*2), prim(1*1*2*md_max), scale 4984 4985 INTEGER :: ma, mb, mc, md, p_index 4986 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 4987 4988 kbd(1:1*md_max) = 0.0_dp 4989 kbc(1:1*2) = 0.0_dp 4990 kad(1:1*md_max) = 0.0_dp 4991 kac(1:1*2) = 0.0_dp 4992 p_index = 0 4993 DO md = 1, md_max 4994 DO mc = 1, 2 4995 DO mb = 1, 1 4996 ks_bd = 0.0_dp 4997 ks_bc = 0.0_dp 4998 p_bd = pbd((md - 1)*1 + mb) 4999 p_bc = pbc((mc - 1)*1 + mb) 5000 DO ma = 1, 1 5001 p_index = p_index + 1 5002 tmp = scale*prim(p_index) 5003 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5004 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5005 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5006 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5007 END DO 5008 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5009 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5010 END DO 5011 END DO 5012 END DO 5013 END SUBROUTINE block_1_1_2 5014! ************************************************************************************************** 5015!> \brief ... 5016!> \param kbd ... 5017!> \param kbc ... 5018!> \param kad ... 5019!> \param kac ... 5020!> \param pbd ... 5021!> \param pbc ... 5022!> \param pad ... 5023!> \param pac ... 5024!> \param prim ... 5025!> \param scale ... 5026! ************************************************************************************************** 5027 SUBROUTINE block_1_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5028 REAL(KIND=dp) :: kbd(1*1), kbc(1*3), kad(1*1), kac(1*3), & 5029 pbd(1*1), pbc(1*3), pad(1*1), & 5030 pac(1*3), prim(1*1*3*1), scale 5031 5032 INTEGER :: ma, mb, mc, md, p_index 5033 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5034 5035 kbd(1:1*1) = 0.0_dp 5036 kbc(1:1*3) = 0.0_dp 5037 kad(1:1*1) = 0.0_dp 5038 kac(1:1*3) = 0.0_dp 5039 p_index = 0 5040 DO md = 1, 1 5041 DO mc = 1, 3 5042 DO mb = 1, 1 5043 ks_bd = 0.0_dp 5044 ks_bc = 0.0_dp 5045 p_bd = pbd((md - 1)*1 + mb) 5046 p_bc = pbc((mc - 1)*1 + mb) 5047 DO ma = 1, 1 5048 p_index = p_index + 1 5049 tmp = scale*prim(p_index) 5050 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5051 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5052 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5053 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5054 END DO 5055 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5056 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5057 END DO 5058 END DO 5059 END DO 5060 END SUBROUTINE block_1_1_3_1 5061! ************************************************************************************************** 5062!> \brief ... 5063!> \param kbd ... 5064!> \param kbc ... 5065!> \param kad ... 5066!> \param kac ... 5067!> \param pbd ... 5068!> \param pbc ... 5069!> \param pad ... 5070!> \param pac ... 5071!> \param prim ... 5072!> \param scale ... 5073! ************************************************************************************************** 5074 SUBROUTINE block_1_1_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5075 REAL(KIND=dp) :: kbd(1*2), kbc(1*3), kad(1*2), kac(1*3), & 5076 pbd(1*2), pbc(1*3), pad(1*2), & 5077 pac(1*3), prim(1*1*3*2), scale 5078 5079 INTEGER :: ma, mb, mc, md, p_index 5080 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5081 5082 kbd(1:1*2) = 0.0_dp 5083 kbc(1:1*3) = 0.0_dp 5084 kad(1:1*2) = 0.0_dp 5085 kac(1:1*3) = 0.0_dp 5086 p_index = 0 5087 DO md = 1, 2 5088 DO mc = 1, 3 5089 DO mb = 1, 1 5090 ks_bd = 0.0_dp 5091 ks_bc = 0.0_dp 5092 p_bd = pbd((md - 1)*1 + mb) 5093 p_bc = pbc((mc - 1)*1 + mb) 5094 DO ma = 1, 1 5095 p_index = p_index + 1 5096 tmp = scale*prim(p_index) 5097 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5098 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5099 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5100 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5101 END DO 5102 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5103 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5104 END DO 5105 END DO 5106 END DO 5107 END SUBROUTINE block_1_1_3_2 5108! ************************************************************************************************** 5109!> \brief ... 5110!> \param kbd ... 5111!> \param kbc ... 5112!> \param kad ... 5113!> \param kac ... 5114!> \param pbd ... 5115!> \param pbc ... 5116!> \param pad ... 5117!> \param pac ... 5118!> \param prim ... 5119!> \param scale ... 5120! ************************************************************************************************** 5121 SUBROUTINE block_1_1_3_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5122 REAL(KIND=dp) :: kbd(1*3), kbc(1*3), kad(1*3), kac(1*3), & 5123 pbd(1*3), pbc(1*3), pad(1*3), & 5124 pac(1*3), prim(1*1*3*3), scale 5125 5126 INTEGER :: ma, mb, mc, md, p_index 5127 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5128 5129 kbd(1:1*3) = 0.0_dp 5130 kbc(1:1*3) = 0.0_dp 5131 kad(1:1*3) = 0.0_dp 5132 kac(1:1*3) = 0.0_dp 5133 p_index = 0 5134 DO md = 1, 3 5135 DO mc = 1, 3 5136 DO mb = 1, 1 5137 ks_bd = 0.0_dp 5138 ks_bc = 0.0_dp 5139 p_bd = pbd((md - 1)*1 + mb) 5140 p_bc = pbc((mc - 1)*1 + mb) 5141 DO ma = 1, 1 5142 p_index = p_index + 1 5143 tmp = scale*prim(p_index) 5144 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5145 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5146 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5147 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5148 END DO 5149 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5150 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5151 END DO 5152 END DO 5153 END DO 5154 END SUBROUTINE block_1_1_3_3 5155! ************************************************************************************************** 5156!> \brief ... 5157!> \param kbd ... 5158!> \param kbc ... 5159!> \param kad ... 5160!> \param kac ... 5161!> \param pbd ... 5162!> \param pbc ... 5163!> \param pad ... 5164!> \param pac ... 5165!> \param prim ... 5166!> \param scale ... 5167! ************************************************************************************************** 5168 SUBROUTINE block_1_1_3_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5169 REAL(KIND=dp) :: kbd(1*4), kbc(1*3), kad(1*4), kac(1*3), & 5170 pbd(1*4), pbc(1*3), pad(1*4), & 5171 pac(1*3), prim(1*1*3*4), scale 5172 5173 INTEGER :: ma, mb, mc, md, p_index 5174 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5175 5176 kbd(1:1*4) = 0.0_dp 5177 kbc(1:1*3) = 0.0_dp 5178 kad(1:1*4) = 0.0_dp 5179 kac(1:1*3) = 0.0_dp 5180 p_index = 0 5181 DO md = 1, 4 5182 DO mc = 1, 3 5183 DO mb = 1, 1 5184 ks_bd = 0.0_dp 5185 ks_bc = 0.0_dp 5186 p_bd = pbd((md - 1)*1 + mb) 5187 p_bc = pbc((mc - 1)*1 + mb) 5188 DO ma = 1, 1 5189 p_index = p_index + 1 5190 tmp = scale*prim(p_index) 5191 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5192 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5193 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5194 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5195 END DO 5196 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5197 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5198 END DO 5199 END DO 5200 END DO 5201 END SUBROUTINE block_1_1_3_4 5202! ************************************************************************************************** 5203!> \brief ... 5204!> \param kbd ... 5205!> \param kbc ... 5206!> \param kad ... 5207!> \param kac ... 5208!> \param pbd ... 5209!> \param pbc ... 5210!> \param pad ... 5211!> \param pac ... 5212!> \param prim ... 5213!> \param scale ... 5214! ************************************************************************************************** 5215 SUBROUTINE block_1_1_3_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5216 REAL(KIND=dp) :: kbd(1*5), kbc(1*3), kad(1*5), kac(1*3), & 5217 pbd(1*5), pbc(1*3), pad(1*5), & 5218 pac(1*3), prim(1*1*3*5), scale 5219 5220 INTEGER :: ma, mb, mc, md, p_index 5221 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5222 5223 kbd(1:1*5) = 0.0_dp 5224 kbc(1:1*3) = 0.0_dp 5225 kad(1:1*5) = 0.0_dp 5226 kac(1:1*3) = 0.0_dp 5227 p_index = 0 5228 DO md = 1, 5 5229 DO mc = 1, 3 5230 DO mb = 1, 1 5231 ks_bd = 0.0_dp 5232 ks_bc = 0.0_dp 5233 p_bd = pbd((md - 1)*1 + mb) 5234 p_bc = pbc((mc - 1)*1 + mb) 5235 DO ma = 1, 1 5236 p_index = p_index + 1 5237 tmp = scale*prim(p_index) 5238 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5239 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5240 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5241 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5242 END DO 5243 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5244 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5245 END DO 5246 END DO 5247 END DO 5248 END SUBROUTINE block_1_1_3_5 5249! ************************************************************************************************** 5250!> \brief ... 5251!> \param kbd ... 5252!> \param kbc ... 5253!> \param kad ... 5254!> \param kac ... 5255!> \param pbd ... 5256!> \param pbc ... 5257!> \param pad ... 5258!> \param pac ... 5259!> \param prim ... 5260!> \param scale ... 5261! ************************************************************************************************** 5262 SUBROUTINE block_1_1_3_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5263 REAL(KIND=dp) :: kbd(1*6), kbc(1*3), kad(1*6), kac(1*3), & 5264 pbd(1*6), pbc(1*3), pad(1*6), & 5265 pac(1*3), prim(1*1*3*6), scale 5266 5267 INTEGER :: ma, mb, mc, md, p_index 5268 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5269 5270 kbd(1:1*6) = 0.0_dp 5271 kbc(1:1*3) = 0.0_dp 5272 kad(1:1*6) = 0.0_dp 5273 kac(1:1*3) = 0.0_dp 5274 p_index = 0 5275 DO md = 1, 6 5276 DO mc = 1, 3 5277 DO mb = 1, 1 5278 ks_bd = 0.0_dp 5279 ks_bc = 0.0_dp 5280 p_bd = pbd((md - 1)*1 + mb) 5281 p_bc = pbc((mc - 1)*1 + mb) 5282 DO ma = 1, 1 5283 p_index = p_index + 1 5284 tmp = scale*prim(p_index) 5285 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5286 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5287 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5288 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5289 END DO 5290 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5291 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5292 END DO 5293 END DO 5294 END DO 5295 END SUBROUTINE block_1_1_3_6 5296! ************************************************************************************************** 5297!> \brief ... 5298!> \param md_max ... 5299!> \param kbd ... 5300!> \param kbc ... 5301!> \param kad ... 5302!> \param kac ... 5303!> \param pbd ... 5304!> \param pbc ... 5305!> \param pad ... 5306!> \param pac ... 5307!> \param prim ... 5308!> \param scale ... 5309! ************************************************************************************************** 5310 SUBROUTINE block_1_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5311 INTEGER :: md_max 5312 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*3), kad(1*md_max), kac(1*3), pbd(1*md_max), pbc(1*3), & 5313 pad(1*md_max), pac(1*3), prim(1*1*3*md_max), scale 5314 5315 INTEGER :: ma, mb, mc, md, p_index 5316 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5317 5318 kbd(1:1*md_max) = 0.0_dp 5319 kbc(1:1*3) = 0.0_dp 5320 kad(1:1*md_max) = 0.0_dp 5321 kac(1:1*3) = 0.0_dp 5322 p_index = 0 5323 DO md = 1, md_max 5324 DO mc = 1, 3 5325 DO mb = 1, 1 5326 ks_bd = 0.0_dp 5327 ks_bc = 0.0_dp 5328 p_bd = pbd((md - 1)*1 + mb) 5329 p_bc = pbc((mc - 1)*1 + mb) 5330 DO ma = 1, 1 5331 p_index = p_index + 1 5332 tmp = scale*prim(p_index) 5333 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5334 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5335 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5336 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5337 END DO 5338 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5339 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5340 END DO 5341 END DO 5342 END DO 5343 END SUBROUTINE block_1_1_3 5344! ************************************************************************************************** 5345!> \brief ... 5346!> \param kbd ... 5347!> \param kbc ... 5348!> \param kad ... 5349!> \param kac ... 5350!> \param pbd ... 5351!> \param pbc ... 5352!> \param pad ... 5353!> \param pac ... 5354!> \param prim ... 5355!> \param scale ... 5356! ************************************************************************************************** 5357 SUBROUTINE block_1_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5358 REAL(KIND=dp) :: kbd(1*1), kbc(1*4), kad(1*1), kac(1*4), & 5359 pbd(1*1), pbc(1*4), pad(1*1), & 5360 pac(1*4), prim(1*1*4*1), scale 5361 5362 INTEGER :: ma, mb, mc, md, p_index 5363 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5364 5365 kbd(1:1*1) = 0.0_dp 5366 kbc(1:1*4) = 0.0_dp 5367 kad(1:1*1) = 0.0_dp 5368 kac(1:1*4) = 0.0_dp 5369 p_index = 0 5370 DO md = 1, 1 5371 DO mc = 1, 4 5372 DO mb = 1, 1 5373 ks_bd = 0.0_dp 5374 ks_bc = 0.0_dp 5375 p_bd = pbd((md - 1)*1 + mb) 5376 p_bc = pbc((mc - 1)*1 + mb) 5377 DO ma = 1, 1 5378 p_index = p_index + 1 5379 tmp = scale*prim(p_index) 5380 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5381 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5382 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5383 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5384 END DO 5385 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5386 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5387 END DO 5388 END DO 5389 END DO 5390 END SUBROUTINE block_1_1_4_1 5391! ************************************************************************************************** 5392!> \brief ... 5393!> \param kbd ... 5394!> \param kbc ... 5395!> \param kad ... 5396!> \param kac ... 5397!> \param pbd ... 5398!> \param pbc ... 5399!> \param pad ... 5400!> \param pac ... 5401!> \param prim ... 5402!> \param scale ... 5403! ************************************************************************************************** 5404 SUBROUTINE block_1_1_4_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5405 REAL(KIND=dp) :: kbd(1*2), kbc(1*4), kad(1*2), kac(1*4), & 5406 pbd(1*2), pbc(1*4), pad(1*2), & 5407 pac(1*4), prim(1*1*4*2), scale 5408 5409 INTEGER :: ma, mb, mc, md, p_index 5410 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5411 5412 kbd(1:1*2) = 0.0_dp 5413 kbc(1:1*4) = 0.0_dp 5414 kad(1:1*2) = 0.0_dp 5415 kac(1:1*4) = 0.0_dp 5416 p_index = 0 5417 DO md = 1, 2 5418 DO mc = 1, 4 5419 DO mb = 1, 1 5420 ks_bd = 0.0_dp 5421 ks_bc = 0.0_dp 5422 p_bd = pbd((md - 1)*1 + mb) 5423 p_bc = pbc((mc - 1)*1 + mb) 5424 DO ma = 1, 1 5425 p_index = p_index + 1 5426 tmp = scale*prim(p_index) 5427 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5428 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5429 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5430 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5431 END DO 5432 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5433 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5434 END DO 5435 END DO 5436 END DO 5437 END SUBROUTINE block_1_1_4_2 5438! ************************************************************************************************** 5439!> \brief ... 5440!> \param kbd ... 5441!> \param kbc ... 5442!> \param kad ... 5443!> \param kac ... 5444!> \param pbd ... 5445!> \param pbc ... 5446!> \param pad ... 5447!> \param pac ... 5448!> \param prim ... 5449!> \param scale ... 5450! ************************************************************************************************** 5451 SUBROUTINE block_1_1_4_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5452 REAL(KIND=dp) :: kbd(1*3), kbc(1*4), kad(1*3), kac(1*4), & 5453 pbd(1*3), pbc(1*4), pad(1*3), & 5454 pac(1*4), prim(1*1*4*3), scale 5455 5456 INTEGER :: ma, mb, mc, md, p_index 5457 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5458 5459 kbd(1:1*3) = 0.0_dp 5460 kbc(1:1*4) = 0.0_dp 5461 kad(1:1*3) = 0.0_dp 5462 kac(1:1*4) = 0.0_dp 5463 p_index = 0 5464 DO md = 1, 3 5465 DO mc = 1, 4 5466 DO mb = 1, 1 5467 ks_bd = 0.0_dp 5468 ks_bc = 0.0_dp 5469 p_bd = pbd((md - 1)*1 + mb) 5470 p_bc = pbc((mc - 1)*1 + mb) 5471 DO ma = 1, 1 5472 p_index = p_index + 1 5473 tmp = scale*prim(p_index) 5474 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5475 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5476 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5477 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5478 END DO 5479 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5480 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5481 END DO 5482 END DO 5483 END DO 5484 END SUBROUTINE block_1_1_4_3 5485! ************************************************************************************************** 5486!> \brief ... 5487!> \param kbd ... 5488!> \param kbc ... 5489!> \param kad ... 5490!> \param kac ... 5491!> \param pbd ... 5492!> \param pbc ... 5493!> \param pad ... 5494!> \param pac ... 5495!> \param prim ... 5496!> \param scale ... 5497! ************************************************************************************************** 5498 SUBROUTINE block_1_1_4_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5499 REAL(KIND=dp) :: kbd(1*4), kbc(1*4), kad(1*4), kac(1*4), & 5500 pbd(1*4), pbc(1*4), pad(1*4), & 5501 pac(1*4), prim(1*1*4*4), scale 5502 5503 INTEGER :: ma, mb, mc, md, p_index 5504 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5505 5506 kbd(1:1*4) = 0.0_dp 5507 kbc(1:1*4) = 0.0_dp 5508 kad(1:1*4) = 0.0_dp 5509 kac(1:1*4) = 0.0_dp 5510 p_index = 0 5511 DO md = 1, 4 5512 DO mc = 1, 4 5513 DO mb = 1, 1 5514 ks_bd = 0.0_dp 5515 ks_bc = 0.0_dp 5516 p_bd = pbd((md - 1)*1 + mb) 5517 p_bc = pbc((mc - 1)*1 + mb) 5518 DO ma = 1, 1 5519 p_index = p_index + 1 5520 tmp = scale*prim(p_index) 5521 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5522 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5523 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5524 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5525 END DO 5526 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5527 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5528 END DO 5529 END DO 5530 END DO 5531 END SUBROUTINE block_1_1_4_4 5532! ************************************************************************************************** 5533!> \brief ... 5534!> \param md_max ... 5535!> \param kbd ... 5536!> \param kbc ... 5537!> \param kad ... 5538!> \param kac ... 5539!> \param pbd ... 5540!> \param pbc ... 5541!> \param pad ... 5542!> \param pac ... 5543!> \param prim ... 5544!> \param scale ... 5545! ************************************************************************************************** 5546 SUBROUTINE block_1_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5547 INTEGER :: md_max 5548 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*4), kad(1*md_max), kac(1*4), pbd(1*md_max), pbc(1*4), & 5549 pad(1*md_max), pac(1*4), prim(1*1*4*md_max), scale 5550 5551 INTEGER :: ma, mb, mc, md, p_index 5552 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5553 5554 kbd(1:1*md_max) = 0.0_dp 5555 kbc(1:1*4) = 0.0_dp 5556 kad(1:1*md_max) = 0.0_dp 5557 kac(1:1*4) = 0.0_dp 5558 p_index = 0 5559 DO md = 1, md_max 5560 DO mc = 1, 4 5561 DO mb = 1, 1 5562 ks_bd = 0.0_dp 5563 ks_bc = 0.0_dp 5564 p_bd = pbd((md - 1)*1 + mb) 5565 p_bc = pbc((mc - 1)*1 + mb) 5566 DO ma = 1, 1 5567 p_index = p_index + 1 5568 tmp = scale*prim(p_index) 5569 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5570 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5571 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5572 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5573 END DO 5574 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5575 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5576 END DO 5577 END DO 5578 END DO 5579 END SUBROUTINE block_1_1_4 5580! ************************************************************************************************** 5581!> \brief ... 5582!> \param kbd ... 5583!> \param kbc ... 5584!> \param kad ... 5585!> \param kac ... 5586!> \param pbd ... 5587!> \param pbc ... 5588!> \param pad ... 5589!> \param pac ... 5590!> \param prim ... 5591!> \param scale ... 5592! ************************************************************************************************** 5593 SUBROUTINE block_1_1_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5594 REAL(KIND=dp) :: kbd(1*1), kbc(1*5), kad(1*1), kac(1*5), & 5595 pbd(1*1), pbc(1*5), pad(1*1), & 5596 pac(1*5), prim(1*1*5*1), scale 5597 5598 INTEGER :: ma, mb, mc, md, p_index 5599 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5600 5601 kbd(1:1*1) = 0.0_dp 5602 kbc(1:1*5) = 0.0_dp 5603 kad(1:1*1) = 0.0_dp 5604 kac(1:1*5) = 0.0_dp 5605 p_index = 0 5606 DO md = 1, 1 5607 DO mc = 1, 5 5608 DO mb = 1, 1 5609 ks_bd = 0.0_dp 5610 ks_bc = 0.0_dp 5611 p_bd = pbd((md - 1)*1 + mb) 5612 p_bc = pbc((mc - 1)*1 + mb) 5613 DO ma = 1, 1 5614 p_index = p_index + 1 5615 tmp = scale*prim(p_index) 5616 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5617 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5618 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5619 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5620 END DO 5621 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5622 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5623 END DO 5624 END DO 5625 END DO 5626 END SUBROUTINE block_1_1_5_1 5627! ************************************************************************************************** 5628!> \brief ... 5629!> \param kbd ... 5630!> \param kbc ... 5631!> \param kad ... 5632!> \param kac ... 5633!> \param pbd ... 5634!> \param pbc ... 5635!> \param pad ... 5636!> \param pac ... 5637!> \param prim ... 5638!> \param scale ... 5639! ************************************************************************************************** 5640 SUBROUTINE block_1_1_5_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5641 REAL(KIND=dp) :: kbd(1*2), kbc(1*5), kad(1*2), kac(1*5), & 5642 pbd(1*2), pbc(1*5), pad(1*2), & 5643 pac(1*5), prim(1*1*5*2), scale 5644 5645 INTEGER :: ma, mb, mc, md, p_index 5646 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5647 5648 kbd(1:1*2) = 0.0_dp 5649 kbc(1:1*5) = 0.0_dp 5650 kad(1:1*2) = 0.0_dp 5651 kac(1:1*5) = 0.0_dp 5652 p_index = 0 5653 DO md = 1, 2 5654 DO mc = 1, 5 5655 DO mb = 1, 1 5656 ks_bd = 0.0_dp 5657 ks_bc = 0.0_dp 5658 p_bd = pbd((md - 1)*1 + mb) 5659 p_bc = pbc((mc - 1)*1 + mb) 5660 DO ma = 1, 1 5661 p_index = p_index + 1 5662 tmp = scale*prim(p_index) 5663 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5664 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5665 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5666 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5667 END DO 5668 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5669 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5670 END DO 5671 END DO 5672 END DO 5673 END SUBROUTINE block_1_1_5_2 5674! ************************************************************************************************** 5675!> \brief ... 5676!> \param kbd ... 5677!> \param kbc ... 5678!> \param kad ... 5679!> \param kac ... 5680!> \param pbd ... 5681!> \param pbc ... 5682!> \param pad ... 5683!> \param pac ... 5684!> \param prim ... 5685!> \param scale ... 5686! ************************************************************************************************** 5687 SUBROUTINE block_1_1_5_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5688 REAL(KIND=dp) :: kbd(1*3), kbc(1*5), kad(1*3), kac(1*5), & 5689 pbd(1*3), pbc(1*5), pad(1*3), & 5690 pac(1*5), prim(1*1*5*3), scale 5691 5692 INTEGER :: ma, mb, mc, md, p_index 5693 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5694 5695 kbd(1:1*3) = 0.0_dp 5696 kbc(1:1*5) = 0.0_dp 5697 kad(1:1*3) = 0.0_dp 5698 kac(1:1*5) = 0.0_dp 5699 p_index = 0 5700 DO md = 1, 3 5701 DO mc = 1, 5 5702 DO mb = 1, 1 5703 ks_bd = 0.0_dp 5704 ks_bc = 0.0_dp 5705 p_bd = pbd((md - 1)*1 + mb) 5706 p_bc = pbc((mc - 1)*1 + mb) 5707 DO ma = 1, 1 5708 p_index = p_index + 1 5709 tmp = scale*prim(p_index) 5710 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5711 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5712 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5713 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5714 END DO 5715 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5716 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5717 END DO 5718 END DO 5719 END DO 5720 END SUBROUTINE block_1_1_5_3 5721! ************************************************************************************************** 5722!> \brief ... 5723!> \param md_max ... 5724!> \param kbd ... 5725!> \param kbc ... 5726!> \param kad ... 5727!> \param kac ... 5728!> \param pbd ... 5729!> \param pbc ... 5730!> \param pad ... 5731!> \param pac ... 5732!> \param prim ... 5733!> \param scale ... 5734! ************************************************************************************************** 5735 SUBROUTINE block_1_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5736 INTEGER :: md_max 5737 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*5), kad(1*md_max), kac(1*5), pbd(1*md_max), pbc(1*5), & 5738 pad(1*md_max), pac(1*5), prim(1*1*5*md_max), scale 5739 5740 INTEGER :: ma, mb, mc, md, p_index 5741 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5742 5743 kbd(1:1*md_max) = 0.0_dp 5744 kbc(1:1*5) = 0.0_dp 5745 kad(1:1*md_max) = 0.0_dp 5746 kac(1:1*5) = 0.0_dp 5747 p_index = 0 5748 DO md = 1, md_max 5749 DO mc = 1, 5 5750 DO mb = 1, 1 5751 ks_bd = 0.0_dp 5752 ks_bc = 0.0_dp 5753 p_bd = pbd((md - 1)*1 + mb) 5754 p_bc = pbc((mc - 1)*1 + mb) 5755 DO ma = 1, 1 5756 p_index = p_index + 1 5757 tmp = scale*prim(p_index) 5758 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5759 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5760 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5761 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5762 END DO 5763 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5764 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5765 END DO 5766 END DO 5767 END DO 5768 END SUBROUTINE block_1_1_5 5769! ************************************************************************************************** 5770!> \brief ... 5771!> \param kbd ... 5772!> \param kbc ... 5773!> \param kad ... 5774!> \param kac ... 5775!> \param pbd ... 5776!> \param pbc ... 5777!> \param pad ... 5778!> \param pac ... 5779!> \param prim ... 5780!> \param scale ... 5781! ************************************************************************************************** 5782 SUBROUTINE block_1_1_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5783 REAL(KIND=dp) :: kbd(1*1), kbc(1*6), kad(1*1), kac(1*6), & 5784 pbd(1*1), pbc(1*6), pad(1*1), & 5785 pac(1*6), prim(1*1*6*1), scale 5786 5787 INTEGER :: ma, mb, mc, md, p_index 5788 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5789 5790 kbd(1:1*1) = 0.0_dp 5791 kbc(1:1*6) = 0.0_dp 5792 kad(1:1*1) = 0.0_dp 5793 kac(1:1*6) = 0.0_dp 5794 p_index = 0 5795 DO md = 1, 1 5796 DO mc = 1, 6 5797 DO mb = 1, 1 5798 ks_bd = 0.0_dp 5799 ks_bc = 0.0_dp 5800 p_bd = pbd((md - 1)*1 + mb) 5801 p_bc = pbc((mc - 1)*1 + mb) 5802 DO ma = 1, 1 5803 p_index = p_index + 1 5804 tmp = scale*prim(p_index) 5805 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5806 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5807 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5808 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5809 END DO 5810 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5811 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5812 END DO 5813 END DO 5814 END DO 5815 END SUBROUTINE block_1_1_6_1 5816! ************************************************************************************************** 5817!> \brief ... 5818!> \param kbd ... 5819!> \param kbc ... 5820!> \param kad ... 5821!> \param kac ... 5822!> \param pbd ... 5823!> \param pbc ... 5824!> \param pad ... 5825!> \param pac ... 5826!> \param prim ... 5827!> \param scale ... 5828! ************************************************************************************************** 5829 SUBROUTINE block_1_1_6_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5830 REAL(KIND=dp) :: kbd(1*2), kbc(1*6), kad(1*2), kac(1*6), & 5831 pbd(1*2), pbc(1*6), pad(1*2), & 5832 pac(1*6), prim(1*1*6*2), scale 5833 5834 INTEGER :: ma, mb, mc, md, p_index 5835 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5836 5837 kbd(1:1*2) = 0.0_dp 5838 kbc(1:1*6) = 0.0_dp 5839 kad(1:1*2) = 0.0_dp 5840 kac(1:1*6) = 0.0_dp 5841 p_index = 0 5842 DO md = 1, 2 5843 DO mc = 1, 6 5844 DO mb = 1, 1 5845 ks_bd = 0.0_dp 5846 ks_bc = 0.0_dp 5847 p_bd = pbd((md - 1)*1 + mb) 5848 p_bc = pbc((mc - 1)*1 + mb) 5849 DO ma = 1, 1 5850 p_index = p_index + 1 5851 tmp = scale*prim(p_index) 5852 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5853 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5854 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5855 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5856 END DO 5857 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5858 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5859 END DO 5860 END DO 5861 END DO 5862 END SUBROUTINE block_1_1_6_2 5863! ************************************************************************************************** 5864!> \brief ... 5865!> \param kbd ... 5866!> \param kbc ... 5867!> \param kad ... 5868!> \param kac ... 5869!> \param pbd ... 5870!> \param pbc ... 5871!> \param pad ... 5872!> \param pac ... 5873!> \param prim ... 5874!> \param scale ... 5875! ************************************************************************************************** 5876 SUBROUTINE block_1_1_6_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5877 REAL(KIND=dp) :: kbd(1*3), kbc(1*6), kad(1*3), kac(1*6), & 5878 pbd(1*3), pbc(1*6), pad(1*3), & 5879 pac(1*6), prim(1*1*6*3), scale 5880 5881 INTEGER :: ma, mb, mc, md, p_index 5882 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5883 5884 kbd(1:1*3) = 0.0_dp 5885 kbc(1:1*6) = 0.0_dp 5886 kad(1:1*3) = 0.0_dp 5887 kac(1:1*6) = 0.0_dp 5888 p_index = 0 5889 DO md = 1, 3 5890 DO mc = 1, 6 5891 DO mb = 1, 1 5892 ks_bd = 0.0_dp 5893 ks_bc = 0.0_dp 5894 p_bd = pbd((md - 1)*1 + mb) 5895 p_bc = pbc((mc - 1)*1 + mb) 5896 DO ma = 1, 1 5897 p_index = p_index + 1 5898 tmp = scale*prim(p_index) 5899 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5900 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5901 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5902 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5903 END DO 5904 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5905 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5906 END DO 5907 END DO 5908 END DO 5909 END SUBROUTINE block_1_1_6_3 5910! ************************************************************************************************** 5911!> \brief ... 5912!> \param md_max ... 5913!> \param kbd ... 5914!> \param kbc ... 5915!> \param kad ... 5916!> \param kac ... 5917!> \param pbd ... 5918!> \param pbc ... 5919!> \param pad ... 5920!> \param pac ... 5921!> \param prim ... 5922!> \param scale ... 5923! ************************************************************************************************** 5924 SUBROUTINE block_1_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5925 INTEGER :: md_max 5926 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*6), kad(1*md_max), kac(1*6), pbd(1*md_max), pbc(1*6), & 5927 pad(1*md_max), pac(1*6), prim(1*1*6*md_max), scale 5928 5929 INTEGER :: ma, mb, mc, md, p_index 5930 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5931 5932 kbd(1:1*md_max) = 0.0_dp 5933 kbc(1:1*6) = 0.0_dp 5934 kad(1:1*md_max) = 0.0_dp 5935 kac(1:1*6) = 0.0_dp 5936 p_index = 0 5937 DO md = 1, md_max 5938 DO mc = 1, 6 5939 DO mb = 1, 1 5940 ks_bd = 0.0_dp 5941 ks_bc = 0.0_dp 5942 p_bd = pbd((md - 1)*1 + mb) 5943 p_bc = pbc((mc - 1)*1 + mb) 5944 DO ma = 1, 1 5945 p_index = p_index + 1 5946 tmp = scale*prim(p_index) 5947 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5948 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5949 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5950 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5951 END DO 5952 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 5953 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 5954 END DO 5955 END DO 5956 END DO 5957 END SUBROUTINE block_1_1_6 5958! ************************************************************************************************** 5959!> \brief ... 5960!> \param kbd ... 5961!> \param kbc ... 5962!> \param kad ... 5963!> \param kac ... 5964!> \param pbd ... 5965!> \param pbc ... 5966!> \param pad ... 5967!> \param pac ... 5968!> \param prim ... 5969!> \param scale ... 5970! ************************************************************************************************** 5971 SUBROUTINE block_1_1_7_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 5972 REAL(KIND=dp) :: kbd(1*1), kbc(1*7), kad(1*1), kac(1*7), & 5973 pbd(1*1), pbc(1*7), pad(1*1), & 5974 pac(1*7), prim(1*1*7*1), scale 5975 5976 INTEGER :: ma, mb, mc, md, p_index 5977 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 5978 5979 kbd(1:1*1) = 0.0_dp 5980 kbc(1:1*7) = 0.0_dp 5981 kad(1:1*1) = 0.0_dp 5982 kac(1:1*7) = 0.0_dp 5983 p_index = 0 5984 DO md = 1, 1 5985 DO mc = 1, 7 5986 DO mb = 1, 1 5987 ks_bd = 0.0_dp 5988 ks_bc = 0.0_dp 5989 p_bd = pbd((md - 1)*1 + mb) 5990 p_bc = pbc((mc - 1)*1 + mb) 5991 DO ma = 1, 1 5992 p_index = p_index + 1 5993 tmp = scale*prim(p_index) 5994 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 5995 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 5996 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 5997 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 5998 END DO 5999 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6000 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6001 END DO 6002 END DO 6003 END DO 6004 END SUBROUTINE block_1_1_7_1 6005! ************************************************************************************************** 6006!> \brief ... 6007!> \param kbd ... 6008!> \param kbc ... 6009!> \param kad ... 6010!> \param kac ... 6011!> \param pbd ... 6012!> \param pbc ... 6013!> \param pad ... 6014!> \param pac ... 6015!> \param prim ... 6016!> \param scale ... 6017! ************************************************************************************************** 6018 SUBROUTINE block_1_1_7_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6019 REAL(KIND=dp) :: kbd(1*2), kbc(1*7), kad(1*2), kac(1*7), & 6020 pbd(1*2), pbc(1*7), pad(1*2), & 6021 pac(1*7), prim(1*1*7*2), scale 6022 6023 INTEGER :: ma, mb, mc, md, p_index 6024 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6025 6026 kbd(1:1*2) = 0.0_dp 6027 kbc(1:1*7) = 0.0_dp 6028 kad(1:1*2) = 0.0_dp 6029 kac(1:1*7) = 0.0_dp 6030 p_index = 0 6031 DO md = 1, 2 6032 DO mc = 1, 7 6033 DO mb = 1, 1 6034 ks_bd = 0.0_dp 6035 ks_bc = 0.0_dp 6036 p_bd = pbd((md - 1)*1 + mb) 6037 p_bc = pbc((mc - 1)*1 + mb) 6038 DO ma = 1, 1 6039 p_index = p_index + 1 6040 tmp = scale*prim(p_index) 6041 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6042 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6043 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6044 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6045 END DO 6046 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6047 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6048 END DO 6049 END DO 6050 END DO 6051 END SUBROUTINE block_1_1_7_2 6052! ************************************************************************************************** 6053!> \brief ... 6054!> \param md_max ... 6055!> \param kbd ... 6056!> \param kbc ... 6057!> \param kad ... 6058!> \param kac ... 6059!> \param pbd ... 6060!> \param pbc ... 6061!> \param pad ... 6062!> \param pac ... 6063!> \param prim ... 6064!> \param scale ... 6065! ************************************************************************************************** 6066 SUBROUTINE block_1_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6067 INTEGER :: md_max 6068 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*7), kad(1*md_max), kac(1*7), pbd(1*md_max), pbc(1*7), & 6069 pad(1*md_max), pac(1*7), prim(1*1*7*md_max), scale 6070 6071 INTEGER :: ma, mb, mc, md, p_index 6072 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6073 6074 kbd(1:1*md_max) = 0.0_dp 6075 kbc(1:1*7) = 0.0_dp 6076 kad(1:1*md_max) = 0.0_dp 6077 kac(1:1*7) = 0.0_dp 6078 p_index = 0 6079 DO md = 1, md_max 6080 DO mc = 1, 7 6081 DO mb = 1, 1 6082 ks_bd = 0.0_dp 6083 ks_bc = 0.0_dp 6084 p_bd = pbd((md - 1)*1 + mb) 6085 p_bc = pbc((mc - 1)*1 + mb) 6086 DO ma = 1, 1 6087 p_index = p_index + 1 6088 tmp = scale*prim(p_index) 6089 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6090 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6091 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6092 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6093 END DO 6094 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6095 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6096 END DO 6097 END DO 6098 END DO 6099 END SUBROUTINE block_1_1_7 6100! ************************************************************************************************** 6101!> \brief ... 6102!> \param kbd ... 6103!> \param kbc ... 6104!> \param kad ... 6105!> \param kac ... 6106!> \param pbd ... 6107!> \param pbc ... 6108!> \param pad ... 6109!> \param pac ... 6110!> \param prim ... 6111!> \param scale ... 6112! ************************************************************************************************** 6113 SUBROUTINE block_1_1_9_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6114 REAL(KIND=dp) :: kbd(1*1), kbc(1*9), kad(1*1), kac(1*9), & 6115 pbd(1*1), pbc(1*9), pad(1*1), & 6116 pac(1*9), prim(1*1*9*1), scale 6117 6118 INTEGER :: ma, mb, mc, md, p_index 6119 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6120 6121 kbd(1:1*1) = 0.0_dp 6122 kbc(1:1*9) = 0.0_dp 6123 kad(1:1*1) = 0.0_dp 6124 kac(1:1*9) = 0.0_dp 6125 p_index = 0 6126 DO md = 1, 1 6127 DO mc = 1, 9 6128 DO mb = 1, 1 6129 ks_bd = 0.0_dp 6130 ks_bc = 0.0_dp 6131 p_bd = pbd((md - 1)*1 + mb) 6132 p_bc = pbc((mc - 1)*1 + mb) 6133 DO ma = 1, 1 6134 p_index = p_index + 1 6135 tmp = scale*prim(p_index) 6136 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6137 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6138 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6139 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6140 END DO 6141 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6142 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6143 END DO 6144 END DO 6145 END DO 6146 END SUBROUTINE block_1_1_9_1 6147! ************************************************************************************************** 6148!> \brief ... 6149!> \param kbd ... 6150!> \param kbc ... 6151!> \param kad ... 6152!> \param kac ... 6153!> \param pbd ... 6154!> \param pbc ... 6155!> \param pad ... 6156!> \param pac ... 6157!> \param prim ... 6158!> \param scale ... 6159! ************************************************************************************************** 6160 SUBROUTINE block_1_1_9_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6161 REAL(KIND=dp) :: kbd(1*2), kbc(1*9), kad(1*2), kac(1*9), & 6162 pbd(1*2), pbc(1*9), pad(1*2), & 6163 pac(1*9), prim(1*1*9*2), scale 6164 6165 INTEGER :: ma, mb, mc, md, p_index 6166 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6167 6168 kbd(1:1*2) = 0.0_dp 6169 kbc(1:1*9) = 0.0_dp 6170 kad(1:1*2) = 0.0_dp 6171 kac(1:1*9) = 0.0_dp 6172 p_index = 0 6173 DO md = 1, 2 6174 DO mc = 1, 9 6175 DO mb = 1, 1 6176 ks_bd = 0.0_dp 6177 ks_bc = 0.0_dp 6178 p_bd = pbd((md - 1)*1 + mb) 6179 p_bc = pbc((mc - 1)*1 + mb) 6180 DO ma = 1, 1 6181 p_index = p_index + 1 6182 tmp = scale*prim(p_index) 6183 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6184 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6185 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6186 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6187 END DO 6188 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6189 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6190 END DO 6191 END DO 6192 END DO 6193 END SUBROUTINE block_1_1_9_2 6194! ************************************************************************************************** 6195!> \brief ... 6196!> \param md_max ... 6197!> \param kbd ... 6198!> \param kbc ... 6199!> \param kad ... 6200!> \param kac ... 6201!> \param pbd ... 6202!> \param pbc ... 6203!> \param pad ... 6204!> \param pac ... 6205!> \param prim ... 6206!> \param scale ... 6207! ************************************************************************************************** 6208 SUBROUTINE block_1_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6209 INTEGER :: md_max 6210 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*9), kad(1*md_max), kac(1*9), pbd(1*md_max), pbc(1*9), & 6211 pad(1*md_max), pac(1*9), prim(1*1*9*md_max), scale 6212 6213 INTEGER :: ma, mb, mc, md, p_index 6214 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6215 6216 kbd(1:1*md_max) = 0.0_dp 6217 kbc(1:1*9) = 0.0_dp 6218 kad(1:1*md_max) = 0.0_dp 6219 kac(1:1*9) = 0.0_dp 6220 p_index = 0 6221 DO md = 1, md_max 6222 DO mc = 1, 9 6223 DO mb = 1, 1 6224 ks_bd = 0.0_dp 6225 ks_bc = 0.0_dp 6226 p_bd = pbd((md - 1)*1 + mb) 6227 p_bc = pbc((mc - 1)*1 + mb) 6228 DO ma = 1, 1 6229 p_index = p_index + 1 6230 tmp = scale*prim(p_index) 6231 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6232 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6233 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6234 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6235 END DO 6236 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6237 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6238 END DO 6239 END DO 6240 END DO 6241 END SUBROUTINE block_1_1_9 6242! ************************************************************************************************** 6243!> \brief ... 6244!> \param kbd ... 6245!> \param kbc ... 6246!> \param kad ... 6247!> \param kac ... 6248!> \param pbd ... 6249!> \param pbc ... 6250!> \param pad ... 6251!> \param pac ... 6252!> \param prim ... 6253!> \param scale ... 6254! ************************************************************************************************** 6255 SUBROUTINE block_1_1_10_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6256 REAL(KIND=dp) :: kbd(1*1), kbc(1*10), kad(1*1), & 6257 kac(1*10), pbd(1*1), pbc(1*10), & 6258 pad(1*1), pac(1*10), prim(1*1*10*1), & 6259 scale 6260 6261 INTEGER :: ma, mb, mc, md, p_index 6262 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6263 6264 kbd(1:1*1) = 0.0_dp 6265 kbc(1:1*10) = 0.0_dp 6266 kad(1:1*1) = 0.0_dp 6267 kac(1:1*10) = 0.0_dp 6268 p_index = 0 6269 DO md = 1, 1 6270 DO mc = 1, 10 6271 DO mb = 1, 1 6272 ks_bd = 0.0_dp 6273 ks_bc = 0.0_dp 6274 p_bd = pbd((md - 1)*1 + mb) 6275 p_bc = pbc((mc - 1)*1 + mb) 6276 DO ma = 1, 1 6277 p_index = p_index + 1 6278 tmp = scale*prim(p_index) 6279 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6280 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6281 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6282 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6283 END DO 6284 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6285 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6286 END DO 6287 END DO 6288 END DO 6289 END SUBROUTINE block_1_1_10_1 6290! ************************************************************************************************** 6291!> \brief ... 6292!> \param md_max ... 6293!> \param kbd ... 6294!> \param kbc ... 6295!> \param kad ... 6296!> \param kac ... 6297!> \param pbd ... 6298!> \param pbc ... 6299!> \param pad ... 6300!> \param pac ... 6301!> \param prim ... 6302!> \param scale ... 6303! ************************************************************************************************** 6304 SUBROUTINE block_1_1_10(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6305 INTEGER :: md_max 6306 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*10), kad(1*md_max), kac(1*10), pbd(1*md_max), & 6307 pbc(1*10), pad(1*md_max), pac(1*10), prim(1*1*10*md_max), scale 6308 6309 INTEGER :: ma, mb, mc, md, p_index 6310 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6311 6312 kbd(1:1*md_max) = 0.0_dp 6313 kbc(1:1*10) = 0.0_dp 6314 kad(1:1*md_max) = 0.0_dp 6315 kac(1:1*10) = 0.0_dp 6316 p_index = 0 6317 DO md = 1, md_max 6318 DO mc = 1, 10 6319 DO mb = 1, 1 6320 ks_bd = 0.0_dp 6321 ks_bc = 0.0_dp 6322 p_bd = pbd((md - 1)*1 + mb) 6323 p_bc = pbc((mc - 1)*1 + mb) 6324 DO ma = 1, 1 6325 p_index = p_index + 1 6326 tmp = scale*prim(p_index) 6327 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6328 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6329 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6330 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6331 END DO 6332 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6333 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6334 END DO 6335 END DO 6336 END DO 6337 END SUBROUTINE block_1_1_10 6338! ************************************************************************************************** 6339!> \brief ... 6340!> \param kbd ... 6341!> \param kbc ... 6342!> \param kad ... 6343!> \param kac ... 6344!> \param pbd ... 6345!> \param pbc ... 6346!> \param pad ... 6347!> \param pac ... 6348!> \param prim ... 6349!> \param scale ... 6350! ************************************************************************************************** 6351 SUBROUTINE block_1_1_11_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6352 REAL(KIND=dp) :: kbd(1*1), kbc(1*11), kad(1*1), & 6353 kac(1*11), pbd(1*1), pbc(1*11), & 6354 pad(1*1), pac(1*11), prim(1*1*11*1), & 6355 scale 6356 6357 INTEGER :: ma, mb, mc, md, p_index 6358 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6359 6360 kbd(1:1*1) = 0.0_dp 6361 kbc(1:1*11) = 0.0_dp 6362 kad(1:1*1) = 0.0_dp 6363 kac(1:1*11) = 0.0_dp 6364 p_index = 0 6365 DO md = 1, 1 6366 DO mc = 1, 11 6367 DO mb = 1, 1 6368 ks_bd = 0.0_dp 6369 ks_bc = 0.0_dp 6370 p_bd = pbd((md - 1)*1 + mb) 6371 p_bc = pbc((mc - 1)*1 + mb) 6372 DO ma = 1, 1 6373 p_index = p_index + 1 6374 tmp = scale*prim(p_index) 6375 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6376 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6377 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6378 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6379 END DO 6380 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6381 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6382 END DO 6383 END DO 6384 END DO 6385 END SUBROUTINE block_1_1_11_1 6386! ************************************************************************************************** 6387!> \brief ... 6388!> \param md_max ... 6389!> \param kbd ... 6390!> \param kbc ... 6391!> \param kad ... 6392!> \param kac ... 6393!> \param pbd ... 6394!> \param pbc ... 6395!> \param pad ... 6396!> \param pac ... 6397!> \param prim ... 6398!> \param scale ... 6399! ************************************************************************************************** 6400 SUBROUTINE block_1_1_11(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6401 INTEGER :: md_max 6402 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*11), kad(1*md_max), kac(1*11), pbd(1*md_max), & 6403 pbc(1*11), pad(1*md_max), pac(1*11), prim(1*1*11*md_max), scale 6404 6405 INTEGER :: ma, mb, mc, md, p_index 6406 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6407 6408 kbd(1:1*md_max) = 0.0_dp 6409 kbc(1:1*11) = 0.0_dp 6410 kad(1:1*md_max) = 0.0_dp 6411 kac(1:1*11) = 0.0_dp 6412 p_index = 0 6413 DO md = 1, md_max 6414 DO mc = 1, 11 6415 DO mb = 1, 1 6416 ks_bd = 0.0_dp 6417 ks_bc = 0.0_dp 6418 p_bd = pbd((md - 1)*1 + mb) 6419 p_bc = pbc((mc - 1)*1 + mb) 6420 DO ma = 1, 1 6421 p_index = p_index + 1 6422 tmp = scale*prim(p_index) 6423 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6424 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6425 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6426 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6427 END DO 6428 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6429 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6430 END DO 6431 END DO 6432 END DO 6433 END SUBROUTINE block_1_1_11 6434! ************************************************************************************************** 6435!> \brief ... 6436!> \param kbd ... 6437!> \param kbc ... 6438!> \param kad ... 6439!> \param kac ... 6440!> \param pbd ... 6441!> \param pbc ... 6442!> \param pad ... 6443!> \param pac ... 6444!> \param prim ... 6445!> \param scale ... 6446! ************************************************************************************************** 6447 SUBROUTINE block_1_1_15_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6448 REAL(KIND=dp) :: kbd(1*1), kbc(1*15), kad(1*1), & 6449 kac(1*15), pbd(1*1), pbc(1*15), & 6450 pad(1*1), pac(1*15), prim(1*1*15*1), & 6451 scale 6452 6453 INTEGER :: ma, mb, mc, md, p_index 6454 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6455 6456 kbd(1:1*1) = 0.0_dp 6457 kbc(1:1*15) = 0.0_dp 6458 kad(1:1*1) = 0.0_dp 6459 kac(1:1*15) = 0.0_dp 6460 p_index = 0 6461 DO md = 1, 1 6462 DO mc = 1, 15 6463 DO mb = 1, 1 6464 ks_bd = 0.0_dp 6465 ks_bc = 0.0_dp 6466 p_bd = pbd((md - 1)*1 + mb) 6467 p_bc = pbc((mc - 1)*1 + mb) 6468 DO ma = 1, 1 6469 p_index = p_index + 1 6470 tmp = scale*prim(p_index) 6471 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6472 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6473 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6474 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6475 END DO 6476 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6477 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6478 END DO 6479 END DO 6480 END DO 6481 END SUBROUTINE block_1_1_15_1 6482! ************************************************************************************************** 6483!> \brief ... 6484!> \param md_max ... 6485!> \param kbd ... 6486!> \param kbc ... 6487!> \param kad ... 6488!> \param kac ... 6489!> \param pbd ... 6490!> \param pbc ... 6491!> \param pad ... 6492!> \param pac ... 6493!> \param prim ... 6494!> \param scale ... 6495! ************************************************************************************************** 6496 SUBROUTINE block_1_1_15(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6497 INTEGER :: md_max 6498 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*15), kad(1*md_max), kac(1*15), pbd(1*md_max), & 6499 pbc(1*15), pad(1*md_max), pac(1*15), prim(1*1*15*md_max), scale 6500 6501 INTEGER :: ma, mb, mc, md, p_index 6502 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6503 6504 kbd(1:1*md_max) = 0.0_dp 6505 kbc(1:1*15) = 0.0_dp 6506 kad(1:1*md_max) = 0.0_dp 6507 kac(1:1*15) = 0.0_dp 6508 p_index = 0 6509 DO md = 1, md_max 6510 DO mc = 1, 15 6511 DO mb = 1, 1 6512 ks_bd = 0.0_dp 6513 ks_bc = 0.0_dp 6514 p_bd = pbd((md - 1)*1 + mb) 6515 p_bc = pbc((mc - 1)*1 + mb) 6516 DO ma = 1, 1 6517 p_index = p_index + 1 6518 tmp = scale*prim(p_index) 6519 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6520 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6521 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6522 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6523 END DO 6524 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 6525 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 6526 END DO 6527 END DO 6528 END DO 6529 END SUBROUTINE block_1_1_15 6530! ************************************************************************************************** 6531!> \brief ... 6532!> \param kbd ... 6533!> \param kbc ... 6534!> \param kad ... 6535!> \param kac ... 6536!> \param pbd ... 6537!> \param pbc ... 6538!> \param pad ... 6539!> \param pac ... 6540!> \param prim ... 6541!> \param scale ... 6542! ************************************************************************************************** 6543 SUBROUTINE block_1_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6544 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(1*1), kac(1*1), & 6545 pbd(2*1), pbc(2*1), pad(1*1), & 6546 pac(1*1), prim(1*2*1*1), scale 6547 6548 INTEGER :: ma, mb, mc, md, p_index 6549 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6550 6551 kbd(1:2*1) = 0.0_dp 6552 kbc(1:2*1) = 0.0_dp 6553 kad(1:1*1) = 0.0_dp 6554 kac(1:1*1) = 0.0_dp 6555 p_index = 0 6556 DO md = 1, 1 6557 DO mc = 1, 1 6558 DO mb = 1, 2 6559 ks_bd = 0.0_dp 6560 ks_bc = 0.0_dp 6561 p_bd = pbd((md - 1)*2 + mb) 6562 p_bc = pbc((mc - 1)*2 + mb) 6563 DO ma = 1, 1 6564 p_index = p_index + 1 6565 tmp = scale*prim(p_index) 6566 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6567 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6568 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6569 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6570 END DO 6571 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6572 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6573 END DO 6574 END DO 6575 END DO 6576 END SUBROUTINE block_1_2_1_1 6577! ************************************************************************************************** 6578!> \brief ... 6579!> \param kbd ... 6580!> \param kbc ... 6581!> \param kad ... 6582!> \param kac ... 6583!> \param pbd ... 6584!> \param pbc ... 6585!> \param pad ... 6586!> \param pac ... 6587!> \param prim ... 6588!> \param scale ... 6589! ************************************************************************************************** 6590 SUBROUTINE block_1_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6591 REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(1*2), kac(1*1), & 6592 pbd(2*2), pbc(2*1), pad(1*2), & 6593 pac(1*1), prim(1*2*1*2), scale 6594 6595 INTEGER :: ma, mb, mc, md, p_index 6596 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6597 6598 kbd(1:2*2) = 0.0_dp 6599 kbc(1:2*1) = 0.0_dp 6600 kad(1:1*2) = 0.0_dp 6601 kac(1:1*1) = 0.0_dp 6602 p_index = 0 6603 DO md = 1, 2 6604 DO mc = 1, 1 6605 DO mb = 1, 2 6606 ks_bd = 0.0_dp 6607 ks_bc = 0.0_dp 6608 p_bd = pbd((md - 1)*2 + mb) 6609 p_bc = pbc((mc - 1)*2 + mb) 6610 DO ma = 1, 1 6611 p_index = p_index + 1 6612 tmp = scale*prim(p_index) 6613 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6614 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6615 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6616 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6617 END DO 6618 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6619 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6620 END DO 6621 END DO 6622 END DO 6623 END SUBROUTINE block_1_2_1_2 6624! ************************************************************************************************** 6625!> \brief ... 6626!> \param kbd ... 6627!> \param kbc ... 6628!> \param kad ... 6629!> \param kac ... 6630!> \param pbd ... 6631!> \param pbc ... 6632!> \param pad ... 6633!> \param pac ... 6634!> \param prim ... 6635!> \param scale ... 6636! ************************************************************************************************** 6637 SUBROUTINE block_1_2_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6638 REAL(KIND=dp) :: kbd(2*3), kbc(2*1), kad(1*3), kac(1*1), & 6639 pbd(2*3), pbc(2*1), pad(1*3), & 6640 pac(1*1), prim(1*2*1*3), scale 6641 6642 INTEGER :: ma, mb, mc, md, p_index 6643 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6644 6645 kbd(1:2*3) = 0.0_dp 6646 kbc(1:2*1) = 0.0_dp 6647 kad(1:1*3) = 0.0_dp 6648 kac(1:1*1) = 0.0_dp 6649 p_index = 0 6650 DO md = 1, 3 6651 DO mc = 1, 1 6652 DO mb = 1, 2 6653 ks_bd = 0.0_dp 6654 ks_bc = 0.0_dp 6655 p_bd = pbd((md - 1)*2 + mb) 6656 p_bc = pbc((mc - 1)*2 + mb) 6657 DO ma = 1, 1 6658 p_index = p_index + 1 6659 tmp = scale*prim(p_index) 6660 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6661 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6662 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6663 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6664 END DO 6665 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6666 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6667 END DO 6668 END DO 6669 END DO 6670 END SUBROUTINE block_1_2_1_3 6671! ************************************************************************************************** 6672!> \brief ... 6673!> \param kbd ... 6674!> \param kbc ... 6675!> \param kad ... 6676!> \param kac ... 6677!> \param pbd ... 6678!> \param pbc ... 6679!> \param pad ... 6680!> \param pac ... 6681!> \param prim ... 6682!> \param scale ... 6683! ************************************************************************************************** 6684 SUBROUTINE block_1_2_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6685 REAL(KIND=dp) :: kbd(2*4), kbc(2*1), kad(1*4), kac(1*1), & 6686 pbd(2*4), pbc(2*1), pad(1*4), & 6687 pac(1*1), prim(1*2*1*4), scale 6688 6689 INTEGER :: ma, mb, mc, md, p_index 6690 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6691 6692 kbd(1:2*4) = 0.0_dp 6693 kbc(1:2*1) = 0.0_dp 6694 kad(1:1*4) = 0.0_dp 6695 kac(1:1*1) = 0.0_dp 6696 p_index = 0 6697 DO md = 1, 4 6698 DO mc = 1, 1 6699 DO mb = 1, 2 6700 ks_bd = 0.0_dp 6701 ks_bc = 0.0_dp 6702 p_bd = pbd((md - 1)*2 + mb) 6703 p_bc = pbc((mc - 1)*2 + mb) 6704 DO ma = 1, 1 6705 p_index = p_index + 1 6706 tmp = scale*prim(p_index) 6707 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6708 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6709 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6710 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6711 END DO 6712 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6713 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6714 END DO 6715 END DO 6716 END DO 6717 END SUBROUTINE block_1_2_1_4 6718! ************************************************************************************************** 6719!> \brief ... 6720!> \param kbd ... 6721!> \param kbc ... 6722!> \param kad ... 6723!> \param kac ... 6724!> \param pbd ... 6725!> \param pbc ... 6726!> \param pad ... 6727!> \param pac ... 6728!> \param prim ... 6729!> \param scale ... 6730! ************************************************************************************************** 6731 SUBROUTINE block_1_2_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6732 REAL(KIND=dp) :: kbd(2*5), kbc(2*1), kad(1*5), kac(1*1), & 6733 pbd(2*5), pbc(2*1), pad(1*5), & 6734 pac(1*1), prim(1*2*1*5), scale 6735 6736 INTEGER :: ma, mb, mc, md, p_index 6737 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6738 6739 kbd(1:2*5) = 0.0_dp 6740 kbc(1:2*1) = 0.0_dp 6741 kad(1:1*5) = 0.0_dp 6742 kac(1:1*1) = 0.0_dp 6743 p_index = 0 6744 DO md = 1, 5 6745 DO mc = 1, 1 6746 DO mb = 1, 2 6747 ks_bd = 0.0_dp 6748 ks_bc = 0.0_dp 6749 p_bd = pbd((md - 1)*2 + mb) 6750 p_bc = pbc((mc - 1)*2 + mb) 6751 DO ma = 1, 1 6752 p_index = p_index + 1 6753 tmp = scale*prim(p_index) 6754 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6755 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6756 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6757 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6758 END DO 6759 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6760 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6761 END DO 6762 END DO 6763 END DO 6764 END SUBROUTINE block_1_2_1_5 6765! ************************************************************************************************** 6766!> \brief ... 6767!> \param kbd ... 6768!> \param kbc ... 6769!> \param kad ... 6770!> \param kac ... 6771!> \param pbd ... 6772!> \param pbc ... 6773!> \param pad ... 6774!> \param pac ... 6775!> \param prim ... 6776!> \param scale ... 6777! ************************************************************************************************** 6778 SUBROUTINE block_1_2_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6779 REAL(KIND=dp) :: kbd(2*6), kbc(2*1), kad(1*6), kac(1*1), & 6780 pbd(2*6), pbc(2*1), pad(1*6), & 6781 pac(1*1), prim(1*2*1*6), scale 6782 6783 INTEGER :: ma, mb, mc, md, p_index 6784 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6785 6786 kbd(1:2*6) = 0.0_dp 6787 kbc(1:2*1) = 0.0_dp 6788 kad(1:1*6) = 0.0_dp 6789 kac(1:1*1) = 0.0_dp 6790 p_index = 0 6791 DO md = 1, 6 6792 DO mc = 1, 1 6793 DO mb = 1, 2 6794 ks_bd = 0.0_dp 6795 ks_bc = 0.0_dp 6796 p_bd = pbd((md - 1)*2 + mb) 6797 p_bc = pbc((mc - 1)*2 + mb) 6798 DO ma = 1, 1 6799 p_index = p_index + 1 6800 tmp = scale*prim(p_index) 6801 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6802 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6803 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6804 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6805 END DO 6806 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6807 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6808 END DO 6809 END DO 6810 END DO 6811 END SUBROUTINE block_1_2_1_6 6812! ************************************************************************************************** 6813!> \brief ... 6814!> \param kbd ... 6815!> \param kbc ... 6816!> \param kad ... 6817!> \param kac ... 6818!> \param pbd ... 6819!> \param pbc ... 6820!> \param pad ... 6821!> \param pac ... 6822!> \param prim ... 6823!> \param scale ... 6824! ************************************************************************************************** 6825 SUBROUTINE block_1_2_1_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6826 REAL(KIND=dp) :: kbd(2*7), kbc(2*1), kad(1*7), kac(1*1), & 6827 pbd(2*7), pbc(2*1), pad(1*7), & 6828 pac(1*1), prim(1*2*1*7), scale 6829 6830 INTEGER :: ma, mb, mc, md, p_index 6831 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6832 6833 kbd(1:2*7) = 0.0_dp 6834 kbc(1:2*1) = 0.0_dp 6835 kad(1:1*7) = 0.0_dp 6836 kac(1:1*1) = 0.0_dp 6837 p_index = 0 6838 DO md = 1, 7 6839 DO mc = 1, 1 6840 DO mb = 1, 2 6841 ks_bd = 0.0_dp 6842 ks_bc = 0.0_dp 6843 p_bd = pbd((md - 1)*2 + mb) 6844 p_bc = pbc((mc - 1)*2 + mb) 6845 DO ma = 1, 1 6846 p_index = p_index + 1 6847 tmp = scale*prim(p_index) 6848 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6849 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6850 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6851 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6852 END DO 6853 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6854 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6855 END DO 6856 END DO 6857 END DO 6858 END SUBROUTINE block_1_2_1_7 6859! ************************************************************************************************** 6860!> \brief ... 6861!> \param kbd ... 6862!> \param kbc ... 6863!> \param kad ... 6864!> \param kac ... 6865!> \param pbd ... 6866!> \param pbc ... 6867!> \param pad ... 6868!> \param pac ... 6869!> \param prim ... 6870!> \param scale ... 6871! ************************************************************************************************** 6872 SUBROUTINE block_1_2_1_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6873 REAL(KIND=dp) :: kbd(2*9), kbc(2*1), kad(1*9), kac(1*1), & 6874 pbd(2*9), pbc(2*1), pad(1*9), & 6875 pac(1*1), prim(1*2*1*9), scale 6876 6877 INTEGER :: ma, mb, mc, md, p_index 6878 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6879 6880 kbd(1:2*9) = 0.0_dp 6881 kbc(1:2*1) = 0.0_dp 6882 kad(1:1*9) = 0.0_dp 6883 kac(1:1*1) = 0.0_dp 6884 p_index = 0 6885 DO md = 1, 9 6886 DO mc = 1, 1 6887 DO mb = 1, 2 6888 ks_bd = 0.0_dp 6889 ks_bc = 0.0_dp 6890 p_bd = pbd((md - 1)*2 + mb) 6891 p_bc = pbc((mc - 1)*2 + mb) 6892 DO ma = 1, 1 6893 p_index = p_index + 1 6894 tmp = scale*prim(p_index) 6895 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6896 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6897 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6898 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6899 END DO 6900 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6901 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6902 END DO 6903 END DO 6904 END DO 6905 END SUBROUTINE block_1_2_1_9 6906! ************************************************************************************************** 6907!> \brief ... 6908!> \param md_max ... 6909!> \param kbd ... 6910!> \param kbc ... 6911!> \param kad ... 6912!> \param kac ... 6913!> \param pbd ... 6914!> \param pbc ... 6915!> \param pad ... 6916!> \param pac ... 6917!> \param prim ... 6918!> \param scale ... 6919! ************************************************************************************************** 6920 SUBROUTINE block_1_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6921 INTEGER :: md_max 6922 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(1*md_max), kac(1*1), pbd(2*md_max), pbc(2*1), & 6923 pad(1*md_max), pac(1*1), prim(1*2*1*md_max), scale 6924 6925 INTEGER :: ma, mb, mc, md, p_index 6926 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6927 6928 kbd(1:2*md_max) = 0.0_dp 6929 kbc(1:2*1) = 0.0_dp 6930 kad(1:1*md_max) = 0.0_dp 6931 kac(1:1*1) = 0.0_dp 6932 p_index = 0 6933 DO md = 1, md_max 6934 DO mc = 1, 1 6935 DO mb = 1, 2 6936 ks_bd = 0.0_dp 6937 ks_bc = 0.0_dp 6938 p_bd = pbd((md - 1)*2 + mb) 6939 p_bc = pbc((mc - 1)*2 + mb) 6940 DO ma = 1, 1 6941 p_index = p_index + 1 6942 tmp = scale*prim(p_index) 6943 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6944 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6945 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6946 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6947 END DO 6948 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6949 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6950 END DO 6951 END DO 6952 END DO 6953 END SUBROUTINE block_1_2_1 6954! ************************************************************************************************** 6955!> \brief ... 6956!> \param kbd ... 6957!> \param kbc ... 6958!> \param kad ... 6959!> \param kac ... 6960!> \param pbd ... 6961!> \param pbc ... 6962!> \param pad ... 6963!> \param pac ... 6964!> \param prim ... 6965!> \param scale ... 6966! ************************************************************************************************** 6967 SUBROUTINE block_1_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 6968 REAL(KIND=dp) :: kbd(2*1), kbc(2*2), kad(1*1), kac(1*2), & 6969 pbd(2*1), pbc(2*2), pad(1*1), & 6970 pac(1*2), prim(1*2*2*1), scale 6971 6972 INTEGER :: ma, mb, mc, md, p_index 6973 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 6974 6975 kbd(1:2*1) = 0.0_dp 6976 kbc(1:2*2) = 0.0_dp 6977 kad(1:1*1) = 0.0_dp 6978 kac(1:1*2) = 0.0_dp 6979 p_index = 0 6980 DO md = 1, 1 6981 DO mc = 1, 2 6982 DO mb = 1, 2 6983 ks_bd = 0.0_dp 6984 ks_bc = 0.0_dp 6985 p_bd = pbd((md - 1)*2 + mb) 6986 p_bc = pbc((mc - 1)*2 + mb) 6987 DO ma = 1, 1 6988 p_index = p_index + 1 6989 tmp = scale*prim(p_index) 6990 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 6991 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 6992 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 6993 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 6994 END DO 6995 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 6996 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 6997 END DO 6998 END DO 6999 END DO 7000 END SUBROUTINE block_1_2_2_1 7001! ************************************************************************************************** 7002!> \brief ... 7003!> \param kbd ... 7004!> \param kbc ... 7005!> \param kad ... 7006!> \param kac ... 7007!> \param pbd ... 7008!> \param pbc ... 7009!> \param pad ... 7010!> \param pac ... 7011!> \param prim ... 7012!> \param scale ... 7013! ************************************************************************************************** 7014 SUBROUTINE block_1_2_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7015 REAL(KIND=dp) :: kbd(2*2), kbc(2*2), kad(1*2), kac(1*2), & 7016 pbd(2*2), pbc(2*2), pad(1*2), & 7017 pac(1*2), prim(1*2*2*2), scale 7018 7019 INTEGER :: ma, mb, mc, md, p_index 7020 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7021 7022 kbd(1:2*2) = 0.0_dp 7023 kbc(1:2*2) = 0.0_dp 7024 kad(1:1*2) = 0.0_dp 7025 kac(1:1*2) = 0.0_dp 7026 p_index = 0 7027 DO md = 1, 2 7028 DO mc = 1, 2 7029 DO mb = 1, 2 7030 ks_bd = 0.0_dp 7031 ks_bc = 0.0_dp 7032 p_bd = pbd((md - 1)*2 + mb) 7033 p_bc = pbc((mc - 1)*2 + mb) 7034 DO ma = 1, 1 7035 p_index = p_index + 1 7036 tmp = scale*prim(p_index) 7037 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7038 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7039 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7040 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7041 END DO 7042 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7043 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7044 END DO 7045 END DO 7046 END DO 7047 END SUBROUTINE block_1_2_2_2 7048! ************************************************************************************************** 7049!> \brief ... 7050!> \param kbd ... 7051!> \param kbc ... 7052!> \param kad ... 7053!> \param kac ... 7054!> \param pbd ... 7055!> \param pbc ... 7056!> \param pad ... 7057!> \param pac ... 7058!> \param prim ... 7059!> \param scale ... 7060! ************************************************************************************************** 7061 SUBROUTINE block_1_2_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7062 REAL(KIND=dp) :: kbd(2*3), kbc(2*2), kad(1*3), kac(1*2), & 7063 pbd(2*3), pbc(2*2), pad(1*3), & 7064 pac(1*2), prim(1*2*2*3), scale 7065 7066 INTEGER :: ma, mb, mc, md, p_index 7067 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7068 7069 kbd(1:2*3) = 0.0_dp 7070 kbc(1:2*2) = 0.0_dp 7071 kad(1:1*3) = 0.0_dp 7072 kac(1:1*2) = 0.0_dp 7073 p_index = 0 7074 DO md = 1, 3 7075 DO mc = 1, 2 7076 DO mb = 1, 2 7077 ks_bd = 0.0_dp 7078 ks_bc = 0.0_dp 7079 p_bd = pbd((md - 1)*2 + mb) 7080 p_bc = pbc((mc - 1)*2 + mb) 7081 DO ma = 1, 1 7082 p_index = p_index + 1 7083 tmp = scale*prim(p_index) 7084 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7085 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7086 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7087 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7088 END DO 7089 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7090 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7091 END DO 7092 END DO 7093 END DO 7094 END SUBROUTINE block_1_2_2_3 7095! ************************************************************************************************** 7096!> \brief ... 7097!> \param kbd ... 7098!> \param kbc ... 7099!> \param kad ... 7100!> \param kac ... 7101!> \param pbd ... 7102!> \param pbc ... 7103!> \param pad ... 7104!> \param pac ... 7105!> \param prim ... 7106!> \param scale ... 7107! ************************************************************************************************** 7108 SUBROUTINE block_1_2_2_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7109 REAL(KIND=dp) :: kbd(2*4), kbc(2*2), kad(1*4), kac(1*2), & 7110 pbd(2*4), pbc(2*2), pad(1*4), & 7111 pac(1*2), prim(1*2*2*4), scale 7112 7113 INTEGER :: ma, mb, mc, md, p_index 7114 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7115 7116 kbd(1:2*4) = 0.0_dp 7117 kbc(1:2*2) = 0.0_dp 7118 kad(1:1*4) = 0.0_dp 7119 kac(1:1*2) = 0.0_dp 7120 p_index = 0 7121 DO md = 1, 4 7122 DO mc = 1, 2 7123 DO mb = 1, 2 7124 ks_bd = 0.0_dp 7125 ks_bc = 0.0_dp 7126 p_bd = pbd((md - 1)*2 + mb) 7127 p_bc = pbc((mc - 1)*2 + mb) 7128 DO ma = 1, 1 7129 p_index = p_index + 1 7130 tmp = scale*prim(p_index) 7131 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7132 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7133 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7134 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7135 END DO 7136 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7137 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7138 END DO 7139 END DO 7140 END DO 7141 END SUBROUTINE block_1_2_2_4 7142! ************************************************************************************************** 7143!> \brief ... 7144!> \param md_max ... 7145!> \param kbd ... 7146!> \param kbc ... 7147!> \param kad ... 7148!> \param kac ... 7149!> \param pbd ... 7150!> \param pbc ... 7151!> \param pad ... 7152!> \param pac ... 7153!> \param prim ... 7154!> \param scale ... 7155! ************************************************************************************************** 7156 SUBROUTINE block_1_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7157 INTEGER :: md_max 7158 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*2), kad(1*md_max), kac(1*2), pbd(2*md_max), pbc(2*2), & 7159 pad(1*md_max), pac(1*2), prim(1*2*2*md_max), scale 7160 7161 INTEGER :: ma, mb, mc, md, p_index 7162 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7163 7164 kbd(1:2*md_max) = 0.0_dp 7165 kbc(1:2*2) = 0.0_dp 7166 kad(1:1*md_max) = 0.0_dp 7167 kac(1:1*2) = 0.0_dp 7168 p_index = 0 7169 DO md = 1, md_max 7170 DO mc = 1, 2 7171 DO mb = 1, 2 7172 ks_bd = 0.0_dp 7173 ks_bc = 0.0_dp 7174 p_bd = pbd((md - 1)*2 + mb) 7175 p_bc = pbc((mc - 1)*2 + mb) 7176 DO ma = 1, 1 7177 p_index = p_index + 1 7178 tmp = scale*prim(p_index) 7179 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7180 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7181 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7182 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7183 END DO 7184 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7185 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7186 END DO 7187 END DO 7188 END DO 7189 END SUBROUTINE block_1_2_2 7190! ************************************************************************************************** 7191!> \brief ... 7192!> \param kbd ... 7193!> \param kbc ... 7194!> \param kad ... 7195!> \param kac ... 7196!> \param pbd ... 7197!> \param pbc ... 7198!> \param pad ... 7199!> \param pac ... 7200!> \param prim ... 7201!> \param scale ... 7202! ************************************************************************************************** 7203 SUBROUTINE block_1_2_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7204 REAL(KIND=dp) :: kbd(2*1), kbc(2*3), kad(1*1), kac(1*3), & 7205 pbd(2*1), pbc(2*3), pad(1*1), & 7206 pac(1*3), prim(1*2*3*1), scale 7207 7208 INTEGER :: ma, mb, mc, md, p_index 7209 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7210 7211 kbd(1:2*1) = 0.0_dp 7212 kbc(1:2*3) = 0.0_dp 7213 kad(1:1*1) = 0.0_dp 7214 kac(1:1*3) = 0.0_dp 7215 p_index = 0 7216 DO md = 1, 1 7217 DO mc = 1, 3 7218 DO mb = 1, 2 7219 ks_bd = 0.0_dp 7220 ks_bc = 0.0_dp 7221 p_bd = pbd((md - 1)*2 + mb) 7222 p_bc = pbc((mc - 1)*2 + mb) 7223 DO ma = 1, 1 7224 p_index = p_index + 1 7225 tmp = scale*prim(p_index) 7226 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7227 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7228 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7229 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7230 END DO 7231 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7232 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7233 END DO 7234 END DO 7235 END DO 7236 END SUBROUTINE block_1_2_3_1 7237! ************************************************************************************************** 7238!> \brief ... 7239!> \param kbd ... 7240!> \param kbc ... 7241!> \param kad ... 7242!> \param kac ... 7243!> \param pbd ... 7244!> \param pbc ... 7245!> \param pad ... 7246!> \param pac ... 7247!> \param prim ... 7248!> \param scale ... 7249! ************************************************************************************************** 7250 SUBROUTINE block_1_2_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7251 REAL(KIND=dp) :: kbd(2*2), kbc(2*3), kad(1*2), kac(1*3), & 7252 pbd(2*2), pbc(2*3), pad(1*2), & 7253 pac(1*3), prim(1*2*3*2), scale 7254 7255 INTEGER :: ma, mb, mc, md, p_index 7256 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7257 7258 kbd(1:2*2) = 0.0_dp 7259 kbc(1:2*3) = 0.0_dp 7260 kad(1:1*2) = 0.0_dp 7261 kac(1:1*3) = 0.0_dp 7262 p_index = 0 7263 DO md = 1, 2 7264 DO mc = 1, 3 7265 DO mb = 1, 2 7266 ks_bd = 0.0_dp 7267 ks_bc = 0.0_dp 7268 p_bd = pbd((md - 1)*2 + mb) 7269 p_bc = pbc((mc - 1)*2 + mb) 7270 DO ma = 1, 1 7271 p_index = p_index + 1 7272 tmp = scale*prim(p_index) 7273 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7274 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7275 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7276 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7277 END DO 7278 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7279 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7280 END DO 7281 END DO 7282 END DO 7283 END SUBROUTINE block_1_2_3_2 7284! ************************************************************************************************** 7285!> \brief ... 7286!> \param kbd ... 7287!> \param kbc ... 7288!> \param kad ... 7289!> \param kac ... 7290!> \param pbd ... 7291!> \param pbc ... 7292!> \param pad ... 7293!> \param pac ... 7294!> \param prim ... 7295!> \param scale ... 7296! ************************************************************************************************** 7297 SUBROUTINE block_1_2_3_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7298 REAL(KIND=dp) :: kbd(2*3), kbc(2*3), kad(1*3), kac(1*3), & 7299 pbd(2*3), pbc(2*3), pad(1*3), & 7300 pac(1*3), prim(1*2*3*3), scale 7301 7302 INTEGER :: ma, mb, mc, md, p_index 7303 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7304 7305 kbd(1:2*3) = 0.0_dp 7306 kbc(1:2*3) = 0.0_dp 7307 kad(1:1*3) = 0.0_dp 7308 kac(1:1*3) = 0.0_dp 7309 p_index = 0 7310 DO md = 1, 3 7311 DO mc = 1, 3 7312 DO mb = 1, 2 7313 ks_bd = 0.0_dp 7314 ks_bc = 0.0_dp 7315 p_bd = pbd((md - 1)*2 + mb) 7316 p_bc = pbc((mc - 1)*2 + mb) 7317 DO ma = 1, 1 7318 p_index = p_index + 1 7319 tmp = scale*prim(p_index) 7320 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7321 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7322 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7323 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7324 END DO 7325 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7326 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7327 END DO 7328 END DO 7329 END DO 7330 END SUBROUTINE block_1_2_3_3 7331! ************************************************************************************************** 7332!> \brief ... 7333!> \param md_max ... 7334!> \param kbd ... 7335!> \param kbc ... 7336!> \param kad ... 7337!> \param kac ... 7338!> \param pbd ... 7339!> \param pbc ... 7340!> \param pad ... 7341!> \param pac ... 7342!> \param prim ... 7343!> \param scale ... 7344! ************************************************************************************************** 7345 SUBROUTINE block_1_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7346 INTEGER :: md_max 7347 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*3), kad(1*md_max), kac(1*3), pbd(2*md_max), pbc(2*3), & 7348 pad(1*md_max), pac(1*3), prim(1*2*3*md_max), scale 7349 7350 INTEGER :: ma, mb, mc, md, p_index 7351 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7352 7353 kbd(1:2*md_max) = 0.0_dp 7354 kbc(1:2*3) = 0.0_dp 7355 kad(1:1*md_max) = 0.0_dp 7356 kac(1:1*3) = 0.0_dp 7357 p_index = 0 7358 DO md = 1, md_max 7359 DO mc = 1, 3 7360 DO mb = 1, 2 7361 ks_bd = 0.0_dp 7362 ks_bc = 0.0_dp 7363 p_bd = pbd((md - 1)*2 + mb) 7364 p_bc = pbc((mc - 1)*2 + mb) 7365 DO ma = 1, 1 7366 p_index = p_index + 1 7367 tmp = scale*prim(p_index) 7368 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7369 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7370 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7371 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7372 END DO 7373 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7374 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7375 END DO 7376 END DO 7377 END DO 7378 END SUBROUTINE block_1_2_3 7379! ************************************************************************************************** 7380!> \brief ... 7381!> \param kbd ... 7382!> \param kbc ... 7383!> \param kad ... 7384!> \param kac ... 7385!> \param pbd ... 7386!> \param pbc ... 7387!> \param pad ... 7388!> \param pac ... 7389!> \param prim ... 7390!> \param scale ... 7391! ************************************************************************************************** 7392 SUBROUTINE block_1_2_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7393 REAL(KIND=dp) :: kbd(2*1), kbc(2*4), kad(1*1), kac(1*4), & 7394 pbd(2*1), pbc(2*4), pad(1*1), & 7395 pac(1*4), prim(1*2*4*1), scale 7396 7397 INTEGER :: ma, mb, mc, md, p_index 7398 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7399 7400 kbd(1:2*1) = 0.0_dp 7401 kbc(1:2*4) = 0.0_dp 7402 kad(1:1*1) = 0.0_dp 7403 kac(1:1*4) = 0.0_dp 7404 p_index = 0 7405 DO md = 1, 1 7406 DO mc = 1, 4 7407 DO mb = 1, 2 7408 ks_bd = 0.0_dp 7409 ks_bc = 0.0_dp 7410 p_bd = pbd((md - 1)*2 + mb) 7411 p_bc = pbc((mc - 1)*2 + mb) 7412 DO ma = 1, 1 7413 p_index = p_index + 1 7414 tmp = scale*prim(p_index) 7415 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7416 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7417 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7418 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7419 END DO 7420 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7421 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7422 END DO 7423 END DO 7424 END DO 7425 END SUBROUTINE block_1_2_4_1 7426! ************************************************************************************************** 7427!> \brief ... 7428!> \param kbd ... 7429!> \param kbc ... 7430!> \param kad ... 7431!> \param kac ... 7432!> \param pbd ... 7433!> \param pbc ... 7434!> \param pad ... 7435!> \param pac ... 7436!> \param prim ... 7437!> \param scale ... 7438! ************************************************************************************************** 7439 SUBROUTINE block_1_2_4_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7440 REAL(KIND=dp) :: kbd(2*2), kbc(2*4), kad(1*2), kac(1*4), & 7441 pbd(2*2), pbc(2*4), pad(1*2), & 7442 pac(1*4), prim(1*2*4*2), scale 7443 7444 INTEGER :: ma, mb, mc, md, p_index 7445 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7446 7447 kbd(1:2*2) = 0.0_dp 7448 kbc(1:2*4) = 0.0_dp 7449 kad(1:1*2) = 0.0_dp 7450 kac(1:1*4) = 0.0_dp 7451 p_index = 0 7452 DO md = 1, 2 7453 DO mc = 1, 4 7454 DO mb = 1, 2 7455 ks_bd = 0.0_dp 7456 ks_bc = 0.0_dp 7457 p_bd = pbd((md - 1)*2 + mb) 7458 p_bc = pbc((mc - 1)*2 + mb) 7459 DO ma = 1, 1 7460 p_index = p_index + 1 7461 tmp = scale*prim(p_index) 7462 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7463 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7464 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7465 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7466 END DO 7467 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7468 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7469 END DO 7470 END DO 7471 END DO 7472 END SUBROUTINE block_1_2_4_2 7473! ************************************************************************************************** 7474!> \brief ... 7475!> \param md_max ... 7476!> \param kbd ... 7477!> \param kbc ... 7478!> \param kad ... 7479!> \param kac ... 7480!> \param pbd ... 7481!> \param pbc ... 7482!> \param pad ... 7483!> \param pac ... 7484!> \param prim ... 7485!> \param scale ... 7486! ************************************************************************************************** 7487 SUBROUTINE block_1_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7488 INTEGER :: md_max 7489 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*4), kad(1*md_max), kac(1*4), pbd(2*md_max), pbc(2*4), & 7490 pad(1*md_max), pac(1*4), prim(1*2*4*md_max), scale 7491 7492 INTEGER :: ma, mb, mc, md, p_index 7493 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7494 7495 kbd(1:2*md_max) = 0.0_dp 7496 kbc(1:2*4) = 0.0_dp 7497 kad(1:1*md_max) = 0.0_dp 7498 kac(1:1*4) = 0.0_dp 7499 p_index = 0 7500 DO md = 1, md_max 7501 DO mc = 1, 4 7502 DO mb = 1, 2 7503 ks_bd = 0.0_dp 7504 ks_bc = 0.0_dp 7505 p_bd = pbd((md - 1)*2 + mb) 7506 p_bc = pbc((mc - 1)*2 + mb) 7507 DO ma = 1, 1 7508 p_index = p_index + 1 7509 tmp = scale*prim(p_index) 7510 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7511 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7512 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7513 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7514 END DO 7515 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7516 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7517 END DO 7518 END DO 7519 END DO 7520 END SUBROUTINE block_1_2_4 7521! ************************************************************************************************** 7522!> \brief ... 7523!> \param kbd ... 7524!> \param kbc ... 7525!> \param kad ... 7526!> \param kac ... 7527!> \param pbd ... 7528!> \param pbc ... 7529!> \param pad ... 7530!> \param pac ... 7531!> \param prim ... 7532!> \param scale ... 7533! ************************************************************************************************** 7534 SUBROUTINE block_1_2_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7535 REAL(KIND=dp) :: kbd(2*1), kbc(2*5), kad(1*1), kac(1*5), & 7536 pbd(2*1), pbc(2*5), pad(1*1), & 7537 pac(1*5), prim(1*2*5*1), scale 7538 7539 INTEGER :: ma, mb, mc, md, p_index 7540 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7541 7542 kbd(1:2*1) = 0.0_dp 7543 kbc(1:2*5) = 0.0_dp 7544 kad(1:1*1) = 0.0_dp 7545 kac(1:1*5) = 0.0_dp 7546 p_index = 0 7547 DO md = 1, 1 7548 DO mc = 1, 5 7549 DO mb = 1, 2 7550 ks_bd = 0.0_dp 7551 ks_bc = 0.0_dp 7552 p_bd = pbd((md - 1)*2 + mb) 7553 p_bc = pbc((mc - 1)*2 + mb) 7554 DO ma = 1, 1 7555 p_index = p_index + 1 7556 tmp = scale*prim(p_index) 7557 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7558 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7559 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7560 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7561 END DO 7562 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7563 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7564 END DO 7565 END DO 7566 END DO 7567 END SUBROUTINE block_1_2_5_1 7568! ************************************************************************************************** 7569!> \brief ... 7570!> \param md_max ... 7571!> \param kbd ... 7572!> \param kbc ... 7573!> \param kad ... 7574!> \param kac ... 7575!> \param pbd ... 7576!> \param pbc ... 7577!> \param pad ... 7578!> \param pac ... 7579!> \param prim ... 7580!> \param scale ... 7581! ************************************************************************************************** 7582 SUBROUTINE block_1_2_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7583 INTEGER :: md_max 7584 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*5), kad(1*md_max), kac(1*5), pbd(2*md_max), pbc(2*5), & 7585 pad(1*md_max), pac(1*5), prim(1*2*5*md_max), scale 7586 7587 INTEGER :: ma, mb, mc, md, p_index 7588 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7589 7590 kbd(1:2*md_max) = 0.0_dp 7591 kbc(1:2*5) = 0.0_dp 7592 kad(1:1*md_max) = 0.0_dp 7593 kac(1:1*5) = 0.0_dp 7594 p_index = 0 7595 DO md = 1, md_max 7596 DO mc = 1, 5 7597 DO mb = 1, 2 7598 ks_bd = 0.0_dp 7599 ks_bc = 0.0_dp 7600 p_bd = pbd((md - 1)*2 + mb) 7601 p_bc = pbc((mc - 1)*2 + mb) 7602 DO ma = 1, 1 7603 p_index = p_index + 1 7604 tmp = scale*prim(p_index) 7605 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7606 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7607 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7608 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7609 END DO 7610 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7611 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7612 END DO 7613 END DO 7614 END DO 7615 END SUBROUTINE block_1_2_5 7616! ************************************************************************************************** 7617!> \brief ... 7618!> \param kbd ... 7619!> \param kbc ... 7620!> \param kad ... 7621!> \param kac ... 7622!> \param pbd ... 7623!> \param pbc ... 7624!> \param pad ... 7625!> \param pac ... 7626!> \param prim ... 7627!> \param scale ... 7628! ************************************************************************************************** 7629 SUBROUTINE block_1_2_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7630 REAL(KIND=dp) :: kbd(2*1), kbc(2*6), kad(1*1), kac(1*6), & 7631 pbd(2*1), pbc(2*6), pad(1*1), & 7632 pac(1*6), prim(1*2*6*1), scale 7633 7634 INTEGER :: ma, mb, mc, md, p_index 7635 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7636 7637 kbd(1:2*1) = 0.0_dp 7638 kbc(1:2*6) = 0.0_dp 7639 kad(1:1*1) = 0.0_dp 7640 kac(1:1*6) = 0.0_dp 7641 p_index = 0 7642 DO md = 1, 1 7643 DO mc = 1, 6 7644 DO mb = 1, 2 7645 ks_bd = 0.0_dp 7646 ks_bc = 0.0_dp 7647 p_bd = pbd((md - 1)*2 + mb) 7648 p_bc = pbc((mc - 1)*2 + mb) 7649 DO ma = 1, 1 7650 p_index = p_index + 1 7651 tmp = scale*prim(p_index) 7652 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7653 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7654 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7655 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7656 END DO 7657 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7658 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7659 END DO 7660 END DO 7661 END DO 7662 END SUBROUTINE block_1_2_6_1 7663! ************************************************************************************************** 7664!> \brief ... 7665!> \param md_max ... 7666!> \param kbd ... 7667!> \param kbc ... 7668!> \param kad ... 7669!> \param kac ... 7670!> \param pbd ... 7671!> \param pbc ... 7672!> \param pad ... 7673!> \param pac ... 7674!> \param prim ... 7675!> \param scale ... 7676! ************************************************************************************************** 7677 SUBROUTINE block_1_2_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7678 INTEGER :: md_max 7679 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*6), kad(1*md_max), kac(1*6), pbd(2*md_max), pbc(2*6), & 7680 pad(1*md_max), pac(1*6), prim(1*2*6*md_max), scale 7681 7682 INTEGER :: ma, mb, mc, md, p_index 7683 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7684 7685 kbd(1:2*md_max) = 0.0_dp 7686 kbc(1:2*6) = 0.0_dp 7687 kad(1:1*md_max) = 0.0_dp 7688 kac(1:1*6) = 0.0_dp 7689 p_index = 0 7690 DO md = 1, md_max 7691 DO mc = 1, 6 7692 DO mb = 1, 2 7693 ks_bd = 0.0_dp 7694 ks_bc = 0.0_dp 7695 p_bd = pbd((md - 1)*2 + mb) 7696 p_bc = pbc((mc - 1)*2 + mb) 7697 DO ma = 1, 1 7698 p_index = p_index + 1 7699 tmp = scale*prim(p_index) 7700 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7701 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7702 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7703 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7704 END DO 7705 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7706 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7707 END DO 7708 END DO 7709 END DO 7710 END SUBROUTINE block_1_2_6 7711! ************************************************************************************************** 7712!> \brief ... 7713!> \param kbd ... 7714!> \param kbc ... 7715!> \param kad ... 7716!> \param kac ... 7717!> \param pbd ... 7718!> \param pbc ... 7719!> \param pad ... 7720!> \param pac ... 7721!> \param prim ... 7722!> \param scale ... 7723! ************************************************************************************************** 7724 SUBROUTINE block_1_2_7_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7725 REAL(KIND=dp) :: kbd(2*1), kbc(2*7), kad(1*1), kac(1*7), & 7726 pbd(2*1), pbc(2*7), pad(1*1), & 7727 pac(1*7), prim(1*2*7*1), scale 7728 7729 INTEGER :: ma, mb, mc, md, p_index 7730 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7731 7732 kbd(1:2*1) = 0.0_dp 7733 kbc(1:2*7) = 0.0_dp 7734 kad(1:1*1) = 0.0_dp 7735 kac(1:1*7) = 0.0_dp 7736 p_index = 0 7737 DO md = 1, 1 7738 DO mc = 1, 7 7739 DO mb = 1, 2 7740 ks_bd = 0.0_dp 7741 ks_bc = 0.0_dp 7742 p_bd = pbd((md - 1)*2 + mb) 7743 p_bc = pbc((mc - 1)*2 + mb) 7744 DO ma = 1, 1 7745 p_index = p_index + 1 7746 tmp = scale*prim(p_index) 7747 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7748 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7749 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7750 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7751 END DO 7752 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7753 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7754 END DO 7755 END DO 7756 END DO 7757 END SUBROUTINE block_1_2_7_1 7758! ************************************************************************************************** 7759!> \brief ... 7760!> \param md_max ... 7761!> \param kbd ... 7762!> \param kbc ... 7763!> \param kad ... 7764!> \param kac ... 7765!> \param pbd ... 7766!> \param pbc ... 7767!> \param pad ... 7768!> \param pac ... 7769!> \param prim ... 7770!> \param scale ... 7771! ************************************************************************************************** 7772 SUBROUTINE block_1_2_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7773 INTEGER :: md_max 7774 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*7), kad(1*md_max), kac(1*7), pbd(2*md_max), pbc(2*7), & 7775 pad(1*md_max), pac(1*7), prim(1*2*7*md_max), scale 7776 7777 INTEGER :: ma, mb, mc, md, p_index 7778 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7779 7780 kbd(1:2*md_max) = 0.0_dp 7781 kbc(1:2*7) = 0.0_dp 7782 kad(1:1*md_max) = 0.0_dp 7783 kac(1:1*7) = 0.0_dp 7784 p_index = 0 7785 DO md = 1, md_max 7786 DO mc = 1, 7 7787 DO mb = 1, 2 7788 ks_bd = 0.0_dp 7789 ks_bc = 0.0_dp 7790 p_bd = pbd((md - 1)*2 + mb) 7791 p_bc = pbc((mc - 1)*2 + mb) 7792 DO ma = 1, 1 7793 p_index = p_index + 1 7794 tmp = scale*prim(p_index) 7795 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7796 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7797 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7798 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7799 END DO 7800 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7801 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7802 END DO 7803 END DO 7804 END DO 7805 END SUBROUTINE block_1_2_7 7806! ************************************************************************************************** 7807!> \brief ... 7808!> \param kbd ... 7809!> \param kbc ... 7810!> \param kad ... 7811!> \param kac ... 7812!> \param pbd ... 7813!> \param pbc ... 7814!> \param pad ... 7815!> \param pac ... 7816!> \param prim ... 7817!> \param scale ... 7818! ************************************************************************************************** 7819 SUBROUTINE block_1_2_9_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7820 REAL(KIND=dp) :: kbd(2*1), kbc(2*9), kad(1*1), kac(1*9), & 7821 pbd(2*1), pbc(2*9), pad(1*1), & 7822 pac(1*9), prim(1*2*9*1), scale 7823 7824 INTEGER :: ma, mb, mc, md, p_index 7825 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7826 7827 kbd(1:2*1) = 0.0_dp 7828 kbc(1:2*9) = 0.0_dp 7829 kad(1:1*1) = 0.0_dp 7830 kac(1:1*9) = 0.0_dp 7831 p_index = 0 7832 DO md = 1, 1 7833 DO mc = 1, 9 7834 DO mb = 1, 2 7835 ks_bd = 0.0_dp 7836 ks_bc = 0.0_dp 7837 p_bd = pbd((md - 1)*2 + mb) 7838 p_bc = pbc((mc - 1)*2 + mb) 7839 DO ma = 1, 1 7840 p_index = p_index + 1 7841 tmp = scale*prim(p_index) 7842 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7843 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7844 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7845 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7846 END DO 7847 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7848 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7849 END DO 7850 END DO 7851 END DO 7852 END SUBROUTINE block_1_2_9_1 7853! ************************************************************************************************** 7854!> \brief ... 7855!> \param md_max ... 7856!> \param kbd ... 7857!> \param kbc ... 7858!> \param kad ... 7859!> \param kac ... 7860!> \param pbd ... 7861!> \param pbc ... 7862!> \param pad ... 7863!> \param pac ... 7864!> \param prim ... 7865!> \param scale ... 7866! ************************************************************************************************** 7867 SUBROUTINE block_1_2_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7868 INTEGER :: md_max 7869 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*9), kad(1*md_max), kac(1*9), pbd(2*md_max), pbc(2*9), & 7870 pad(1*md_max), pac(1*9), prim(1*2*9*md_max), scale 7871 7872 INTEGER :: ma, mb, mc, md, p_index 7873 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7874 7875 kbd(1:2*md_max) = 0.0_dp 7876 kbc(1:2*9) = 0.0_dp 7877 kad(1:1*md_max) = 0.0_dp 7878 kac(1:1*9) = 0.0_dp 7879 p_index = 0 7880 DO md = 1, md_max 7881 DO mc = 1, 9 7882 DO mb = 1, 2 7883 ks_bd = 0.0_dp 7884 ks_bc = 0.0_dp 7885 p_bd = pbd((md - 1)*2 + mb) 7886 p_bc = pbc((mc - 1)*2 + mb) 7887 DO ma = 1, 1 7888 p_index = p_index + 1 7889 tmp = scale*prim(p_index) 7890 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7891 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7892 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7893 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7894 END DO 7895 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7896 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7897 END DO 7898 END DO 7899 END DO 7900 END SUBROUTINE block_1_2_9 7901! ************************************************************************************************** 7902!> \brief ... 7903!> \param mc_max ... 7904!> \param md_max ... 7905!> \param kbd ... 7906!> \param kbc ... 7907!> \param kad ... 7908!> \param kac ... 7909!> \param pbd ... 7910!> \param pbc ... 7911!> \param pad ... 7912!> \param pac ... 7913!> \param prim ... 7914!> \param scale ... 7915! ************************************************************************************************** 7916 SUBROUTINE block_1_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7917 INTEGER :: mc_max, md_max 7918 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(1*md_max), kac(1*mc_max), pbd(2*md_max), & 7919 pbc(2*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*2*mc_max*md_max), scale 7920 7921 INTEGER :: ma, mb, mc, md, p_index 7922 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7923 7924 kbd(1:2*md_max) = 0.0_dp 7925 kbc(1:2*mc_max) = 0.0_dp 7926 kad(1:1*md_max) = 0.0_dp 7927 kac(1:1*mc_max) = 0.0_dp 7928 p_index = 0 7929 DO md = 1, md_max 7930 DO mc = 1, mc_max 7931 DO mb = 1, 2 7932 ks_bd = 0.0_dp 7933 ks_bc = 0.0_dp 7934 p_bd = pbd((md - 1)*2 + mb) 7935 p_bc = pbc((mc - 1)*2 + mb) 7936 DO ma = 1, 1 7937 p_index = p_index + 1 7938 tmp = scale*prim(p_index) 7939 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7940 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7941 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7942 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7943 END DO 7944 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 7945 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 7946 END DO 7947 END DO 7948 END DO 7949 END SUBROUTINE block_1_2 7950! ************************************************************************************************** 7951!> \brief ... 7952!> \param kbd ... 7953!> \param kbc ... 7954!> \param kad ... 7955!> \param kac ... 7956!> \param pbd ... 7957!> \param pbc ... 7958!> \param pad ... 7959!> \param pac ... 7960!> \param prim ... 7961!> \param scale ... 7962! ************************************************************************************************** 7963 SUBROUTINE block_1_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 7964 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(1*1), kac(1*1), & 7965 pbd(3*1), pbc(3*1), pad(1*1), & 7966 pac(1*1), prim(1*3*1*1), scale 7967 7968 INTEGER :: ma, mb, mc, md, p_index 7969 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 7970 7971 kbd(1:3*1) = 0.0_dp 7972 kbc(1:3*1) = 0.0_dp 7973 kad(1:1*1) = 0.0_dp 7974 kac(1:1*1) = 0.0_dp 7975 p_index = 0 7976 DO md = 1, 1 7977 DO mc = 1, 1 7978 DO mb = 1, 3 7979 ks_bd = 0.0_dp 7980 ks_bc = 0.0_dp 7981 p_bd = pbd((md - 1)*3 + mb) 7982 p_bc = pbc((mc - 1)*3 + mb) 7983 DO ma = 1, 1 7984 p_index = p_index + 1 7985 tmp = scale*prim(p_index) 7986 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 7987 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 7988 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 7989 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 7990 END DO 7991 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 7992 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 7993 END DO 7994 END DO 7995 END DO 7996 END SUBROUTINE block_1_3_1_1 7997! ************************************************************************************************** 7998!> \brief ... 7999!> \param kbd ... 8000!> \param kbc ... 8001!> \param kad ... 8002!> \param kac ... 8003!> \param pbd ... 8004!> \param pbc ... 8005!> \param pad ... 8006!> \param pac ... 8007!> \param prim ... 8008!> \param scale ... 8009! ************************************************************************************************** 8010 SUBROUTINE block_1_3_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8011 REAL(KIND=dp) :: kbd(3*2), kbc(3*1), kad(1*2), kac(1*1), & 8012 pbd(3*2), pbc(3*1), pad(1*2), & 8013 pac(1*1), prim(1*3*1*2), scale 8014 8015 INTEGER :: ma, mb, mc, md, p_index 8016 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8017 8018 kbd(1:3*2) = 0.0_dp 8019 kbc(1:3*1) = 0.0_dp 8020 kad(1:1*2) = 0.0_dp 8021 kac(1:1*1) = 0.0_dp 8022 p_index = 0 8023 DO md = 1, 2 8024 DO mc = 1, 1 8025 DO mb = 1, 3 8026 ks_bd = 0.0_dp 8027 ks_bc = 0.0_dp 8028 p_bd = pbd((md - 1)*3 + mb) 8029 p_bc = pbc((mc - 1)*3 + mb) 8030 DO ma = 1, 1 8031 p_index = p_index + 1 8032 tmp = scale*prim(p_index) 8033 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8034 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8035 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8036 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8037 END DO 8038 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8039 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8040 END DO 8041 END DO 8042 END DO 8043 END SUBROUTINE block_1_3_1_2 8044! ************************************************************************************************** 8045!> \brief ... 8046!> \param kbd ... 8047!> \param kbc ... 8048!> \param kad ... 8049!> \param kac ... 8050!> \param pbd ... 8051!> \param pbc ... 8052!> \param pad ... 8053!> \param pac ... 8054!> \param prim ... 8055!> \param scale ... 8056! ************************************************************************************************** 8057 SUBROUTINE block_1_3_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8058 REAL(KIND=dp) :: kbd(3*3), kbc(3*1), kad(1*3), kac(1*1), & 8059 pbd(3*3), pbc(3*1), pad(1*3), & 8060 pac(1*1), prim(1*3*1*3), scale 8061 8062 INTEGER :: ma, mb, mc, md, p_index 8063 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8064 8065 kbd(1:3*3) = 0.0_dp 8066 kbc(1:3*1) = 0.0_dp 8067 kad(1:1*3) = 0.0_dp 8068 kac(1:1*1) = 0.0_dp 8069 p_index = 0 8070 DO md = 1, 3 8071 DO mc = 1, 1 8072 DO mb = 1, 3 8073 ks_bd = 0.0_dp 8074 ks_bc = 0.0_dp 8075 p_bd = pbd((md - 1)*3 + mb) 8076 p_bc = pbc((mc - 1)*3 + mb) 8077 DO ma = 1, 1 8078 p_index = p_index + 1 8079 tmp = scale*prim(p_index) 8080 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8081 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8082 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8083 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8084 END DO 8085 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8086 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8087 END DO 8088 END DO 8089 END DO 8090 END SUBROUTINE block_1_3_1_3 8091! ************************************************************************************************** 8092!> \brief ... 8093!> \param kbd ... 8094!> \param kbc ... 8095!> \param kad ... 8096!> \param kac ... 8097!> \param pbd ... 8098!> \param pbc ... 8099!> \param pad ... 8100!> \param pac ... 8101!> \param prim ... 8102!> \param scale ... 8103! ************************************************************************************************** 8104 SUBROUTINE block_1_3_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8105 REAL(KIND=dp) :: kbd(3*4), kbc(3*1), kad(1*4), kac(1*1), & 8106 pbd(3*4), pbc(3*1), pad(1*4), & 8107 pac(1*1), prim(1*3*1*4), scale 8108 8109 INTEGER :: ma, mb, mc, md, p_index 8110 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8111 8112 kbd(1:3*4) = 0.0_dp 8113 kbc(1:3*1) = 0.0_dp 8114 kad(1:1*4) = 0.0_dp 8115 kac(1:1*1) = 0.0_dp 8116 p_index = 0 8117 DO md = 1, 4 8118 DO mc = 1, 1 8119 DO mb = 1, 3 8120 ks_bd = 0.0_dp 8121 ks_bc = 0.0_dp 8122 p_bd = pbd((md - 1)*3 + mb) 8123 p_bc = pbc((mc - 1)*3 + mb) 8124 DO ma = 1, 1 8125 p_index = p_index + 1 8126 tmp = scale*prim(p_index) 8127 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8128 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8129 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8130 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8131 END DO 8132 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8133 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8134 END DO 8135 END DO 8136 END DO 8137 END SUBROUTINE block_1_3_1_4 8138! ************************************************************************************************** 8139!> \brief ... 8140!> \param kbd ... 8141!> \param kbc ... 8142!> \param kad ... 8143!> \param kac ... 8144!> \param pbd ... 8145!> \param pbc ... 8146!> \param pad ... 8147!> \param pac ... 8148!> \param prim ... 8149!> \param scale ... 8150! ************************************************************************************************** 8151 SUBROUTINE block_1_3_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8152 REAL(KIND=dp) :: kbd(3*5), kbc(3*1), kad(1*5), kac(1*1), & 8153 pbd(3*5), pbc(3*1), pad(1*5), & 8154 pac(1*1), prim(1*3*1*5), scale 8155 8156 INTEGER :: ma, mb, mc, md, p_index 8157 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8158 8159 kbd(1:3*5) = 0.0_dp 8160 kbc(1:3*1) = 0.0_dp 8161 kad(1:1*5) = 0.0_dp 8162 kac(1:1*1) = 0.0_dp 8163 p_index = 0 8164 DO md = 1, 5 8165 DO mc = 1, 1 8166 DO mb = 1, 3 8167 ks_bd = 0.0_dp 8168 ks_bc = 0.0_dp 8169 p_bd = pbd((md - 1)*3 + mb) 8170 p_bc = pbc((mc - 1)*3 + mb) 8171 DO ma = 1, 1 8172 p_index = p_index + 1 8173 tmp = scale*prim(p_index) 8174 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8175 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8176 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8177 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8178 END DO 8179 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8180 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8181 END DO 8182 END DO 8183 END DO 8184 END SUBROUTINE block_1_3_1_5 8185! ************************************************************************************************** 8186!> \brief ... 8187!> \param kbd ... 8188!> \param kbc ... 8189!> \param kad ... 8190!> \param kac ... 8191!> \param pbd ... 8192!> \param pbc ... 8193!> \param pad ... 8194!> \param pac ... 8195!> \param prim ... 8196!> \param scale ... 8197! ************************************************************************************************** 8198 SUBROUTINE block_1_3_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8199 REAL(KIND=dp) :: kbd(3*6), kbc(3*1), kad(1*6), kac(1*1), & 8200 pbd(3*6), pbc(3*1), pad(1*6), & 8201 pac(1*1), prim(1*3*1*6), scale 8202 8203 INTEGER :: ma, mb, mc, md, p_index 8204 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8205 8206 kbd(1:3*6) = 0.0_dp 8207 kbc(1:3*1) = 0.0_dp 8208 kad(1:1*6) = 0.0_dp 8209 kac(1:1*1) = 0.0_dp 8210 p_index = 0 8211 DO md = 1, 6 8212 DO mc = 1, 1 8213 DO mb = 1, 3 8214 ks_bd = 0.0_dp 8215 ks_bc = 0.0_dp 8216 p_bd = pbd((md - 1)*3 + mb) 8217 p_bc = pbc((mc - 1)*3 + mb) 8218 DO ma = 1, 1 8219 p_index = p_index + 1 8220 tmp = scale*prim(p_index) 8221 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8222 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8223 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8224 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8225 END DO 8226 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8227 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8228 END DO 8229 END DO 8230 END DO 8231 END SUBROUTINE block_1_3_1_6 8232! ************************************************************************************************** 8233!> \brief ... 8234!> \param md_max ... 8235!> \param kbd ... 8236!> \param kbc ... 8237!> \param kad ... 8238!> \param kac ... 8239!> \param pbd ... 8240!> \param pbc ... 8241!> \param pad ... 8242!> \param pac ... 8243!> \param prim ... 8244!> \param scale ... 8245! ************************************************************************************************** 8246 SUBROUTINE block_1_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8247 INTEGER :: md_max 8248 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(1*md_max), kac(1*1), pbd(3*md_max), pbc(3*1), & 8249 pad(1*md_max), pac(1*1), prim(1*3*1*md_max), scale 8250 8251 INTEGER :: ma, mb, mc, md, p_index 8252 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8253 8254 kbd(1:3*md_max) = 0.0_dp 8255 kbc(1:3*1) = 0.0_dp 8256 kad(1:1*md_max) = 0.0_dp 8257 kac(1:1*1) = 0.0_dp 8258 p_index = 0 8259 DO md = 1, md_max 8260 DO mc = 1, 1 8261 DO mb = 1, 3 8262 ks_bd = 0.0_dp 8263 ks_bc = 0.0_dp 8264 p_bd = pbd((md - 1)*3 + mb) 8265 p_bc = pbc((mc - 1)*3 + mb) 8266 DO ma = 1, 1 8267 p_index = p_index + 1 8268 tmp = scale*prim(p_index) 8269 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8270 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8271 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8272 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8273 END DO 8274 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8275 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8276 END DO 8277 END DO 8278 END DO 8279 END SUBROUTINE block_1_3_1 8280! ************************************************************************************************** 8281!> \brief ... 8282!> \param kbd ... 8283!> \param kbc ... 8284!> \param kad ... 8285!> \param kac ... 8286!> \param pbd ... 8287!> \param pbc ... 8288!> \param pad ... 8289!> \param pac ... 8290!> \param prim ... 8291!> \param scale ... 8292! ************************************************************************************************** 8293 SUBROUTINE block_1_3_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8294 REAL(KIND=dp) :: kbd(3*1), kbc(3*2), kad(1*1), kac(1*2), & 8295 pbd(3*1), pbc(3*2), pad(1*1), & 8296 pac(1*2), prim(1*3*2*1), scale 8297 8298 INTEGER :: ma, mb, mc, md, p_index 8299 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8300 8301 kbd(1:3*1) = 0.0_dp 8302 kbc(1:3*2) = 0.0_dp 8303 kad(1:1*1) = 0.0_dp 8304 kac(1:1*2) = 0.0_dp 8305 p_index = 0 8306 DO md = 1, 1 8307 DO mc = 1, 2 8308 DO mb = 1, 3 8309 ks_bd = 0.0_dp 8310 ks_bc = 0.0_dp 8311 p_bd = pbd((md - 1)*3 + mb) 8312 p_bc = pbc((mc - 1)*3 + mb) 8313 DO ma = 1, 1 8314 p_index = p_index + 1 8315 tmp = scale*prim(p_index) 8316 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8317 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8318 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8319 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8320 END DO 8321 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8322 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8323 END DO 8324 END DO 8325 END DO 8326 END SUBROUTINE block_1_3_2_1 8327! ************************************************************************************************** 8328!> \brief ... 8329!> \param kbd ... 8330!> \param kbc ... 8331!> \param kad ... 8332!> \param kac ... 8333!> \param pbd ... 8334!> \param pbc ... 8335!> \param pad ... 8336!> \param pac ... 8337!> \param prim ... 8338!> \param scale ... 8339! ************************************************************************************************** 8340 SUBROUTINE block_1_3_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8341 REAL(KIND=dp) :: kbd(3*2), kbc(3*2), kad(1*2), kac(1*2), & 8342 pbd(3*2), pbc(3*2), pad(1*2), & 8343 pac(1*2), prim(1*3*2*2), scale 8344 8345 INTEGER :: ma, mb, mc, md, p_index 8346 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8347 8348 kbd(1:3*2) = 0.0_dp 8349 kbc(1:3*2) = 0.0_dp 8350 kad(1:1*2) = 0.0_dp 8351 kac(1:1*2) = 0.0_dp 8352 p_index = 0 8353 DO md = 1, 2 8354 DO mc = 1, 2 8355 DO mb = 1, 3 8356 ks_bd = 0.0_dp 8357 ks_bc = 0.0_dp 8358 p_bd = pbd((md - 1)*3 + mb) 8359 p_bc = pbc((mc - 1)*3 + mb) 8360 DO ma = 1, 1 8361 p_index = p_index + 1 8362 tmp = scale*prim(p_index) 8363 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8364 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8365 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8366 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8367 END DO 8368 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8369 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8370 END DO 8371 END DO 8372 END DO 8373 END SUBROUTINE block_1_3_2_2 8374! ************************************************************************************************** 8375!> \brief ... 8376!> \param kbd ... 8377!> \param kbc ... 8378!> \param kad ... 8379!> \param kac ... 8380!> \param pbd ... 8381!> \param pbc ... 8382!> \param pad ... 8383!> \param pac ... 8384!> \param prim ... 8385!> \param scale ... 8386! ************************************************************************************************** 8387 SUBROUTINE block_1_3_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8388 REAL(KIND=dp) :: kbd(3*3), kbc(3*2), kad(1*3), kac(1*2), & 8389 pbd(3*3), pbc(3*2), pad(1*3), & 8390 pac(1*2), prim(1*3*2*3), scale 8391 8392 INTEGER :: ma, mb, mc, md, p_index 8393 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8394 8395 kbd(1:3*3) = 0.0_dp 8396 kbc(1:3*2) = 0.0_dp 8397 kad(1:1*3) = 0.0_dp 8398 kac(1:1*2) = 0.0_dp 8399 p_index = 0 8400 DO md = 1, 3 8401 DO mc = 1, 2 8402 DO mb = 1, 3 8403 ks_bd = 0.0_dp 8404 ks_bc = 0.0_dp 8405 p_bd = pbd((md - 1)*3 + mb) 8406 p_bc = pbc((mc - 1)*3 + mb) 8407 DO ma = 1, 1 8408 p_index = p_index + 1 8409 tmp = scale*prim(p_index) 8410 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8411 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8412 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8413 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8414 END DO 8415 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8416 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8417 END DO 8418 END DO 8419 END DO 8420 END SUBROUTINE block_1_3_2_3 8421! ************************************************************************************************** 8422!> \brief ... 8423!> \param md_max ... 8424!> \param kbd ... 8425!> \param kbc ... 8426!> \param kad ... 8427!> \param kac ... 8428!> \param pbd ... 8429!> \param pbc ... 8430!> \param pad ... 8431!> \param pac ... 8432!> \param prim ... 8433!> \param scale ... 8434! ************************************************************************************************** 8435 SUBROUTINE block_1_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8436 INTEGER :: md_max 8437 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*2), kad(1*md_max), kac(1*2), pbd(3*md_max), pbc(3*2), & 8438 pad(1*md_max), pac(1*2), prim(1*3*2*md_max), scale 8439 8440 INTEGER :: ma, mb, mc, md, p_index 8441 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8442 8443 kbd(1:3*md_max) = 0.0_dp 8444 kbc(1:3*2) = 0.0_dp 8445 kad(1:1*md_max) = 0.0_dp 8446 kac(1:1*2) = 0.0_dp 8447 p_index = 0 8448 DO md = 1, md_max 8449 DO mc = 1, 2 8450 DO mb = 1, 3 8451 ks_bd = 0.0_dp 8452 ks_bc = 0.0_dp 8453 p_bd = pbd((md - 1)*3 + mb) 8454 p_bc = pbc((mc - 1)*3 + mb) 8455 DO ma = 1, 1 8456 p_index = p_index + 1 8457 tmp = scale*prim(p_index) 8458 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8459 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8460 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8461 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8462 END DO 8463 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8464 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8465 END DO 8466 END DO 8467 END DO 8468 END SUBROUTINE block_1_3_2 8469! ************************************************************************************************** 8470!> \brief ... 8471!> \param kbd ... 8472!> \param kbc ... 8473!> \param kad ... 8474!> \param kac ... 8475!> \param pbd ... 8476!> \param pbc ... 8477!> \param pad ... 8478!> \param pac ... 8479!> \param prim ... 8480!> \param scale ... 8481! ************************************************************************************************** 8482 SUBROUTINE block_1_3_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8483 REAL(KIND=dp) :: kbd(3*1), kbc(3*3), kad(1*1), kac(1*3), & 8484 pbd(3*1), pbc(3*3), pad(1*1), & 8485 pac(1*3), prim(1*3*3*1), scale 8486 8487 INTEGER :: ma, mb, mc, md, p_index 8488 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8489 8490 kbd(1:3*1) = 0.0_dp 8491 kbc(1:3*3) = 0.0_dp 8492 kad(1:1*1) = 0.0_dp 8493 kac(1:1*3) = 0.0_dp 8494 p_index = 0 8495 DO md = 1, 1 8496 DO mc = 1, 3 8497 DO mb = 1, 3 8498 ks_bd = 0.0_dp 8499 ks_bc = 0.0_dp 8500 p_bd = pbd((md - 1)*3 + mb) 8501 p_bc = pbc((mc - 1)*3 + mb) 8502 DO ma = 1, 1 8503 p_index = p_index + 1 8504 tmp = scale*prim(p_index) 8505 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8506 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8507 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8508 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8509 END DO 8510 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8511 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8512 END DO 8513 END DO 8514 END DO 8515 END SUBROUTINE block_1_3_3_1 8516! ************************************************************************************************** 8517!> \brief ... 8518!> \param kbd ... 8519!> \param kbc ... 8520!> \param kad ... 8521!> \param kac ... 8522!> \param pbd ... 8523!> \param pbc ... 8524!> \param pad ... 8525!> \param pac ... 8526!> \param prim ... 8527!> \param scale ... 8528! ************************************************************************************************** 8529 SUBROUTINE block_1_3_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8530 REAL(KIND=dp) :: kbd(3*2), kbc(3*3), kad(1*2), kac(1*3), & 8531 pbd(3*2), pbc(3*3), pad(1*2), & 8532 pac(1*3), prim(1*3*3*2), scale 8533 8534 INTEGER :: ma, mb, mc, md, p_index 8535 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8536 8537 kbd(1:3*2) = 0.0_dp 8538 kbc(1:3*3) = 0.0_dp 8539 kad(1:1*2) = 0.0_dp 8540 kac(1:1*3) = 0.0_dp 8541 p_index = 0 8542 DO md = 1, 2 8543 DO mc = 1, 3 8544 DO mb = 1, 3 8545 ks_bd = 0.0_dp 8546 ks_bc = 0.0_dp 8547 p_bd = pbd((md - 1)*3 + mb) 8548 p_bc = pbc((mc - 1)*3 + mb) 8549 DO ma = 1, 1 8550 p_index = p_index + 1 8551 tmp = scale*prim(p_index) 8552 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8553 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8554 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8555 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8556 END DO 8557 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8558 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8559 END DO 8560 END DO 8561 END DO 8562 END SUBROUTINE block_1_3_3_2 8563! ************************************************************************************************** 8564!> \brief ... 8565!> \param md_max ... 8566!> \param kbd ... 8567!> \param kbc ... 8568!> \param kad ... 8569!> \param kac ... 8570!> \param pbd ... 8571!> \param pbc ... 8572!> \param pad ... 8573!> \param pac ... 8574!> \param prim ... 8575!> \param scale ... 8576! ************************************************************************************************** 8577 SUBROUTINE block_1_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8578 INTEGER :: md_max 8579 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*3), kad(1*md_max), kac(1*3), pbd(3*md_max), pbc(3*3), & 8580 pad(1*md_max), pac(1*3), prim(1*3*3*md_max), scale 8581 8582 INTEGER :: ma, mb, mc, md, p_index 8583 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8584 8585 kbd(1:3*md_max) = 0.0_dp 8586 kbc(1:3*3) = 0.0_dp 8587 kad(1:1*md_max) = 0.0_dp 8588 kac(1:1*3) = 0.0_dp 8589 p_index = 0 8590 DO md = 1, md_max 8591 DO mc = 1, 3 8592 DO mb = 1, 3 8593 ks_bd = 0.0_dp 8594 ks_bc = 0.0_dp 8595 p_bd = pbd((md - 1)*3 + mb) 8596 p_bc = pbc((mc - 1)*3 + mb) 8597 DO ma = 1, 1 8598 p_index = p_index + 1 8599 tmp = scale*prim(p_index) 8600 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8601 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8602 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8603 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8604 END DO 8605 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8606 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8607 END DO 8608 END DO 8609 END DO 8610 END SUBROUTINE block_1_3_3 8611! ************************************************************************************************** 8612!> \brief ... 8613!> \param kbd ... 8614!> \param kbc ... 8615!> \param kad ... 8616!> \param kac ... 8617!> \param pbd ... 8618!> \param pbc ... 8619!> \param pad ... 8620!> \param pac ... 8621!> \param prim ... 8622!> \param scale ... 8623! ************************************************************************************************** 8624 SUBROUTINE block_1_3_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8625 REAL(KIND=dp) :: kbd(3*1), kbc(3*4), kad(1*1), kac(1*4), & 8626 pbd(3*1), pbc(3*4), pad(1*1), & 8627 pac(1*4), prim(1*3*4*1), scale 8628 8629 INTEGER :: ma, mb, mc, md, p_index 8630 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8631 8632 kbd(1:3*1) = 0.0_dp 8633 kbc(1:3*4) = 0.0_dp 8634 kad(1:1*1) = 0.0_dp 8635 kac(1:1*4) = 0.0_dp 8636 p_index = 0 8637 DO md = 1, 1 8638 DO mc = 1, 4 8639 DO mb = 1, 3 8640 ks_bd = 0.0_dp 8641 ks_bc = 0.0_dp 8642 p_bd = pbd((md - 1)*3 + mb) 8643 p_bc = pbc((mc - 1)*3 + mb) 8644 DO ma = 1, 1 8645 p_index = p_index + 1 8646 tmp = scale*prim(p_index) 8647 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8648 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8649 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8650 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8651 END DO 8652 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8653 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8654 END DO 8655 END DO 8656 END DO 8657 END SUBROUTINE block_1_3_4_1 8658! ************************************************************************************************** 8659!> \brief ... 8660!> \param md_max ... 8661!> \param kbd ... 8662!> \param kbc ... 8663!> \param kad ... 8664!> \param kac ... 8665!> \param pbd ... 8666!> \param pbc ... 8667!> \param pad ... 8668!> \param pac ... 8669!> \param prim ... 8670!> \param scale ... 8671! ************************************************************************************************** 8672 SUBROUTINE block_1_3_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8673 INTEGER :: md_max 8674 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*4), kad(1*md_max), kac(1*4), pbd(3*md_max), pbc(3*4), & 8675 pad(1*md_max), pac(1*4), prim(1*3*4*md_max), scale 8676 8677 INTEGER :: ma, mb, mc, md, p_index 8678 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8679 8680 kbd(1:3*md_max) = 0.0_dp 8681 kbc(1:3*4) = 0.0_dp 8682 kad(1:1*md_max) = 0.0_dp 8683 kac(1:1*4) = 0.0_dp 8684 p_index = 0 8685 DO md = 1, md_max 8686 DO mc = 1, 4 8687 DO mb = 1, 3 8688 ks_bd = 0.0_dp 8689 ks_bc = 0.0_dp 8690 p_bd = pbd((md - 1)*3 + mb) 8691 p_bc = pbc((mc - 1)*3 + mb) 8692 DO ma = 1, 1 8693 p_index = p_index + 1 8694 tmp = scale*prim(p_index) 8695 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8696 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8697 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8698 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8699 END DO 8700 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8701 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8702 END DO 8703 END DO 8704 END DO 8705 END SUBROUTINE block_1_3_4 8706! ************************************************************************************************** 8707!> \brief ... 8708!> \param kbd ... 8709!> \param kbc ... 8710!> \param kad ... 8711!> \param kac ... 8712!> \param pbd ... 8713!> \param pbc ... 8714!> \param pad ... 8715!> \param pac ... 8716!> \param prim ... 8717!> \param scale ... 8718! ************************************************************************************************** 8719 SUBROUTINE block_1_3_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8720 REAL(KIND=dp) :: kbd(3*1), kbc(3*5), kad(1*1), kac(1*5), & 8721 pbd(3*1), pbc(3*5), pad(1*1), & 8722 pac(1*5), prim(1*3*5*1), scale 8723 8724 INTEGER :: ma, mb, mc, md, p_index 8725 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8726 8727 kbd(1:3*1) = 0.0_dp 8728 kbc(1:3*5) = 0.0_dp 8729 kad(1:1*1) = 0.0_dp 8730 kac(1:1*5) = 0.0_dp 8731 p_index = 0 8732 DO md = 1, 1 8733 DO mc = 1, 5 8734 DO mb = 1, 3 8735 ks_bd = 0.0_dp 8736 ks_bc = 0.0_dp 8737 p_bd = pbd((md - 1)*3 + mb) 8738 p_bc = pbc((mc - 1)*3 + mb) 8739 DO ma = 1, 1 8740 p_index = p_index + 1 8741 tmp = scale*prim(p_index) 8742 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8743 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8744 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8745 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8746 END DO 8747 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8748 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8749 END DO 8750 END DO 8751 END DO 8752 END SUBROUTINE block_1_3_5_1 8753! ************************************************************************************************** 8754!> \brief ... 8755!> \param md_max ... 8756!> \param kbd ... 8757!> \param kbc ... 8758!> \param kad ... 8759!> \param kac ... 8760!> \param pbd ... 8761!> \param pbc ... 8762!> \param pad ... 8763!> \param pac ... 8764!> \param prim ... 8765!> \param scale ... 8766! ************************************************************************************************** 8767 SUBROUTINE block_1_3_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8768 INTEGER :: md_max 8769 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*5), kad(1*md_max), kac(1*5), pbd(3*md_max), pbc(3*5), & 8770 pad(1*md_max), pac(1*5), prim(1*3*5*md_max), scale 8771 8772 INTEGER :: ma, mb, mc, md, p_index 8773 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8774 8775 kbd(1:3*md_max) = 0.0_dp 8776 kbc(1:3*5) = 0.0_dp 8777 kad(1:1*md_max) = 0.0_dp 8778 kac(1:1*5) = 0.0_dp 8779 p_index = 0 8780 DO md = 1, md_max 8781 DO mc = 1, 5 8782 DO mb = 1, 3 8783 ks_bd = 0.0_dp 8784 ks_bc = 0.0_dp 8785 p_bd = pbd((md - 1)*3 + mb) 8786 p_bc = pbc((mc - 1)*3 + mb) 8787 DO ma = 1, 1 8788 p_index = p_index + 1 8789 tmp = scale*prim(p_index) 8790 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8791 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8792 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8793 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8794 END DO 8795 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8796 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8797 END DO 8798 END DO 8799 END DO 8800 END SUBROUTINE block_1_3_5 8801! ************************************************************************************************** 8802!> \brief ... 8803!> \param kbd ... 8804!> \param kbc ... 8805!> \param kad ... 8806!> \param kac ... 8807!> \param pbd ... 8808!> \param pbc ... 8809!> \param pad ... 8810!> \param pac ... 8811!> \param prim ... 8812!> \param scale ... 8813! ************************************************************************************************** 8814 SUBROUTINE block_1_3_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8815 REAL(KIND=dp) :: kbd(3*1), kbc(3*6), kad(1*1), kac(1*6), & 8816 pbd(3*1), pbc(3*6), pad(1*1), & 8817 pac(1*6), prim(1*3*6*1), scale 8818 8819 INTEGER :: ma, mb, mc, md, p_index 8820 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8821 8822 kbd(1:3*1) = 0.0_dp 8823 kbc(1:3*6) = 0.0_dp 8824 kad(1:1*1) = 0.0_dp 8825 kac(1:1*6) = 0.0_dp 8826 p_index = 0 8827 DO md = 1, 1 8828 DO mc = 1, 6 8829 DO mb = 1, 3 8830 ks_bd = 0.0_dp 8831 ks_bc = 0.0_dp 8832 p_bd = pbd((md - 1)*3 + mb) 8833 p_bc = pbc((mc - 1)*3 + mb) 8834 DO ma = 1, 1 8835 p_index = p_index + 1 8836 tmp = scale*prim(p_index) 8837 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8838 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8839 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8840 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8841 END DO 8842 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8843 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8844 END DO 8845 END DO 8846 END DO 8847 END SUBROUTINE block_1_3_6_1 8848! ************************************************************************************************** 8849!> \brief ... 8850!> \param md_max ... 8851!> \param kbd ... 8852!> \param kbc ... 8853!> \param kad ... 8854!> \param kac ... 8855!> \param pbd ... 8856!> \param pbc ... 8857!> \param pad ... 8858!> \param pac ... 8859!> \param prim ... 8860!> \param scale ... 8861! ************************************************************************************************** 8862 SUBROUTINE block_1_3_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8863 INTEGER :: md_max 8864 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*6), kad(1*md_max), kac(1*6), pbd(3*md_max), pbc(3*6), & 8865 pad(1*md_max), pac(1*6), prim(1*3*6*md_max), scale 8866 8867 INTEGER :: ma, mb, mc, md, p_index 8868 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8869 8870 kbd(1:3*md_max) = 0.0_dp 8871 kbc(1:3*6) = 0.0_dp 8872 kad(1:1*md_max) = 0.0_dp 8873 kac(1:1*6) = 0.0_dp 8874 p_index = 0 8875 DO md = 1, md_max 8876 DO mc = 1, 6 8877 DO mb = 1, 3 8878 ks_bd = 0.0_dp 8879 ks_bc = 0.0_dp 8880 p_bd = pbd((md - 1)*3 + mb) 8881 p_bc = pbc((mc - 1)*3 + mb) 8882 DO ma = 1, 1 8883 p_index = p_index + 1 8884 tmp = scale*prim(p_index) 8885 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8886 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8887 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8888 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8889 END DO 8890 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8891 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8892 END DO 8893 END DO 8894 END DO 8895 END SUBROUTINE block_1_3_6 8896! ************************************************************************************************** 8897!> \brief ... 8898!> \param mc_max ... 8899!> \param md_max ... 8900!> \param kbd ... 8901!> \param kbc ... 8902!> \param kad ... 8903!> \param kac ... 8904!> \param pbd ... 8905!> \param pbc ... 8906!> \param pad ... 8907!> \param pac ... 8908!> \param prim ... 8909!> \param scale ... 8910! ************************************************************************************************** 8911 SUBROUTINE block_1_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8912 INTEGER :: mc_max, md_max 8913 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(1*md_max), kac(1*mc_max), pbd(3*md_max), & 8914 pbc(3*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*3*mc_max*md_max), scale 8915 8916 INTEGER :: ma, mb, mc, md, p_index 8917 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8918 8919 kbd(1:3*md_max) = 0.0_dp 8920 kbc(1:3*mc_max) = 0.0_dp 8921 kad(1:1*md_max) = 0.0_dp 8922 kac(1:1*mc_max) = 0.0_dp 8923 p_index = 0 8924 DO md = 1, md_max 8925 DO mc = 1, mc_max 8926 DO mb = 1, 3 8927 ks_bd = 0.0_dp 8928 ks_bc = 0.0_dp 8929 p_bd = pbd((md - 1)*3 + mb) 8930 p_bc = pbc((mc - 1)*3 + mb) 8931 DO ma = 1, 1 8932 p_index = p_index + 1 8933 tmp = scale*prim(p_index) 8934 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8935 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8936 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8937 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8938 END DO 8939 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 8940 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 8941 END DO 8942 END DO 8943 END DO 8944 END SUBROUTINE block_1_3 8945! ************************************************************************************************** 8946!> \brief ... 8947!> \param kbd ... 8948!> \param kbc ... 8949!> \param kad ... 8950!> \param kac ... 8951!> \param pbd ... 8952!> \param pbc ... 8953!> \param pad ... 8954!> \param pac ... 8955!> \param prim ... 8956!> \param scale ... 8957! ************************************************************************************************** 8958 SUBROUTINE block_1_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 8959 REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(1*1), kac(1*1), & 8960 pbd(4*1), pbc(4*1), pad(1*1), & 8961 pac(1*1), prim(1*4*1*1), scale 8962 8963 INTEGER :: ma, mb, mc, md, p_index 8964 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 8965 8966 kbd(1:4*1) = 0.0_dp 8967 kbc(1:4*1) = 0.0_dp 8968 kad(1:1*1) = 0.0_dp 8969 kac(1:1*1) = 0.0_dp 8970 p_index = 0 8971 DO md = 1, 1 8972 DO mc = 1, 1 8973 DO mb = 1, 4 8974 ks_bd = 0.0_dp 8975 ks_bc = 0.0_dp 8976 p_bd = pbd((md - 1)*4 + mb) 8977 p_bc = pbc((mc - 1)*4 + mb) 8978 DO ma = 1, 1 8979 p_index = p_index + 1 8980 tmp = scale*prim(p_index) 8981 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 8982 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 8983 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 8984 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 8985 END DO 8986 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 8987 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 8988 END DO 8989 END DO 8990 END DO 8991 END SUBROUTINE block_1_4_1_1 8992! ************************************************************************************************** 8993!> \brief ... 8994!> \param kbd ... 8995!> \param kbc ... 8996!> \param kad ... 8997!> \param kac ... 8998!> \param pbd ... 8999!> \param pbc ... 9000!> \param pad ... 9001!> \param pac ... 9002!> \param prim ... 9003!> \param scale ... 9004! ************************************************************************************************** 9005 SUBROUTINE block_1_4_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9006 REAL(KIND=dp) :: kbd(4*2), kbc(4*1), kad(1*2), kac(1*1), & 9007 pbd(4*2), pbc(4*1), pad(1*2), & 9008 pac(1*1), prim(1*4*1*2), scale 9009 9010 INTEGER :: ma, mb, mc, md, p_index 9011 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9012 9013 kbd(1:4*2) = 0.0_dp 9014 kbc(1:4*1) = 0.0_dp 9015 kad(1:1*2) = 0.0_dp 9016 kac(1:1*1) = 0.0_dp 9017 p_index = 0 9018 DO md = 1, 2 9019 DO mc = 1, 1 9020 DO mb = 1, 4 9021 ks_bd = 0.0_dp 9022 ks_bc = 0.0_dp 9023 p_bd = pbd((md - 1)*4 + mb) 9024 p_bc = pbc((mc - 1)*4 + mb) 9025 DO ma = 1, 1 9026 p_index = p_index + 1 9027 tmp = scale*prim(p_index) 9028 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9029 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9030 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9031 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9032 END DO 9033 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9034 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9035 END DO 9036 END DO 9037 END DO 9038 END SUBROUTINE block_1_4_1_2 9039! ************************************************************************************************** 9040!> \brief ... 9041!> \param kbd ... 9042!> \param kbc ... 9043!> \param kad ... 9044!> \param kac ... 9045!> \param pbd ... 9046!> \param pbc ... 9047!> \param pad ... 9048!> \param pac ... 9049!> \param prim ... 9050!> \param scale ... 9051! ************************************************************************************************** 9052 SUBROUTINE block_1_4_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9053 REAL(KIND=dp) :: kbd(4*3), kbc(4*1), kad(1*3), kac(1*1), & 9054 pbd(4*3), pbc(4*1), pad(1*3), & 9055 pac(1*1), prim(1*4*1*3), scale 9056 9057 INTEGER :: ma, mb, mc, md, p_index 9058 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9059 9060 kbd(1:4*3) = 0.0_dp 9061 kbc(1:4*1) = 0.0_dp 9062 kad(1:1*3) = 0.0_dp 9063 kac(1:1*1) = 0.0_dp 9064 p_index = 0 9065 DO md = 1, 3 9066 DO mc = 1, 1 9067 DO mb = 1, 4 9068 ks_bd = 0.0_dp 9069 ks_bc = 0.0_dp 9070 p_bd = pbd((md - 1)*4 + mb) 9071 p_bc = pbc((mc - 1)*4 + mb) 9072 DO ma = 1, 1 9073 p_index = p_index + 1 9074 tmp = scale*prim(p_index) 9075 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9076 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9077 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9078 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9079 END DO 9080 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9081 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9082 END DO 9083 END DO 9084 END DO 9085 END SUBROUTINE block_1_4_1_3 9086! ************************************************************************************************** 9087!> \brief ... 9088!> \param kbd ... 9089!> \param kbc ... 9090!> \param kad ... 9091!> \param kac ... 9092!> \param pbd ... 9093!> \param pbc ... 9094!> \param pad ... 9095!> \param pac ... 9096!> \param prim ... 9097!> \param scale ... 9098! ************************************************************************************************** 9099 SUBROUTINE block_1_4_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9100 REAL(KIND=dp) :: kbd(4*4), kbc(4*1), kad(1*4), kac(1*1), & 9101 pbd(4*4), pbc(4*1), pad(1*4), & 9102 pac(1*1), prim(1*4*1*4), scale 9103 9104 INTEGER :: ma, mb, mc, md, p_index 9105 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9106 9107 kbd(1:4*4) = 0.0_dp 9108 kbc(1:4*1) = 0.0_dp 9109 kad(1:1*4) = 0.0_dp 9110 kac(1:1*1) = 0.0_dp 9111 p_index = 0 9112 DO md = 1, 4 9113 DO mc = 1, 1 9114 DO mb = 1, 4 9115 ks_bd = 0.0_dp 9116 ks_bc = 0.0_dp 9117 p_bd = pbd((md - 1)*4 + mb) 9118 p_bc = pbc((mc - 1)*4 + mb) 9119 DO ma = 1, 1 9120 p_index = p_index + 1 9121 tmp = scale*prim(p_index) 9122 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9123 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9124 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9125 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9126 END DO 9127 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9128 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9129 END DO 9130 END DO 9131 END DO 9132 END SUBROUTINE block_1_4_1_4 9133! ************************************************************************************************** 9134!> \brief ... 9135!> \param md_max ... 9136!> \param kbd ... 9137!> \param kbc ... 9138!> \param kad ... 9139!> \param kac ... 9140!> \param pbd ... 9141!> \param pbc ... 9142!> \param pad ... 9143!> \param pac ... 9144!> \param prim ... 9145!> \param scale ... 9146! ************************************************************************************************** 9147 SUBROUTINE block_1_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9148 INTEGER :: md_max 9149 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*1), kad(1*md_max), kac(1*1), pbd(4*md_max), pbc(4*1), & 9150 pad(1*md_max), pac(1*1), prim(1*4*1*md_max), scale 9151 9152 INTEGER :: ma, mb, mc, md, p_index 9153 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9154 9155 kbd(1:4*md_max) = 0.0_dp 9156 kbc(1:4*1) = 0.0_dp 9157 kad(1:1*md_max) = 0.0_dp 9158 kac(1:1*1) = 0.0_dp 9159 p_index = 0 9160 DO md = 1, md_max 9161 DO mc = 1, 1 9162 DO mb = 1, 4 9163 ks_bd = 0.0_dp 9164 ks_bc = 0.0_dp 9165 p_bd = pbd((md - 1)*4 + mb) 9166 p_bc = pbc((mc - 1)*4 + mb) 9167 DO ma = 1, 1 9168 p_index = p_index + 1 9169 tmp = scale*prim(p_index) 9170 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9171 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9172 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9173 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9174 END DO 9175 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9176 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9177 END DO 9178 END DO 9179 END DO 9180 END SUBROUTINE block_1_4_1 9181! ************************************************************************************************** 9182!> \brief ... 9183!> \param kbd ... 9184!> \param kbc ... 9185!> \param kad ... 9186!> \param kac ... 9187!> \param pbd ... 9188!> \param pbc ... 9189!> \param pad ... 9190!> \param pac ... 9191!> \param prim ... 9192!> \param scale ... 9193! ************************************************************************************************** 9194 SUBROUTINE block_1_4_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9195 REAL(KIND=dp) :: kbd(4*1), kbc(4*2), kad(1*1), kac(1*2), & 9196 pbd(4*1), pbc(4*2), pad(1*1), & 9197 pac(1*2), prim(1*4*2*1), scale 9198 9199 INTEGER :: ma, mb, mc, md, p_index 9200 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9201 9202 kbd(1:4*1) = 0.0_dp 9203 kbc(1:4*2) = 0.0_dp 9204 kad(1:1*1) = 0.0_dp 9205 kac(1:1*2) = 0.0_dp 9206 p_index = 0 9207 DO md = 1, 1 9208 DO mc = 1, 2 9209 DO mb = 1, 4 9210 ks_bd = 0.0_dp 9211 ks_bc = 0.0_dp 9212 p_bd = pbd((md - 1)*4 + mb) 9213 p_bc = pbc((mc - 1)*4 + mb) 9214 DO ma = 1, 1 9215 p_index = p_index + 1 9216 tmp = scale*prim(p_index) 9217 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9218 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9219 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9220 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9221 END DO 9222 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9223 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9224 END DO 9225 END DO 9226 END DO 9227 END SUBROUTINE block_1_4_2_1 9228! ************************************************************************************************** 9229!> \brief ... 9230!> \param kbd ... 9231!> \param kbc ... 9232!> \param kad ... 9233!> \param kac ... 9234!> \param pbd ... 9235!> \param pbc ... 9236!> \param pad ... 9237!> \param pac ... 9238!> \param prim ... 9239!> \param scale ... 9240! ************************************************************************************************** 9241 SUBROUTINE block_1_4_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9242 REAL(KIND=dp) :: kbd(4*2), kbc(4*2), kad(1*2), kac(1*2), & 9243 pbd(4*2), pbc(4*2), pad(1*2), & 9244 pac(1*2), prim(1*4*2*2), scale 9245 9246 INTEGER :: ma, mb, mc, md, p_index 9247 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9248 9249 kbd(1:4*2) = 0.0_dp 9250 kbc(1:4*2) = 0.0_dp 9251 kad(1:1*2) = 0.0_dp 9252 kac(1:1*2) = 0.0_dp 9253 p_index = 0 9254 DO md = 1, 2 9255 DO mc = 1, 2 9256 DO mb = 1, 4 9257 ks_bd = 0.0_dp 9258 ks_bc = 0.0_dp 9259 p_bd = pbd((md - 1)*4 + mb) 9260 p_bc = pbc((mc - 1)*4 + mb) 9261 DO ma = 1, 1 9262 p_index = p_index + 1 9263 tmp = scale*prim(p_index) 9264 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9265 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9266 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9267 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9268 END DO 9269 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9270 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9271 END DO 9272 END DO 9273 END DO 9274 END SUBROUTINE block_1_4_2_2 9275! ************************************************************************************************** 9276!> \brief ... 9277!> \param md_max ... 9278!> \param kbd ... 9279!> \param kbc ... 9280!> \param kad ... 9281!> \param kac ... 9282!> \param pbd ... 9283!> \param pbc ... 9284!> \param pad ... 9285!> \param pac ... 9286!> \param prim ... 9287!> \param scale ... 9288! ************************************************************************************************** 9289 SUBROUTINE block_1_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9290 INTEGER :: md_max 9291 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*2), kad(1*md_max), kac(1*2), pbd(4*md_max), pbc(4*2), & 9292 pad(1*md_max), pac(1*2), prim(1*4*2*md_max), scale 9293 9294 INTEGER :: ma, mb, mc, md, p_index 9295 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9296 9297 kbd(1:4*md_max) = 0.0_dp 9298 kbc(1:4*2) = 0.0_dp 9299 kad(1:1*md_max) = 0.0_dp 9300 kac(1:1*2) = 0.0_dp 9301 p_index = 0 9302 DO md = 1, md_max 9303 DO mc = 1, 2 9304 DO mb = 1, 4 9305 ks_bd = 0.0_dp 9306 ks_bc = 0.0_dp 9307 p_bd = pbd((md - 1)*4 + mb) 9308 p_bc = pbc((mc - 1)*4 + mb) 9309 DO ma = 1, 1 9310 p_index = p_index + 1 9311 tmp = scale*prim(p_index) 9312 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9313 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9314 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9315 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9316 END DO 9317 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9318 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9319 END DO 9320 END DO 9321 END DO 9322 END SUBROUTINE block_1_4_2 9323! ************************************************************************************************** 9324!> \brief ... 9325!> \param kbd ... 9326!> \param kbc ... 9327!> \param kad ... 9328!> \param kac ... 9329!> \param pbd ... 9330!> \param pbc ... 9331!> \param pad ... 9332!> \param pac ... 9333!> \param prim ... 9334!> \param scale ... 9335! ************************************************************************************************** 9336 SUBROUTINE block_1_4_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9337 REAL(KIND=dp) :: kbd(4*1), kbc(4*3), kad(1*1), kac(1*3), & 9338 pbd(4*1), pbc(4*3), pad(1*1), & 9339 pac(1*3), prim(1*4*3*1), scale 9340 9341 INTEGER :: ma, mb, mc, md, p_index 9342 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9343 9344 kbd(1:4*1) = 0.0_dp 9345 kbc(1:4*3) = 0.0_dp 9346 kad(1:1*1) = 0.0_dp 9347 kac(1:1*3) = 0.0_dp 9348 p_index = 0 9349 DO md = 1, 1 9350 DO mc = 1, 3 9351 DO mb = 1, 4 9352 ks_bd = 0.0_dp 9353 ks_bc = 0.0_dp 9354 p_bd = pbd((md - 1)*4 + mb) 9355 p_bc = pbc((mc - 1)*4 + mb) 9356 DO ma = 1, 1 9357 p_index = p_index + 1 9358 tmp = scale*prim(p_index) 9359 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9360 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9361 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9362 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9363 END DO 9364 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9365 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9366 END DO 9367 END DO 9368 END DO 9369 END SUBROUTINE block_1_4_3_1 9370! ************************************************************************************************** 9371!> \brief ... 9372!> \param md_max ... 9373!> \param kbd ... 9374!> \param kbc ... 9375!> \param kad ... 9376!> \param kac ... 9377!> \param pbd ... 9378!> \param pbc ... 9379!> \param pad ... 9380!> \param pac ... 9381!> \param prim ... 9382!> \param scale ... 9383! ************************************************************************************************** 9384 SUBROUTINE block_1_4_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9385 INTEGER :: md_max 9386 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*3), kad(1*md_max), kac(1*3), pbd(4*md_max), pbc(4*3), & 9387 pad(1*md_max), pac(1*3), prim(1*4*3*md_max), scale 9388 9389 INTEGER :: ma, mb, mc, md, p_index 9390 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9391 9392 kbd(1:4*md_max) = 0.0_dp 9393 kbc(1:4*3) = 0.0_dp 9394 kad(1:1*md_max) = 0.0_dp 9395 kac(1:1*3) = 0.0_dp 9396 p_index = 0 9397 DO md = 1, md_max 9398 DO mc = 1, 3 9399 DO mb = 1, 4 9400 ks_bd = 0.0_dp 9401 ks_bc = 0.0_dp 9402 p_bd = pbd((md - 1)*4 + mb) 9403 p_bc = pbc((mc - 1)*4 + mb) 9404 DO ma = 1, 1 9405 p_index = p_index + 1 9406 tmp = scale*prim(p_index) 9407 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9408 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9409 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9410 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9411 END DO 9412 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9413 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9414 END DO 9415 END DO 9416 END DO 9417 END SUBROUTINE block_1_4_3 9418! ************************************************************************************************** 9419!> \brief ... 9420!> \param kbd ... 9421!> \param kbc ... 9422!> \param kad ... 9423!> \param kac ... 9424!> \param pbd ... 9425!> \param pbc ... 9426!> \param pad ... 9427!> \param pac ... 9428!> \param prim ... 9429!> \param scale ... 9430! ************************************************************************************************** 9431 SUBROUTINE block_1_4_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9432 REAL(KIND=dp) :: kbd(4*1), kbc(4*4), kad(1*1), kac(1*4), & 9433 pbd(4*1), pbc(4*4), pad(1*1), & 9434 pac(1*4), prim(1*4*4*1), scale 9435 9436 INTEGER :: ma, mb, mc, md, p_index 9437 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9438 9439 kbd(1:4*1) = 0.0_dp 9440 kbc(1:4*4) = 0.0_dp 9441 kad(1:1*1) = 0.0_dp 9442 kac(1:1*4) = 0.0_dp 9443 p_index = 0 9444 DO md = 1, 1 9445 DO mc = 1, 4 9446 DO mb = 1, 4 9447 ks_bd = 0.0_dp 9448 ks_bc = 0.0_dp 9449 p_bd = pbd((md - 1)*4 + mb) 9450 p_bc = pbc((mc - 1)*4 + mb) 9451 DO ma = 1, 1 9452 p_index = p_index + 1 9453 tmp = scale*prim(p_index) 9454 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9455 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9456 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9457 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9458 END DO 9459 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9460 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9461 END DO 9462 END DO 9463 END DO 9464 END SUBROUTINE block_1_4_4_1 9465! ************************************************************************************************** 9466!> \brief ... 9467!> \param md_max ... 9468!> \param kbd ... 9469!> \param kbc ... 9470!> \param kad ... 9471!> \param kac ... 9472!> \param pbd ... 9473!> \param pbc ... 9474!> \param pad ... 9475!> \param pac ... 9476!> \param prim ... 9477!> \param scale ... 9478! ************************************************************************************************** 9479 SUBROUTINE block_1_4_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9480 INTEGER :: md_max 9481 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*4), kad(1*md_max), kac(1*4), pbd(4*md_max), pbc(4*4), & 9482 pad(1*md_max), pac(1*4), prim(1*4*4*md_max), scale 9483 9484 INTEGER :: ma, mb, mc, md, p_index 9485 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9486 9487 kbd(1:4*md_max) = 0.0_dp 9488 kbc(1:4*4) = 0.0_dp 9489 kad(1:1*md_max) = 0.0_dp 9490 kac(1:1*4) = 0.0_dp 9491 p_index = 0 9492 DO md = 1, md_max 9493 DO mc = 1, 4 9494 DO mb = 1, 4 9495 ks_bd = 0.0_dp 9496 ks_bc = 0.0_dp 9497 p_bd = pbd((md - 1)*4 + mb) 9498 p_bc = pbc((mc - 1)*4 + mb) 9499 DO ma = 1, 1 9500 p_index = p_index + 1 9501 tmp = scale*prim(p_index) 9502 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9503 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9504 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9505 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9506 END DO 9507 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9508 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9509 END DO 9510 END DO 9511 END DO 9512 END SUBROUTINE block_1_4_4 9513! ************************************************************************************************** 9514!> \brief ... 9515!> \param mc_max ... 9516!> \param md_max ... 9517!> \param kbd ... 9518!> \param kbc ... 9519!> \param kad ... 9520!> \param kac ... 9521!> \param pbd ... 9522!> \param pbc ... 9523!> \param pad ... 9524!> \param pac ... 9525!> \param prim ... 9526!> \param scale ... 9527! ************************************************************************************************** 9528 SUBROUTINE block_1_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9529 INTEGER :: mc_max, md_max 9530 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(1*md_max), kac(1*mc_max), pbd(4*md_max), & 9531 pbc(4*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*4*mc_max*md_max), scale 9532 9533 INTEGER :: ma, mb, mc, md, p_index 9534 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9535 9536 kbd(1:4*md_max) = 0.0_dp 9537 kbc(1:4*mc_max) = 0.0_dp 9538 kad(1:1*md_max) = 0.0_dp 9539 kac(1:1*mc_max) = 0.0_dp 9540 p_index = 0 9541 DO md = 1, md_max 9542 DO mc = 1, mc_max 9543 DO mb = 1, 4 9544 ks_bd = 0.0_dp 9545 ks_bc = 0.0_dp 9546 p_bd = pbd((md - 1)*4 + mb) 9547 p_bc = pbc((mc - 1)*4 + mb) 9548 DO ma = 1, 1 9549 p_index = p_index + 1 9550 tmp = scale*prim(p_index) 9551 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9552 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9553 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9554 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9555 END DO 9556 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 9557 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 9558 END DO 9559 END DO 9560 END DO 9561 END SUBROUTINE block_1_4 9562! ************************************************************************************************** 9563!> \brief ... 9564!> \param kbd ... 9565!> \param kbc ... 9566!> \param kad ... 9567!> \param kac ... 9568!> \param pbd ... 9569!> \param pbc ... 9570!> \param pad ... 9571!> \param pac ... 9572!> \param prim ... 9573!> \param scale ... 9574! ************************************************************************************************** 9575 SUBROUTINE block_1_5_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9576 REAL(KIND=dp) :: kbd(5*1), kbc(5*1), kad(1*1), kac(1*1), & 9577 pbd(5*1), pbc(5*1), pad(1*1), & 9578 pac(1*1), prim(1*5*1*1), scale 9579 9580 INTEGER :: ma, mb, mc, md, p_index 9581 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9582 9583 kbd(1:5*1) = 0.0_dp 9584 kbc(1:5*1) = 0.0_dp 9585 kad(1:1*1) = 0.0_dp 9586 kac(1:1*1) = 0.0_dp 9587 p_index = 0 9588 DO md = 1, 1 9589 DO mc = 1, 1 9590 DO mb = 1, 5 9591 ks_bd = 0.0_dp 9592 ks_bc = 0.0_dp 9593 p_bd = pbd((md - 1)*5 + mb) 9594 p_bc = pbc((mc - 1)*5 + mb) 9595 DO ma = 1, 1 9596 p_index = p_index + 1 9597 tmp = scale*prim(p_index) 9598 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9599 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9600 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9601 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9602 END DO 9603 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9604 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9605 END DO 9606 END DO 9607 END DO 9608 END SUBROUTINE block_1_5_1_1 9609! ************************************************************************************************** 9610!> \brief ... 9611!> \param kbd ... 9612!> \param kbc ... 9613!> \param kad ... 9614!> \param kac ... 9615!> \param pbd ... 9616!> \param pbc ... 9617!> \param pad ... 9618!> \param pac ... 9619!> \param prim ... 9620!> \param scale ... 9621! ************************************************************************************************** 9622 SUBROUTINE block_1_5_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9623 REAL(KIND=dp) :: kbd(5*2), kbc(5*1), kad(1*2), kac(1*1), & 9624 pbd(5*2), pbc(5*1), pad(1*2), & 9625 pac(1*1), prim(1*5*1*2), scale 9626 9627 INTEGER :: ma, mb, mc, md, p_index 9628 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9629 9630 kbd(1:5*2) = 0.0_dp 9631 kbc(1:5*1) = 0.0_dp 9632 kad(1:1*2) = 0.0_dp 9633 kac(1:1*1) = 0.0_dp 9634 p_index = 0 9635 DO md = 1, 2 9636 DO mc = 1, 1 9637 DO mb = 1, 5 9638 ks_bd = 0.0_dp 9639 ks_bc = 0.0_dp 9640 p_bd = pbd((md - 1)*5 + mb) 9641 p_bc = pbc((mc - 1)*5 + mb) 9642 DO ma = 1, 1 9643 p_index = p_index + 1 9644 tmp = scale*prim(p_index) 9645 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9646 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9647 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9648 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9649 END DO 9650 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9651 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9652 END DO 9653 END DO 9654 END DO 9655 END SUBROUTINE block_1_5_1_2 9656! ************************************************************************************************** 9657!> \brief ... 9658!> \param kbd ... 9659!> \param kbc ... 9660!> \param kad ... 9661!> \param kac ... 9662!> \param pbd ... 9663!> \param pbc ... 9664!> \param pad ... 9665!> \param pac ... 9666!> \param prim ... 9667!> \param scale ... 9668! ************************************************************************************************** 9669 SUBROUTINE block_1_5_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9670 REAL(KIND=dp) :: kbd(5*3), kbc(5*1), kad(1*3), kac(1*1), & 9671 pbd(5*3), pbc(5*1), pad(1*3), & 9672 pac(1*1), prim(1*5*1*3), scale 9673 9674 INTEGER :: ma, mb, mc, md, p_index 9675 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9676 9677 kbd(1:5*3) = 0.0_dp 9678 kbc(1:5*1) = 0.0_dp 9679 kad(1:1*3) = 0.0_dp 9680 kac(1:1*1) = 0.0_dp 9681 p_index = 0 9682 DO md = 1, 3 9683 DO mc = 1, 1 9684 DO mb = 1, 5 9685 ks_bd = 0.0_dp 9686 ks_bc = 0.0_dp 9687 p_bd = pbd((md - 1)*5 + mb) 9688 p_bc = pbc((mc - 1)*5 + mb) 9689 DO ma = 1, 1 9690 p_index = p_index + 1 9691 tmp = scale*prim(p_index) 9692 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9693 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9694 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9695 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9696 END DO 9697 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9698 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9699 END DO 9700 END DO 9701 END DO 9702 END SUBROUTINE block_1_5_1_3 9703! ************************************************************************************************** 9704!> \brief ... 9705!> \param md_max ... 9706!> \param kbd ... 9707!> \param kbc ... 9708!> \param kad ... 9709!> \param kac ... 9710!> \param pbd ... 9711!> \param pbc ... 9712!> \param pad ... 9713!> \param pac ... 9714!> \param prim ... 9715!> \param scale ... 9716! ************************************************************************************************** 9717 SUBROUTINE block_1_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9718 INTEGER :: md_max 9719 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(1*md_max), kac(1*1), pbd(5*md_max), pbc(5*1), & 9720 pad(1*md_max), pac(1*1), prim(1*5*1*md_max), scale 9721 9722 INTEGER :: ma, mb, mc, md, p_index 9723 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9724 9725 kbd(1:5*md_max) = 0.0_dp 9726 kbc(1:5*1) = 0.0_dp 9727 kad(1:1*md_max) = 0.0_dp 9728 kac(1:1*1) = 0.0_dp 9729 p_index = 0 9730 DO md = 1, md_max 9731 DO mc = 1, 1 9732 DO mb = 1, 5 9733 ks_bd = 0.0_dp 9734 ks_bc = 0.0_dp 9735 p_bd = pbd((md - 1)*5 + mb) 9736 p_bc = pbc((mc - 1)*5 + mb) 9737 DO ma = 1, 1 9738 p_index = p_index + 1 9739 tmp = scale*prim(p_index) 9740 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9741 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9742 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9743 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9744 END DO 9745 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9746 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9747 END DO 9748 END DO 9749 END DO 9750 END SUBROUTINE block_1_5_1 9751! ************************************************************************************************** 9752!> \brief ... 9753!> \param kbd ... 9754!> \param kbc ... 9755!> \param kad ... 9756!> \param kac ... 9757!> \param pbd ... 9758!> \param pbc ... 9759!> \param pad ... 9760!> \param pac ... 9761!> \param prim ... 9762!> \param scale ... 9763! ************************************************************************************************** 9764 SUBROUTINE block_1_5_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9765 REAL(KIND=dp) :: kbd(5*1), kbc(5*2), kad(1*1), kac(1*2), & 9766 pbd(5*1), pbc(5*2), pad(1*1), & 9767 pac(1*2), prim(1*5*2*1), scale 9768 9769 INTEGER :: ma, mb, mc, md, p_index 9770 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9771 9772 kbd(1:5*1) = 0.0_dp 9773 kbc(1:5*2) = 0.0_dp 9774 kad(1:1*1) = 0.0_dp 9775 kac(1:1*2) = 0.0_dp 9776 p_index = 0 9777 DO md = 1, 1 9778 DO mc = 1, 2 9779 DO mb = 1, 5 9780 ks_bd = 0.0_dp 9781 ks_bc = 0.0_dp 9782 p_bd = pbd((md - 1)*5 + mb) 9783 p_bc = pbc((mc - 1)*5 + mb) 9784 DO ma = 1, 1 9785 p_index = p_index + 1 9786 tmp = scale*prim(p_index) 9787 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9788 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9789 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9790 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9791 END DO 9792 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9793 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9794 END DO 9795 END DO 9796 END DO 9797 END SUBROUTINE block_1_5_2_1 9798! ************************************************************************************************** 9799!> \brief ... 9800!> \param md_max ... 9801!> \param kbd ... 9802!> \param kbc ... 9803!> \param kad ... 9804!> \param kac ... 9805!> \param pbd ... 9806!> \param pbc ... 9807!> \param pad ... 9808!> \param pac ... 9809!> \param prim ... 9810!> \param scale ... 9811! ************************************************************************************************** 9812 SUBROUTINE block_1_5_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9813 INTEGER :: md_max 9814 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*2), kad(1*md_max), kac(1*2), pbd(5*md_max), pbc(5*2), & 9815 pad(1*md_max), pac(1*2), prim(1*5*2*md_max), scale 9816 9817 INTEGER :: ma, mb, mc, md, p_index 9818 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9819 9820 kbd(1:5*md_max) = 0.0_dp 9821 kbc(1:5*2) = 0.0_dp 9822 kad(1:1*md_max) = 0.0_dp 9823 kac(1:1*2) = 0.0_dp 9824 p_index = 0 9825 DO md = 1, md_max 9826 DO mc = 1, 2 9827 DO mb = 1, 5 9828 ks_bd = 0.0_dp 9829 ks_bc = 0.0_dp 9830 p_bd = pbd((md - 1)*5 + mb) 9831 p_bc = pbc((mc - 1)*5 + mb) 9832 DO ma = 1, 1 9833 p_index = p_index + 1 9834 tmp = scale*prim(p_index) 9835 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9836 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9837 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9838 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9839 END DO 9840 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9841 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9842 END DO 9843 END DO 9844 END DO 9845 END SUBROUTINE block_1_5_2 9846! ************************************************************************************************** 9847!> \brief ... 9848!> \param kbd ... 9849!> \param kbc ... 9850!> \param kad ... 9851!> \param kac ... 9852!> \param pbd ... 9853!> \param pbc ... 9854!> \param pad ... 9855!> \param pac ... 9856!> \param prim ... 9857!> \param scale ... 9858! ************************************************************************************************** 9859 SUBROUTINE block_1_5_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9860 REAL(KIND=dp) :: kbd(5*1), kbc(5*3), kad(1*1), kac(1*3), & 9861 pbd(5*1), pbc(5*3), pad(1*1), & 9862 pac(1*3), prim(1*5*3*1), scale 9863 9864 INTEGER :: ma, mb, mc, md, p_index 9865 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9866 9867 kbd(1:5*1) = 0.0_dp 9868 kbc(1:5*3) = 0.0_dp 9869 kad(1:1*1) = 0.0_dp 9870 kac(1:1*3) = 0.0_dp 9871 p_index = 0 9872 DO md = 1, 1 9873 DO mc = 1, 3 9874 DO mb = 1, 5 9875 ks_bd = 0.0_dp 9876 ks_bc = 0.0_dp 9877 p_bd = pbd((md - 1)*5 + mb) 9878 p_bc = pbc((mc - 1)*5 + mb) 9879 DO ma = 1, 1 9880 p_index = p_index + 1 9881 tmp = scale*prim(p_index) 9882 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9883 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9884 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9885 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9886 END DO 9887 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9888 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9889 END DO 9890 END DO 9891 END DO 9892 END SUBROUTINE block_1_5_3_1 9893! ************************************************************************************************** 9894!> \brief ... 9895!> \param md_max ... 9896!> \param kbd ... 9897!> \param kbc ... 9898!> \param kad ... 9899!> \param kac ... 9900!> \param pbd ... 9901!> \param pbc ... 9902!> \param pad ... 9903!> \param pac ... 9904!> \param prim ... 9905!> \param scale ... 9906! ************************************************************************************************** 9907 SUBROUTINE block_1_5_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9908 INTEGER :: md_max 9909 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*3), kad(1*md_max), kac(1*3), pbd(5*md_max), pbc(5*3), & 9910 pad(1*md_max), pac(1*3), prim(1*5*3*md_max), scale 9911 9912 INTEGER :: ma, mb, mc, md, p_index 9913 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9914 9915 kbd(1:5*md_max) = 0.0_dp 9916 kbc(1:5*3) = 0.0_dp 9917 kad(1:1*md_max) = 0.0_dp 9918 kac(1:1*3) = 0.0_dp 9919 p_index = 0 9920 DO md = 1, md_max 9921 DO mc = 1, 3 9922 DO mb = 1, 5 9923 ks_bd = 0.0_dp 9924 ks_bc = 0.0_dp 9925 p_bd = pbd((md - 1)*5 + mb) 9926 p_bc = pbc((mc - 1)*5 + mb) 9927 DO ma = 1, 1 9928 p_index = p_index + 1 9929 tmp = scale*prim(p_index) 9930 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9931 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9932 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9933 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9934 END DO 9935 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9936 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9937 END DO 9938 END DO 9939 END DO 9940 END SUBROUTINE block_1_5_3 9941! ************************************************************************************************** 9942!> \brief ... 9943!> \param mc_max ... 9944!> \param md_max ... 9945!> \param kbd ... 9946!> \param kbc ... 9947!> \param kad ... 9948!> \param kac ... 9949!> \param pbd ... 9950!> \param pbc ... 9951!> \param pad ... 9952!> \param pac ... 9953!> \param prim ... 9954!> \param scale ... 9955! ************************************************************************************************** 9956 SUBROUTINE block_1_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 9957 INTEGER :: mc_max, md_max 9958 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(1*md_max), kac(1*mc_max), pbd(5*md_max), & 9959 pbc(5*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*5*mc_max*md_max), scale 9960 9961 INTEGER :: ma, mb, mc, md, p_index 9962 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 9963 9964 kbd(1:5*md_max) = 0.0_dp 9965 kbc(1:5*mc_max) = 0.0_dp 9966 kad(1:1*md_max) = 0.0_dp 9967 kac(1:1*mc_max) = 0.0_dp 9968 p_index = 0 9969 DO md = 1, md_max 9970 DO mc = 1, mc_max 9971 DO mb = 1, 5 9972 ks_bd = 0.0_dp 9973 ks_bc = 0.0_dp 9974 p_bd = pbd((md - 1)*5 + mb) 9975 p_bc = pbc((mc - 1)*5 + mb) 9976 DO ma = 1, 1 9977 p_index = p_index + 1 9978 tmp = scale*prim(p_index) 9979 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 9980 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 9981 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 9982 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 9983 END DO 9984 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 9985 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 9986 END DO 9987 END DO 9988 END DO 9989 END SUBROUTINE block_1_5 9990! ************************************************************************************************** 9991!> \brief ... 9992!> \param kbd ... 9993!> \param kbc ... 9994!> \param kad ... 9995!> \param kac ... 9996!> \param pbd ... 9997!> \param pbc ... 9998!> \param pad ... 9999!> \param pac ... 10000!> \param prim ... 10001!> \param scale ... 10002! ************************************************************************************************** 10003 SUBROUTINE block_1_6_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10004 REAL(KIND=dp) :: kbd(6*1), kbc(6*1), kad(1*1), kac(1*1), & 10005 pbd(6*1), pbc(6*1), pad(1*1), & 10006 pac(1*1), prim(1*6*1*1), scale 10007 10008 INTEGER :: ma, mb, mc, md, p_index 10009 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10010 10011 kbd(1:6*1) = 0.0_dp 10012 kbc(1:6*1) = 0.0_dp 10013 kad(1:1*1) = 0.0_dp 10014 kac(1:1*1) = 0.0_dp 10015 p_index = 0 10016 DO md = 1, 1 10017 DO mc = 1, 1 10018 DO mb = 1, 6 10019 ks_bd = 0.0_dp 10020 ks_bc = 0.0_dp 10021 p_bd = pbd((md - 1)*6 + mb) 10022 p_bc = pbc((mc - 1)*6 + mb) 10023 DO ma = 1, 1 10024 p_index = p_index + 1 10025 tmp = scale*prim(p_index) 10026 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10027 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10028 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10029 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10030 END DO 10031 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10032 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10033 END DO 10034 END DO 10035 END DO 10036 END SUBROUTINE block_1_6_1_1 10037! ************************************************************************************************** 10038!> \brief ... 10039!> \param kbd ... 10040!> \param kbc ... 10041!> \param kad ... 10042!> \param kac ... 10043!> \param pbd ... 10044!> \param pbc ... 10045!> \param pad ... 10046!> \param pac ... 10047!> \param prim ... 10048!> \param scale ... 10049! ************************************************************************************************** 10050 SUBROUTINE block_1_6_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10051 REAL(KIND=dp) :: kbd(6*2), kbc(6*1), kad(1*2), kac(1*1), & 10052 pbd(6*2), pbc(6*1), pad(1*2), & 10053 pac(1*1), prim(1*6*1*2), scale 10054 10055 INTEGER :: ma, mb, mc, md, p_index 10056 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10057 10058 kbd(1:6*2) = 0.0_dp 10059 kbc(1:6*1) = 0.0_dp 10060 kad(1:1*2) = 0.0_dp 10061 kac(1:1*1) = 0.0_dp 10062 p_index = 0 10063 DO md = 1, 2 10064 DO mc = 1, 1 10065 DO mb = 1, 6 10066 ks_bd = 0.0_dp 10067 ks_bc = 0.0_dp 10068 p_bd = pbd((md - 1)*6 + mb) 10069 p_bc = pbc((mc - 1)*6 + mb) 10070 DO ma = 1, 1 10071 p_index = p_index + 1 10072 tmp = scale*prim(p_index) 10073 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10074 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10075 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10076 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10077 END DO 10078 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10079 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10080 END DO 10081 END DO 10082 END DO 10083 END SUBROUTINE block_1_6_1_2 10084! ************************************************************************************************** 10085!> \brief ... 10086!> \param kbd ... 10087!> \param kbc ... 10088!> \param kad ... 10089!> \param kac ... 10090!> \param pbd ... 10091!> \param pbc ... 10092!> \param pad ... 10093!> \param pac ... 10094!> \param prim ... 10095!> \param scale ... 10096! ************************************************************************************************** 10097 SUBROUTINE block_1_6_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10098 REAL(KIND=dp) :: kbd(6*3), kbc(6*1), kad(1*3), kac(1*1), & 10099 pbd(6*3), pbc(6*1), pad(1*3), & 10100 pac(1*1), prim(1*6*1*3), scale 10101 10102 INTEGER :: ma, mb, mc, md, p_index 10103 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10104 10105 kbd(1:6*3) = 0.0_dp 10106 kbc(1:6*1) = 0.0_dp 10107 kad(1:1*3) = 0.0_dp 10108 kac(1:1*1) = 0.0_dp 10109 p_index = 0 10110 DO md = 1, 3 10111 DO mc = 1, 1 10112 DO mb = 1, 6 10113 ks_bd = 0.0_dp 10114 ks_bc = 0.0_dp 10115 p_bd = pbd((md - 1)*6 + mb) 10116 p_bc = pbc((mc - 1)*6 + mb) 10117 DO ma = 1, 1 10118 p_index = p_index + 1 10119 tmp = scale*prim(p_index) 10120 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10121 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10122 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10123 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10124 END DO 10125 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10126 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10127 END DO 10128 END DO 10129 END DO 10130 END SUBROUTINE block_1_6_1_3 10131! ************************************************************************************************** 10132!> \brief ... 10133!> \param md_max ... 10134!> \param kbd ... 10135!> \param kbc ... 10136!> \param kad ... 10137!> \param kac ... 10138!> \param pbd ... 10139!> \param pbc ... 10140!> \param pad ... 10141!> \param pac ... 10142!> \param prim ... 10143!> \param scale ... 10144! ************************************************************************************************** 10145 SUBROUTINE block_1_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10146 INTEGER :: md_max 10147 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*1), kad(1*md_max), kac(1*1), pbd(6*md_max), pbc(6*1), & 10148 pad(1*md_max), pac(1*1), prim(1*6*1*md_max), scale 10149 10150 INTEGER :: ma, mb, mc, md, p_index 10151 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10152 10153 kbd(1:6*md_max) = 0.0_dp 10154 kbc(1:6*1) = 0.0_dp 10155 kad(1:1*md_max) = 0.0_dp 10156 kac(1:1*1) = 0.0_dp 10157 p_index = 0 10158 DO md = 1, md_max 10159 DO mc = 1, 1 10160 DO mb = 1, 6 10161 ks_bd = 0.0_dp 10162 ks_bc = 0.0_dp 10163 p_bd = pbd((md - 1)*6 + mb) 10164 p_bc = pbc((mc - 1)*6 + mb) 10165 DO ma = 1, 1 10166 p_index = p_index + 1 10167 tmp = scale*prim(p_index) 10168 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10169 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10170 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10171 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10172 END DO 10173 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10174 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10175 END DO 10176 END DO 10177 END DO 10178 END SUBROUTINE block_1_6_1 10179! ************************************************************************************************** 10180!> \brief ... 10181!> \param kbd ... 10182!> \param kbc ... 10183!> \param kad ... 10184!> \param kac ... 10185!> \param pbd ... 10186!> \param pbc ... 10187!> \param pad ... 10188!> \param pac ... 10189!> \param prim ... 10190!> \param scale ... 10191! ************************************************************************************************** 10192 SUBROUTINE block_1_6_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10193 REAL(KIND=dp) :: kbd(6*1), kbc(6*2), kad(1*1), kac(1*2), & 10194 pbd(6*1), pbc(6*2), pad(1*1), & 10195 pac(1*2), prim(1*6*2*1), scale 10196 10197 INTEGER :: ma, mb, mc, md, p_index 10198 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10199 10200 kbd(1:6*1) = 0.0_dp 10201 kbc(1:6*2) = 0.0_dp 10202 kad(1:1*1) = 0.0_dp 10203 kac(1:1*2) = 0.0_dp 10204 p_index = 0 10205 DO md = 1, 1 10206 DO mc = 1, 2 10207 DO mb = 1, 6 10208 ks_bd = 0.0_dp 10209 ks_bc = 0.0_dp 10210 p_bd = pbd((md - 1)*6 + mb) 10211 p_bc = pbc((mc - 1)*6 + mb) 10212 DO ma = 1, 1 10213 p_index = p_index + 1 10214 tmp = scale*prim(p_index) 10215 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10216 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10217 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10218 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10219 END DO 10220 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10221 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10222 END DO 10223 END DO 10224 END DO 10225 END SUBROUTINE block_1_6_2_1 10226! ************************************************************************************************** 10227!> \brief ... 10228!> \param md_max ... 10229!> \param kbd ... 10230!> \param kbc ... 10231!> \param kad ... 10232!> \param kac ... 10233!> \param pbd ... 10234!> \param pbc ... 10235!> \param pad ... 10236!> \param pac ... 10237!> \param prim ... 10238!> \param scale ... 10239! ************************************************************************************************** 10240 SUBROUTINE block_1_6_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10241 INTEGER :: md_max 10242 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*2), kad(1*md_max), kac(1*2), pbd(6*md_max), pbc(6*2), & 10243 pad(1*md_max), pac(1*2), prim(1*6*2*md_max), scale 10244 10245 INTEGER :: ma, mb, mc, md, p_index 10246 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10247 10248 kbd(1:6*md_max) = 0.0_dp 10249 kbc(1:6*2) = 0.0_dp 10250 kad(1:1*md_max) = 0.0_dp 10251 kac(1:1*2) = 0.0_dp 10252 p_index = 0 10253 DO md = 1, md_max 10254 DO mc = 1, 2 10255 DO mb = 1, 6 10256 ks_bd = 0.0_dp 10257 ks_bc = 0.0_dp 10258 p_bd = pbd((md - 1)*6 + mb) 10259 p_bc = pbc((mc - 1)*6 + mb) 10260 DO ma = 1, 1 10261 p_index = p_index + 1 10262 tmp = scale*prim(p_index) 10263 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10264 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10265 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10266 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10267 END DO 10268 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10269 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10270 END DO 10271 END DO 10272 END DO 10273 END SUBROUTINE block_1_6_2 10274! ************************************************************************************************** 10275!> \brief ... 10276!> \param kbd ... 10277!> \param kbc ... 10278!> \param kad ... 10279!> \param kac ... 10280!> \param pbd ... 10281!> \param pbc ... 10282!> \param pad ... 10283!> \param pac ... 10284!> \param prim ... 10285!> \param scale ... 10286! ************************************************************************************************** 10287 SUBROUTINE block_1_6_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10288 REAL(KIND=dp) :: kbd(6*1), kbc(6*3), kad(1*1), kac(1*3), & 10289 pbd(6*1), pbc(6*3), pad(1*1), & 10290 pac(1*3), prim(1*6*3*1), scale 10291 10292 INTEGER :: ma, mb, mc, md, p_index 10293 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10294 10295 kbd(1:6*1) = 0.0_dp 10296 kbc(1:6*3) = 0.0_dp 10297 kad(1:1*1) = 0.0_dp 10298 kac(1:1*3) = 0.0_dp 10299 p_index = 0 10300 DO md = 1, 1 10301 DO mc = 1, 3 10302 DO mb = 1, 6 10303 ks_bd = 0.0_dp 10304 ks_bc = 0.0_dp 10305 p_bd = pbd((md - 1)*6 + mb) 10306 p_bc = pbc((mc - 1)*6 + mb) 10307 DO ma = 1, 1 10308 p_index = p_index + 1 10309 tmp = scale*prim(p_index) 10310 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10311 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10312 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10313 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10314 END DO 10315 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10316 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10317 END DO 10318 END DO 10319 END DO 10320 END SUBROUTINE block_1_6_3_1 10321! ************************************************************************************************** 10322!> \brief ... 10323!> \param md_max ... 10324!> \param kbd ... 10325!> \param kbc ... 10326!> \param kad ... 10327!> \param kac ... 10328!> \param pbd ... 10329!> \param pbc ... 10330!> \param pad ... 10331!> \param pac ... 10332!> \param prim ... 10333!> \param scale ... 10334! ************************************************************************************************** 10335 SUBROUTINE block_1_6_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10336 INTEGER :: md_max 10337 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*3), kad(1*md_max), kac(1*3), pbd(6*md_max), pbc(6*3), & 10338 pad(1*md_max), pac(1*3), prim(1*6*3*md_max), scale 10339 10340 INTEGER :: ma, mb, mc, md, p_index 10341 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10342 10343 kbd(1:6*md_max) = 0.0_dp 10344 kbc(1:6*3) = 0.0_dp 10345 kad(1:1*md_max) = 0.0_dp 10346 kac(1:1*3) = 0.0_dp 10347 p_index = 0 10348 DO md = 1, md_max 10349 DO mc = 1, 3 10350 DO mb = 1, 6 10351 ks_bd = 0.0_dp 10352 ks_bc = 0.0_dp 10353 p_bd = pbd((md - 1)*6 + mb) 10354 p_bc = pbc((mc - 1)*6 + mb) 10355 DO ma = 1, 1 10356 p_index = p_index + 1 10357 tmp = scale*prim(p_index) 10358 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10359 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10360 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10361 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10362 END DO 10363 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10364 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10365 END DO 10366 END DO 10367 END DO 10368 END SUBROUTINE block_1_6_3 10369! ************************************************************************************************** 10370!> \brief ... 10371!> \param mc_max ... 10372!> \param md_max ... 10373!> \param kbd ... 10374!> \param kbc ... 10375!> \param kad ... 10376!> \param kac ... 10377!> \param pbd ... 10378!> \param pbc ... 10379!> \param pad ... 10380!> \param pac ... 10381!> \param prim ... 10382!> \param scale ... 10383! ************************************************************************************************** 10384 SUBROUTINE block_1_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10385 INTEGER :: mc_max, md_max 10386 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(1*md_max), kac(1*mc_max), pbd(6*md_max), & 10387 pbc(6*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*6*mc_max*md_max), scale 10388 10389 INTEGER :: ma, mb, mc, md, p_index 10390 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10391 10392 kbd(1:6*md_max) = 0.0_dp 10393 kbc(1:6*mc_max) = 0.0_dp 10394 kad(1:1*md_max) = 0.0_dp 10395 kac(1:1*mc_max) = 0.0_dp 10396 p_index = 0 10397 DO md = 1, md_max 10398 DO mc = 1, mc_max 10399 DO mb = 1, 6 10400 ks_bd = 0.0_dp 10401 ks_bc = 0.0_dp 10402 p_bd = pbd((md - 1)*6 + mb) 10403 p_bc = pbc((mc - 1)*6 + mb) 10404 DO ma = 1, 1 10405 p_index = p_index + 1 10406 tmp = scale*prim(p_index) 10407 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10408 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10409 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10410 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10411 END DO 10412 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 10413 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 10414 END DO 10415 END DO 10416 END DO 10417 END SUBROUTINE block_1_6 10418! ************************************************************************************************** 10419!> \brief ... 10420!> \param kbd ... 10421!> \param kbc ... 10422!> \param kad ... 10423!> \param kac ... 10424!> \param pbd ... 10425!> \param pbc ... 10426!> \param pad ... 10427!> \param pac ... 10428!> \param prim ... 10429!> \param scale ... 10430! ************************************************************************************************** 10431 SUBROUTINE block_1_7_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10432 REAL(KIND=dp) :: kbd(7*1), kbc(7*1), kad(1*1), kac(1*1), & 10433 pbd(7*1), pbc(7*1), pad(1*1), & 10434 pac(1*1), prim(1*7*1*1), scale 10435 10436 INTEGER :: ma, mb, mc, md, p_index 10437 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10438 10439 kbd(1:7*1) = 0.0_dp 10440 kbc(1:7*1) = 0.0_dp 10441 kad(1:1*1) = 0.0_dp 10442 kac(1:1*1) = 0.0_dp 10443 p_index = 0 10444 DO md = 1, 1 10445 DO mc = 1, 1 10446 DO mb = 1, 7 10447 ks_bd = 0.0_dp 10448 ks_bc = 0.0_dp 10449 p_bd = pbd((md - 1)*7 + mb) 10450 p_bc = pbc((mc - 1)*7 + mb) 10451 DO ma = 1, 1 10452 p_index = p_index + 1 10453 tmp = scale*prim(p_index) 10454 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10455 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10456 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10457 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10458 END DO 10459 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 10460 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 10461 END DO 10462 END DO 10463 END DO 10464 END SUBROUTINE block_1_7_1_1 10465! ************************************************************************************************** 10466!> \brief ... 10467!> \param kbd ... 10468!> \param kbc ... 10469!> \param kad ... 10470!> \param kac ... 10471!> \param pbd ... 10472!> \param pbc ... 10473!> \param pad ... 10474!> \param pac ... 10475!> \param prim ... 10476!> \param scale ... 10477! ************************************************************************************************** 10478 SUBROUTINE block_1_7_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10479 REAL(KIND=dp) :: kbd(7*2), kbc(7*1), kad(1*2), kac(1*1), & 10480 pbd(7*2), pbc(7*1), pad(1*2), & 10481 pac(1*1), prim(1*7*1*2), scale 10482 10483 INTEGER :: ma, mb, mc, md, p_index 10484 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10485 10486 kbd(1:7*2) = 0.0_dp 10487 kbc(1:7*1) = 0.0_dp 10488 kad(1:1*2) = 0.0_dp 10489 kac(1:1*1) = 0.0_dp 10490 p_index = 0 10491 DO md = 1, 2 10492 DO mc = 1, 1 10493 DO mb = 1, 7 10494 ks_bd = 0.0_dp 10495 ks_bc = 0.0_dp 10496 p_bd = pbd((md - 1)*7 + mb) 10497 p_bc = pbc((mc - 1)*7 + mb) 10498 DO ma = 1, 1 10499 p_index = p_index + 1 10500 tmp = scale*prim(p_index) 10501 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10502 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10503 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10504 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10505 END DO 10506 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 10507 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 10508 END DO 10509 END DO 10510 END DO 10511 END SUBROUTINE block_1_7_1_2 10512! ************************************************************************************************** 10513!> \brief ... 10514!> \param md_max ... 10515!> \param kbd ... 10516!> \param kbc ... 10517!> \param kad ... 10518!> \param kac ... 10519!> \param pbd ... 10520!> \param pbc ... 10521!> \param pad ... 10522!> \param pac ... 10523!> \param prim ... 10524!> \param scale ... 10525! ************************************************************************************************** 10526 SUBROUTINE block_1_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10527 INTEGER :: md_max 10528 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*1), kad(1*md_max), kac(1*1), pbd(7*md_max), pbc(7*1), & 10529 pad(1*md_max), pac(1*1), prim(1*7*1*md_max), scale 10530 10531 INTEGER :: ma, mb, mc, md, p_index 10532 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10533 10534 kbd(1:7*md_max) = 0.0_dp 10535 kbc(1:7*1) = 0.0_dp 10536 kad(1:1*md_max) = 0.0_dp 10537 kac(1:1*1) = 0.0_dp 10538 p_index = 0 10539 DO md = 1, md_max 10540 DO mc = 1, 1 10541 DO mb = 1, 7 10542 ks_bd = 0.0_dp 10543 ks_bc = 0.0_dp 10544 p_bd = pbd((md - 1)*7 + mb) 10545 p_bc = pbc((mc - 1)*7 + mb) 10546 DO ma = 1, 1 10547 p_index = p_index + 1 10548 tmp = scale*prim(p_index) 10549 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10550 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10551 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10552 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10553 END DO 10554 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 10555 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 10556 END DO 10557 END DO 10558 END DO 10559 END SUBROUTINE block_1_7_1 10560! ************************************************************************************************** 10561!> \brief ... 10562!> \param kbd ... 10563!> \param kbc ... 10564!> \param kad ... 10565!> \param kac ... 10566!> \param pbd ... 10567!> \param pbc ... 10568!> \param pad ... 10569!> \param pac ... 10570!> \param prim ... 10571!> \param scale ... 10572! ************************************************************************************************** 10573 SUBROUTINE block_1_7_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10574 REAL(KIND=dp) :: kbd(7*1), kbc(7*2), kad(1*1), kac(1*2), & 10575 pbd(7*1), pbc(7*2), pad(1*1), & 10576 pac(1*2), prim(1*7*2*1), scale 10577 10578 INTEGER :: ma, mb, mc, md, p_index 10579 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10580 10581 kbd(1:7*1) = 0.0_dp 10582 kbc(1:7*2) = 0.0_dp 10583 kad(1:1*1) = 0.0_dp 10584 kac(1:1*2) = 0.0_dp 10585 p_index = 0 10586 DO md = 1, 1 10587 DO mc = 1, 2 10588 DO mb = 1, 7 10589 ks_bd = 0.0_dp 10590 ks_bc = 0.0_dp 10591 p_bd = pbd((md - 1)*7 + mb) 10592 p_bc = pbc((mc - 1)*7 + mb) 10593 DO ma = 1, 1 10594 p_index = p_index + 1 10595 tmp = scale*prim(p_index) 10596 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10597 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10598 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10599 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10600 END DO 10601 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 10602 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 10603 END DO 10604 END DO 10605 END DO 10606 END SUBROUTINE block_1_7_2_1 10607! ************************************************************************************************** 10608!> \brief ... 10609!> \param md_max ... 10610!> \param kbd ... 10611!> \param kbc ... 10612!> \param kad ... 10613!> \param kac ... 10614!> \param pbd ... 10615!> \param pbc ... 10616!> \param pad ... 10617!> \param pac ... 10618!> \param prim ... 10619!> \param scale ... 10620! ************************************************************************************************** 10621 SUBROUTINE block_1_7_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10622 INTEGER :: md_max 10623 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*2), kad(1*md_max), kac(1*2), pbd(7*md_max), pbc(7*2), & 10624 pad(1*md_max), pac(1*2), prim(1*7*2*md_max), scale 10625 10626 INTEGER :: ma, mb, mc, md, p_index 10627 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10628 10629 kbd(1:7*md_max) = 0.0_dp 10630 kbc(1:7*2) = 0.0_dp 10631 kad(1:1*md_max) = 0.0_dp 10632 kac(1:1*2) = 0.0_dp 10633 p_index = 0 10634 DO md = 1, md_max 10635 DO mc = 1, 2 10636 DO mb = 1, 7 10637 ks_bd = 0.0_dp 10638 ks_bc = 0.0_dp 10639 p_bd = pbd((md - 1)*7 + mb) 10640 p_bc = pbc((mc - 1)*7 + mb) 10641 DO ma = 1, 1 10642 p_index = p_index + 1 10643 tmp = scale*prim(p_index) 10644 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10645 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10646 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10647 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10648 END DO 10649 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 10650 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 10651 END DO 10652 END DO 10653 END DO 10654 END SUBROUTINE block_1_7_2 10655! ************************************************************************************************** 10656!> \brief ... 10657!> \param mc_max ... 10658!> \param md_max ... 10659!> \param kbd ... 10660!> \param kbc ... 10661!> \param kad ... 10662!> \param kac ... 10663!> \param pbd ... 10664!> \param pbc ... 10665!> \param pad ... 10666!> \param pac ... 10667!> \param prim ... 10668!> \param scale ... 10669! ************************************************************************************************** 10670 SUBROUTINE block_1_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10671 INTEGER :: mc_max, md_max 10672 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(1*md_max), kac(1*mc_max), pbd(7*md_max), & 10673 pbc(7*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*7*mc_max*md_max), scale 10674 10675 INTEGER :: ma, mb, mc, md, p_index 10676 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10677 10678 kbd(1:7*md_max) = 0.0_dp 10679 kbc(1:7*mc_max) = 0.0_dp 10680 kad(1:1*md_max) = 0.0_dp 10681 kac(1:1*mc_max) = 0.0_dp 10682 p_index = 0 10683 DO md = 1, md_max 10684 DO mc = 1, mc_max 10685 DO mb = 1, 7 10686 ks_bd = 0.0_dp 10687 ks_bc = 0.0_dp 10688 p_bd = pbd((md - 1)*7 + mb) 10689 p_bc = pbc((mc - 1)*7 + mb) 10690 DO ma = 1, 1 10691 p_index = p_index + 1 10692 tmp = scale*prim(p_index) 10693 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10694 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10695 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10696 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10697 END DO 10698 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 10699 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 10700 END DO 10701 END DO 10702 END DO 10703 END SUBROUTINE block_1_7 10704! ************************************************************************************************** 10705!> \brief ... 10706!> \param kbd ... 10707!> \param kbc ... 10708!> \param kad ... 10709!> \param kac ... 10710!> \param pbd ... 10711!> \param pbc ... 10712!> \param pad ... 10713!> \param pac ... 10714!> \param prim ... 10715!> \param scale ... 10716! ************************************************************************************************** 10717 SUBROUTINE block_1_9_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10718 REAL(KIND=dp) :: kbd(9*1), kbc(9*1), kad(1*1), kac(1*1), & 10719 pbd(9*1), pbc(9*1), pad(1*1), & 10720 pac(1*1), prim(1*9*1*1), scale 10721 10722 INTEGER :: ma, mb, mc, md, p_index 10723 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10724 10725 kbd(1:9*1) = 0.0_dp 10726 kbc(1:9*1) = 0.0_dp 10727 kad(1:1*1) = 0.0_dp 10728 kac(1:1*1) = 0.0_dp 10729 p_index = 0 10730 DO md = 1, 1 10731 DO mc = 1, 1 10732 DO mb = 1, 9 10733 ks_bd = 0.0_dp 10734 ks_bc = 0.0_dp 10735 p_bd = pbd((md - 1)*9 + mb) 10736 p_bc = pbc((mc - 1)*9 + mb) 10737 DO ma = 1, 1 10738 p_index = p_index + 1 10739 tmp = scale*prim(p_index) 10740 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10741 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10742 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10743 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10744 END DO 10745 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 10746 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 10747 END DO 10748 END DO 10749 END DO 10750 END SUBROUTINE block_1_9_1_1 10751! ************************************************************************************************** 10752!> \brief ... 10753!> \param kbd ... 10754!> \param kbc ... 10755!> \param kad ... 10756!> \param kac ... 10757!> \param pbd ... 10758!> \param pbc ... 10759!> \param pad ... 10760!> \param pac ... 10761!> \param prim ... 10762!> \param scale ... 10763! ************************************************************************************************** 10764 SUBROUTINE block_1_9_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10765 REAL(KIND=dp) :: kbd(9*2), kbc(9*1), kad(1*2), kac(1*1), & 10766 pbd(9*2), pbc(9*1), pad(1*2), & 10767 pac(1*1), prim(1*9*1*2), scale 10768 10769 INTEGER :: ma, mb, mc, md, p_index 10770 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10771 10772 kbd(1:9*2) = 0.0_dp 10773 kbc(1:9*1) = 0.0_dp 10774 kad(1:1*2) = 0.0_dp 10775 kac(1:1*1) = 0.0_dp 10776 p_index = 0 10777 DO md = 1, 2 10778 DO mc = 1, 1 10779 DO mb = 1, 9 10780 ks_bd = 0.0_dp 10781 ks_bc = 0.0_dp 10782 p_bd = pbd((md - 1)*9 + mb) 10783 p_bc = pbc((mc - 1)*9 + mb) 10784 DO ma = 1, 1 10785 p_index = p_index + 1 10786 tmp = scale*prim(p_index) 10787 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10788 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10789 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10790 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10791 END DO 10792 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 10793 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 10794 END DO 10795 END DO 10796 END DO 10797 END SUBROUTINE block_1_9_1_2 10798! ************************************************************************************************** 10799!> \brief ... 10800!> \param md_max ... 10801!> \param kbd ... 10802!> \param kbc ... 10803!> \param kad ... 10804!> \param kac ... 10805!> \param pbd ... 10806!> \param pbc ... 10807!> \param pad ... 10808!> \param pac ... 10809!> \param prim ... 10810!> \param scale ... 10811! ************************************************************************************************** 10812 SUBROUTINE block_1_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10813 INTEGER :: md_max 10814 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*1), kad(1*md_max), kac(1*1), pbd(9*md_max), pbc(9*1), & 10815 pad(1*md_max), pac(1*1), prim(1*9*1*md_max), scale 10816 10817 INTEGER :: ma, mb, mc, md, p_index 10818 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10819 10820 kbd(1:9*md_max) = 0.0_dp 10821 kbc(1:9*1) = 0.0_dp 10822 kad(1:1*md_max) = 0.0_dp 10823 kac(1:1*1) = 0.0_dp 10824 p_index = 0 10825 DO md = 1, md_max 10826 DO mc = 1, 1 10827 DO mb = 1, 9 10828 ks_bd = 0.0_dp 10829 ks_bc = 0.0_dp 10830 p_bd = pbd((md - 1)*9 + mb) 10831 p_bc = pbc((mc - 1)*9 + mb) 10832 DO ma = 1, 1 10833 p_index = p_index + 1 10834 tmp = scale*prim(p_index) 10835 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10836 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10837 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10838 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10839 END DO 10840 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 10841 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 10842 END DO 10843 END DO 10844 END DO 10845 END SUBROUTINE block_1_9_1 10846! ************************************************************************************************** 10847!> \brief ... 10848!> \param kbd ... 10849!> \param kbc ... 10850!> \param kad ... 10851!> \param kac ... 10852!> \param pbd ... 10853!> \param pbc ... 10854!> \param pad ... 10855!> \param pac ... 10856!> \param prim ... 10857!> \param scale ... 10858! ************************************************************************************************** 10859 SUBROUTINE block_1_9_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10860 REAL(KIND=dp) :: kbd(9*1), kbc(9*2), kad(1*1), kac(1*2), & 10861 pbd(9*1), pbc(9*2), pad(1*1), & 10862 pac(1*2), prim(1*9*2*1), scale 10863 10864 INTEGER :: ma, mb, mc, md, p_index 10865 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10866 10867 kbd(1:9*1) = 0.0_dp 10868 kbc(1:9*2) = 0.0_dp 10869 kad(1:1*1) = 0.0_dp 10870 kac(1:1*2) = 0.0_dp 10871 p_index = 0 10872 DO md = 1, 1 10873 DO mc = 1, 2 10874 DO mb = 1, 9 10875 ks_bd = 0.0_dp 10876 ks_bc = 0.0_dp 10877 p_bd = pbd((md - 1)*9 + mb) 10878 p_bc = pbc((mc - 1)*9 + mb) 10879 DO ma = 1, 1 10880 p_index = p_index + 1 10881 tmp = scale*prim(p_index) 10882 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10883 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10884 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10885 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10886 END DO 10887 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 10888 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 10889 END DO 10890 END DO 10891 END DO 10892 END SUBROUTINE block_1_9_2_1 10893! ************************************************************************************************** 10894!> \brief ... 10895!> \param md_max ... 10896!> \param kbd ... 10897!> \param kbc ... 10898!> \param kad ... 10899!> \param kac ... 10900!> \param pbd ... 10901!> \param pbc ... 10902!> \param pad ... 10903!> \param pac ... 10904!> \param prim ... 10905!> \param scale ... 10906! ************************************************************************************************** 10907 SUBROUTINE block_1_9_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10908 INTEGER :: md_max 10909 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*2), kad(1*md_max), kac(1*2), pbd(9*md_max), pbc(9*2), & 10910 pad(1*md_max), pac(1*2), prim(1*9*2*md_max), scale 10911 10912 INTEGER :: ma, mb, mc, md, p_index 10913 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10914 10915 kbd(1:9*md_max) = 0.0_dp 10916 kbc(1:9*2) = 0.0_dp 10917 kad(1:1*md_max) = 0.0_dp 10918 kac(1:1*2) = 0.0_dp 10919 p_index = 0 10920 DO md = 1, md_max 10921 DO mc = 1, 2 10922 DO mb = 1, 9 10923 ks_bd = 0.0_dp 10924 ks_bc = 0.0_dp 10925 p_bd = pbd((md - 1)*9 + mb) 10926 p_bc = pbc((mc - 1)*9 + mb) 10927 DO ma = 1, 1 10928 p_index = p_index + 1 10929 tmp = scale*prim(p_index) 10930 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10931 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10932 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10933 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10934 END DO 10935 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 10936 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 10937 END DO 10938 END DO 10939 END DO 10940 END SUBROUTINE block_1_9_2 10941! ************************************************************************************************** 10942!> \brief ... 10943!> \param mc_max ... 10944!> \param md_max ... 10945!> \param kbd ... 10946!> \param kbc ... 10947!> \param kad ... 10948!> \param kac ... 10949!> \param pbd ... 10950!> \param pbc ... 10951!> \param pad ... 10952!> \param pac ... 10953!> \param prim ... 10954!> \param scale ... 10955! ************************************************************************************************** 10956 SUBROUTINE block_1_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 10957 INTEGER :: mc_max, md_max 10958 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(1*md_max), kac(1*mc_max), pbd(9*md_max), & 10959 pbc(9*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*9*mc_max*md_max), scale 10960 10961 INTEGER :: ma, mb, mc, md, p_index 10962 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 10963 10964 kbd(1:9*md_max) = 0.0_dp 10965 kbc(1:9*mc_max) = 0.0_dp 10966 kad(1:1*md_max) = 0.0_dp 10967 kac(1:1*mc_max) = 0.0_dp 10968 p_index = 0 10969 DO md = 1, md_max 10970 DO mc = 1, mc_max 10971 DO mb = 1, 9 10972 ks_bd = 0.0_dp 10973 ks_bc = 0.0_dp 10974 p_bd = pbd((md - 1)*9 + mb) 10975 p_bc = pbc((mc - 1)*9 + mb) 10976 DO ma = 1, 1 10977 p_index = p_index + 1 10978 tmp = scale*prim(p_index) 10979 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 10980 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 10981 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 10982 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 10983 END DO 10984 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 10985 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 10986 END DO 10987 END DO 10988 END DO 10989 END SUBROUTINE block_1_9 10990! ************************************************************************************************** 10991!> \brief ... 10992!> \param kbd ... 10993!> \param kbc ... 10994!> \param kad ... 10995!> \param kac ... 10996!> \param pbd ... 10997!> \param pbc ... 10998!> \param pad ... 10999!> \param pac ... 11000!> \param prim ... 11001!> \param scale ... 11002! ************************************************************************************************** 11003 SUBROUTINE block_1_10_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11004 REAL(KIND=dp) :: kbd(10*1), kbc(10*1), kad(1*1), & 11005 kac(1*1), pbd(10*1), pbc(10*1), & 11006 pad(1*1), pac(1*1), prim(1*10*1*1), & 11007 scale 11008 11009 INTEGER :: ma, mb, mc, md, p_index 11010 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11011 11012 kbd(1:10*1) = 0.0_dp 11013 kbc(1:10*1) = 0.0_dp 11014 kad(1:1*1) = 0.0_dp 11015 kac(1:1*1) = 0.0_dp 11016 p_index = 0 11017 DO md = 1, 1 11018 DO mc = 1, 1 11019 DO mb = 1, 10 11020 ks_bd = 0.0_dp 11021 ks_bc = 0.0_dp 11022 p_bd = pbd((md - 1)*10 + mb) 11023 p_bc = pbc((mc - 1)*10 + mb) 11024 DO ma = 1, 1 11025 p_index = p_index + 1 11026 tmp = scale*prim(p_index) 11027 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11028 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11029 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11030 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11031 END DO 11032 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 11033 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 11034 END DO 11035 END DO 11036 END DO 11037 END SUBROUTINE block_1_10_1_1 11038! ************************************************************************************************** 11039!> \brief ... 11040!> \param md_max ... 11041!> \param kbd ... 11042!> \param kbc ... 11043!> \param kad ... 11044!> \param kac ... 11045!> \param pbd ... 11046!> \param pbc ... 11047!> \param pad ... 11048!> \param pac ... 11049!> \param prim ... 11050!> \param scale ... 11051! ************************************************************************************************** 11052 SUBROUTINE block_1_10_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11053 INTEGER :: md_max 11054 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*1), kad(1*md_max), kac(1*1), pbd(10*md_max), & 11055 pbc(10*1), pad(1*md_max), pac(1*1), prim(1*10*1*md_max), scale 11056 11057 INTEGER :: ma, mb, mc, md, p_index 11058 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11059 11060 kbd(1:10*md_max) = 0.0_dp 11061 kbc(1:10*1) = 0.0_dp 11062 kad(1:1*md_max) = 0.0_dp 11063 kac(1:1*1) = 0.0_dp 11064 p_index = 0 11065 DO md = 1, md_max 11066 DO mc = 1, 1 11067 DO mb = 1, 10 11068 ks_bd = 0.0_dp 11069 ks_bc = 0.0_dp 11070 p_bd = pbd((md - 1)*10 + mb) 11071 p_bc = pbc((mc - 1)*10 + mb) 11072 DO ma = 1, 1 11073 p_index = p_index + 1 11074 tmp = scale*prim(p_index) 11075 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11076 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11077 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11078 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11079 END DO 11080 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 11081 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 11082 END DO 11083 END DO 11084 END DO 11085 END SUBROUTINE block_1_10_1 11086! ************************************************************************************************** 11087!> \brief ... 11088!> \param mc_max ... 11089!> \param md_max ... 11090!> \param kbd ... 11091!> \param kbc ... 11092!> \param kad ... 11093!> \param kac ... 11094!> \param pbd ... 11095!> \param pbc ... 11096!> \param pad ... 11097!> \param pac ... 11098!> \param prim ... 11099!> \param scale ... 11100! ************************************************************************************************** 11101 SUBROUTINE block_1_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11102 INTEGER :: mc_max, md_max 11103 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(1*md_max), kac(1*mc_max), & 11104 pbd(10*md_max), pbc(10*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*10*mc_max*md_max), & 11105 scale 11106 11107 INTEGER :: ma, mb, mc, md, p_index 11108 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11109 11110 kbd(1:10*md_max) = 0.0_dp 11111 kbc(1:10*mc_max) = 0.0_dp 11112 kad(1:1*md_max) = 0.0_dp 11113 kac(1:1*mc_max) = 0.0_dp 11114 p_index = 0 11115 DO md = 1, md_max 11116 DO mc = 1, mc_max 11117 DO mb = 1, 10 11118 ks_bd = 0.0_dp 11119 ks_bc = 0.0_dp 11120 p_bd = pbd((md - 1)*10 + mb) 11121 p_bc = pbc((mc - 1)*10 + mb) 11122 DO ma = 1, 1 11123 p_index = p_index + 1 11124 tmp = scale*prim(p_index) 11125 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11126 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11127 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11128 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11129 END DO 11130 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 11131 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 11132 END DO 11133 END DO 11134 END DO 11135 END SUBROUTINE block_1_10 11136! ************************************************************************************************** 11137!> \brief ... 11138!> \param kbd ... 11139!> \param kbc ... 11140!> \param kad ... 11141!> \param kac ... 11142!> \param pbd ... 11143!> \param pbc ... 11144!> \param pad ... 11145!> \param pac ... 11146!> \param prim ... 11147!> \param scale ... 11148! ************************************************************************************************** 11149 SUBROUTINE block_1_11_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11150 REAL(KIND=dp) :: kbd(11*1), kbc(11*1), kad(1*1), & 11151 kac(1*1), pbd(11*1), pbc(11*1), & 11152 pad(1*1), pac(1*1), prim(1*11*1*1), & 11153 scale 11154 11155 INTEGER :: ma, mb, mc, md, p_index 11156 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11157 11158 kbd(1:11*1) = 0.0_dp 11159 kbc(1:11*1) = 0.0_dp 11160 kad(1:1*1) = 0.0_dp 11161 kac(1:1*1) = 0.0_dp 11162 p_index = 0 11163 DO md = 1, 1 11164 DO mc = 1, 1 11165 DO mb = 1, 11 11166 ks_bd = 0.0_dp 11167 ks_bc = 0.0_dp 11168 p_bd = pbd((md - 1)*11 + mb) 11169 p_bc = pbc((mc - 1)*11 + mb) 11170 DO ma = 1, 1 11171 p_index = p_index + 1 11172 tmp = scale*prim(p_index) 11173 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11174 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11175 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11176 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11177 END DO 11178 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 11179 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 11180 END DO 11181 END DO 11182 END DO 11183 END SUBROUTINE block_1_11_1_1 11184! ************************************************************************************************** 11185!> \brief ... 11186!> \param md_max ... 11187!> \param kbd ... 11188!> \param kbc ... 11189!> \param kad ... 11190!> \param kac ... 11191!> \param pbd ... 11192!> \param pbc ... 11193!> \param pad ... 11194!> \param pac ... 11195!> \param prim ... 11196!> \param scale ... 11197! ************************************************************************************************** 11198 SUBROUTINE block_1_11_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11199 INTEGER :: md_max 11200 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*1), kad(1*md_max), kac(1*1), pbd(11*md_max), & 11201 pbc(11*1), pad(1*md_max), pac(1*1), prim(1*11*1*md_max), scale 11202 11203 INTEGER :: ma, mb, mc, md, p_index 11204 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11205 11206 kbd(1:11*md_max) = 0.0_dp 11207 kbc(1:11*1) = 0.0_dp 11208 kad(1:1*md_max) = 0.0_dp 11209 kac(1:1*1) = 0.0_dp 11210 p_index = 0 11211 DO md = 1, md_max 11212 DO mc = 1, 1 11213 DO mb = 1, 11 11214 ks_bd = 0.0_dp 11215 ks_bc = 0.0_dp 11216 p_bd = pbd((md - 1)*11 + mb) 11217 p_bc = pbc((mc - 1)*11 + mb) 11218 DO ma = 1, 1 11219 p_index = p_index + 1 11220 tmp = scale*prim(p_index) 11221 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11222 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11223 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11224 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11225 END DO 11226 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 11227 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 11228 END DO 11229 END DO 11230 END DO 11231 END SUBROUTINE block_1_11_1 11232! ************************************************************************************************** 11233!> \brief ... 11234!> \param mc_max ... 11235!> \param md_max ... 11236!> \param kbd ... 11237!> \param kbc ... 11238!> \param kad ... 11239!> \param kac ... 11240!> \param pbd ... 11241!> \param pbc ... 11242!> \param pad ... 11243!> \param pac ... 11244!> \param prim ... 11245!> \param scale ... 11246! ************************************************************************************************** 11247 SUBROUTINE block_1_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11248 INTEGER :: mc_max, md_max 11249 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(1*md_max), kac(1*mc_max), & 11250 pbd(11*md_max), pbc(11*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*11*mc_max*md_max), & 11251 scale 11252 11253 INTEGER :: ma, mb, mc, md, p_index 11254 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11255 11256 kbd(1:11*md_max) = 0.0_dp 11257 kbc(1:11*mc_max) = 0.0_dp 11258 kad(1:1*md_max) = 0.0_dp 11259 kac(1:1*mc_max) = 0.0_dp 11260 p_index = 0 11261 DO md = 1, md_max 11262 DO mc = 1, mc_max 11263 DO mb = 1, 11 11264 ks_bd = 0.0_dp 11265 ks_bc = 0.0_dp 11266 p_bd = pbd((md - 1)*11 + mb) 11267 p_bc = pbc((mc - 1)*11 + mb) 11268 DO ma = 1, 1 11269 p_index = p_index + 1 11270 tmp = scale*prim(p_index) 11271 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11272 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11273 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11274 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11275 END DO 11276 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 11277 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 11278 END DO 11279 END DO 11280 END DO 11281 END SUBROUTINE block_1_11 11282! ************************************************************************************************** 11283!> \brief ... 11284!> \param kbd ... 11285!> \param kbc ... 11286!> \param kad ... 11287!> \param kac ... 11288!> \param pbd ... 11289!> \param pbc ... 11290!> \param pad ... 11291!> \param pac ... 11292!> \param prim ... 11293!> \param scale ... 11294! ************************************************************************************************** 11295 SUBROUTINE block_1_15_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11296 REAL(KIND=dp) :: kbd(15*1), kbc(15*1), kad(1*1), & 11297 kac(1*1), pbd(15*1), pbc(15*1), & 11298 pad(1*1), pac(1*1), prim(1*15*1*1), & 11299 scale 11300 11301 INTEGER :: ma, mb, mc, md, p_index 11302 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11303 11304 kbd(1:15*1) = 0.0_dp 11305 kbc(1:15*1) = 0.0_dp 11306 kad(1:1*1) = 0.0_dp 11307 kac(1:1*1) = 0.0_dp 11308 p_index = 0 11309 DO md = 1, 1 11310 DO mc = 1, 1 11311 DO mb = 1, 15 11312 ks_bd = 0.0_dp 11313 ks_bc = 0.0_dp 11314 p_bd = pbd((md - 1)*15 + mb) 11315 p_bc = pbc((mc - 1)*15 + mb) 11316 DO ma = 1, 1 11317 p_index = p_index + 1 11318 tmp = scale*prim(p_index) 11319 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11320 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11321 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11322 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11323 END DO 11324 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 11325 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 11326 END DO 11327 END DO 11328 END DO 11329 END SUBROUTINE block_1_15_1_1 11330! ************************************************************************************************** 11331!> \brief ... 11332!> \param md_max ... 11333!> \param kbd ... 11334!> \param kbc ... 11335!> \param kad ... 11336!> \param kac ... 11337!> \param pbd ... 11338!> \param pbc ... 11339!> \param pad ... 11340!> \param pac ... 11341!> \param prim ... 11342!> \param scale ... 11343! ************************************************************************************************** 11344 SUBROUTINE block_1_15_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11345 INTEGER :: md_max 11346 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*1), kad(1*md_max), kac(1*1), pbd(15*md_max), & 11347 pbc(15*1), pad(1*md_max), pac(1*1), prim(1*15*1*md_max), scale 11348 11349 INTEGER :: ma, mb, mc, md, p_index 11350 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11351 11352 kbd(1:15*md_max) = 0.0_dp 11353 kbc(1:15*1) = 0.0_dp 11354 kad(1:1*md_max) = 0.0_dp 11355 kac(1:1*1) = 0.0_dp 11356 p_index = 0 11357 DO md = 1, md_max 11358 DO mc = 1, 1 11359 DO mb = 1, 15 11360 ks_bd = 0.0_dp 11361 ks_bc = 0.0_dp 11362 p_bd = pbd((md - 1)*15 + mb) 11363 p_bc = pbc((mc - 1)*15 + mb) 11364 DO ma = 1, 1 11365 p_index = p_index + 1 11366 tmp = scale*prim(p_index) 11367 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11368 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11369 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11370 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11371 END DO 11372 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 11373 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 11374 END DO 11375 END DO 11376 END DO 11377 END SUBROUTINE block_1_15_1 11378! ************************************************************************************************** 11379!> \brief ... 11380!> \param mc_max ... 11381!> \param md_max ... 11382!> \param kbd ... 11383!> \param kbc ... 11384!> \param kad ... 11385!> \param kac ... 11386!> \param pbd ... 11387!> \param pbc ... 11388!> \param pad ... 11389!> \param pac ... 11390!> \param prim ... 11391!> \param scale ... 11392! ************************************************************************************************** 11393 SUBROUTINE block_1_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11394 INTEGER :: mc_max, md_max 11395 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(1*md_max), kac(1*mc_max), & 11396 pbd(15*md_max), pbc(15*mc_max), pad(1*md_max), pac(1*mc_max), prim(1*15*mc_max*md_max), & 11397 scale 11398 11399 INTEGER :: ma, mb, mc, md, p_index 11400 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11401 11402 kbd(1:15*md_max) = 0.0_dp 11403 kbc(1:15*mc_max) = 0.0_dp 11404 kad(1:1*md_max) = 0.0_dp 11405 kac(1:1*mc_max) = 0.0_dp 11406 p_index = 0 11407 DO md = 1, md_max 11408 DO mc = 1, mc_max 11409 DO mb = 1, 15 11410 ks_bd = 0.0_dp 11411 ks_bc = 0.0_dp 11412 p_bd = pbd((md - 1)*15 + mb) 11413 p_bc = pbc((mc - 1)*15 + mb) 11414 DO ma = 1, 1 11415 p_index = p_index + 1 11416 tmp = scale*prim(p_index) 11417 ks_bc = ks_bc + tmp*pad((md - 1)*1 + ma) 11418 ks_bd = ks_bd + tmp*pac((mc - 1)*1 + ma) 11419 kad((md - 1)*1 + ma) = kad((md - 1)*1 + ma) - tmp*p_bc 11420 kac((mc - 1)*1 + ma) = kac((mc - 1)*1 + ma) - tmp*p_bd 11421 END DO 11422 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 11423 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 11424 END DO 11425 END DO 11426 END DO 11427 END SUBROUTINE block_1_15 11428! ************************************************************************************************** 11429!> \brief ... 11430!> \param kbd ... 11431!> \param kbc ... 11432!> \param kad ... 11433!> \param kac ... 11434!> \param pbd ... 11435!> \param pbc ... 11436!> \param pad ... 11437!> \param pac ... 11438!> \param prim ... 11439!> \param scale ... 11440! ************************************************************************************************** 11441 SUBROUTINE block_2_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11442 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(2*1), kac(2*1), & 11443 pbd(1*1), pbc(1*1), pad(2*1), & 11444 pac(2*1), prim(2*1*1*1), scale 11445 11446 INTEGER :: ma, mb, mc, md, p_index 11447 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11448 11449 kbd(1:1*1) = 0.0_dp 11450 kbc(1:1*1) = 0.0_dp 11451 kad(1:2*1) = 0.0_dp 11452 kac(1:2*1) = 0.0_dp 11453 p_index = 0 11454 DO md = 1, 1 11455 DO mc = 1, 1 11456 DO mb = 1, 1 11457 ks_bd = 0.0_dp 11458 ks_bc = 0.0_dp 11459 p_bd = pbd((md - 1)*1 + mb) 11460 p_bc = pbc((mc - 1)*1 + mb) 11461 DO ma = 1, 2 11462 p_index = p_index + 1 11463 tmp = scale*prim(p_index) 11464 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11465 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11466 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11467 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11468 END DO 11469 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11470 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11471 END DO 11472 END DO 11473 END DO 11474 END SUBROUTINE block_2_1_1_1 11475! ************************************************************************************************** 11476!> \brief ... 11477!> \param kbd ... 11478!> \param kbc ... 11479!> \param kad ... 11480!> \param kac ... 11481!> \param pbd ... 11482!> \param pbc ... 11483!> \param pad ... 11484!> \param pac ... 11485!> \param prim ... 11486!> \param scale ... 11487! ************************************************************************************************** 11488 SUBROUTINE block_2_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11489 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(2*2), kac(2*1), & 11490 pbd(1*2), pbc(1*1), pad(2*2), & 11491 pac(2*1), prim(2*1*1*2), scale 11492 11493 INTEGER :: ma, mb, mc, md, p_index 11494 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11495 11496 kbd(1:1*2) = 0.0_dp 11497 kbc(1:1*1) = 0.0_dp 11498 kad(1:2*2) = 0.0_dp 11499 kac(1:2*1) = 0.0_dp 11500 p_index = 0 11501 DO md = 1, 2 11502 DO mc = 1, 1 11503 DO mb = 1, 1 11504 ks_bd = 0.0_dp 11505 ks_bc = 0.0_dp 11506 p_bd = pbd((md - 1)*1 + mb) 11507 p_bc = pbc((mc - 1)*1 + mb) 11508 DO ma = 1, 2 11509 p_index = p_index + 1 11510 tmp = scale*prim(p_index) 11511 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11512 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11513 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11514 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11515 END DO 11516 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11517 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11518 END DO 11519 END DO 11520 END DO 11521 END SUBROUTINE block_2_1_1_2 11522! ************************************************************************************************** 11523!> \brief ... 11524!> \param kbd ... 11525!> \param kbc ... 11526!> \param kad ... 11527!> \param kac ... 11528!> \param pbd ... 11529!> \param pbc ... 11530!> \param pad ... 11531!> \param pac ... 11532!> \param prim ... 11533!> \param scale ... 11534! ************************************************************************************************** 11535 SUBROUTINE block_2_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11536 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(2*3), kac(2*1), & 11537 pbd(1*3), pbc(1*1), pad(2*3), & 11538 pac(2*1), prim(2*1*1*3), scale 11539 11540 INTEGER :: ma, mb, mc, md, p_index 11541 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11542 11543 kbd(1:1*3) = 0.0_dp 11544 kbc(1:1*1) = 0.0_dp 11545 kad(1:2*3) = 0.0_dp 11546 kac(1:2*1) = 0.0_dp 11547 p_index = 0 11548 DO md = 1, 3 11549 DO mc = 1, 1 11550 DO mb = 1, 1 11551 ks_bd = 0.0_dp 11552 ks_bc = 0.0_dp 11553 p_bd = pbd((md - 1)*1 + mb) 11554 p_bc = pbc((mc - 1)*1 + mb) 11555 DO ma = 1, 2 11556 p_index = p_index + 1 11557 tmp = scale*prim(p_index) 11558 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11559 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11560 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11561 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11562 END DO 11563 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11564 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11565 END DO 11566 END DO 11567 END DO 11568 END SUBROUTINE block_2_1_1_3 11569! ************************************************************************************************** 11570!> \brief ... 11571!> \param kbd ... 11572!> \param kbc ... 11573!> \param kad ... 11574!> \param kac ... 11575!> \param pbd ... 11576!> \param pbc ... 11577!> \param pad ... 11578!> \param pac ... 11579!> \param prim ... 11580!> \param scale ... 11581! ************************************************************************************************** 11582 SUBROUTINE block_2_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11583 REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(2*4), kac(2*1), & 11584 pbd(1*4), pbc(1*1), pad(2*4), & 11585 pac(2*1), prim(2*1*1*4), scale 11586 11587 INTEGER :: ma, mb, mc, md, p_index 11588 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11589 11590 kbd(1:1*4) = 0.0_dp 11591 kbc(1:1*1) = 0.0_dp 11592 kad(1:2*4) = 0.0_dp 11593 kac(1:2*1) = 0.0_dp 11594 p_index = 0 11595 DO md = 1, 4 11596 DO mc = 1, 1 11597 DO mb = 1, 1 11598 ks_bd = 0.0_dp 11599 ks_bc = 0.0_dp 11600 p_bd = pbd((md - 1)*1 + mb) 11601 p_bc = pbc((mc - 1)*1 + mb) 11602 DO ma = 1, 2 11603 p_index = p_index + 1 11604 tmp = scale*prim(p_index) 11605 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11606 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11607 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11608 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11609 END DO 11610 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11611 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11612 END DO 11613 END DO 11614 END DO 11615 END SUBROUTINE block_2_1_1_4 11616! ************************************************************************************************** 11617!> \brief ... 11618!> \param kbd ... 11619!> \param kbc ... 11620!> \param kad ... 11621!> \param kac ... 11622!> \param pbd ... 11623!> \param pbc ... 11624!> \param pad ... 11625!> \param pac ... 11626!> \param prim ... 11627!> \param scale ... 11628! ************************************************************************************************** 11629 SUBROUTINE block_2_1_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11630 REAL(KIND=dp) :: kbd(1*5), kbc(1*1), kad(2*5), kac(2*1), & 11631 pbd(1*5), pbc(1*1), pad(2*5), & 11632 pac(2*1), prim(2*1*1*5), scale 11633 11634 INTEGER :: ma, mb, mc, md, p_index 11635 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11636 11637 kbd(1:1*5) = 0.0_dp 11638 kbc(1:1*1) = 0.0_dp 11639 kad(1:2*5) = 0.0_dp 11640 kac(1:2*1) = 0.0_dp 11641 p_index = 0 11642 DO md = 1, 5 11643 DO mc = 1, 1 11644 DO mb = 1, 1 11645 ks_bd = 0.0_dp 11646 ks_bc = 0.0_dp 11647 p_bd = pbd((md - 1)*1 + mb) 11648 p_bc = pbc((mc - 1)*1 + mb) 11649 DO ma = 1, 2 11650 p_index = p_index + 1 11651 tmp = scale*prim(p_index) 11652 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11653 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11654 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11655 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11656 END DO 11657 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11658 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11659 END DO 11660 END DO 11661 END DO 11662 END SUBROUTINE block_2_1_1_5 11663! ************************************************************************************************** 11664!> \brief ... 11665!> \param kbd ... 11666!> \param kbc ... 11667!> \param kad ... 11668!> \param kac ... 11669!> \param pbd ... 11670!> \param pbc ... 11671!> \param pad ... 11672!> \param pac ... 11673!> \param prim ... 11674!> \param scale ... 11675! ************************************************************************************************** 11676 SUBROUTINE block_2_1_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11677 REAL(KIND=dp) :: kbd(1*6), kbc(1*1), kad(2*6), kac(2*1), & 11678 pbd(1*6), pbc(1*1), pad(2*6), & 11679 pac(2*1), prim(2*1*1*6), scale 11680 11681 INTEGER :: ma, mb, mc, md, p_index 11682 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11683 11684 kbd(1:1*6) = 0.0_dp 11685 kbc(1:1*1) = 0.0_dp 11686 kad(1:2*6) = 0.0_dp 11687 kac(1:2*1) = 0.0_dp 11688 p_index = 0 11689 DO md = 1, 6 11690 DO mc = 1, 1 11691 DO mb = 1, 1 11692 ks_bd = 0.0_dp 11693 ks_bc = 0.0_dp 11694 p_bd = pbd((md - 1)*1 + mb) 11695 p_bc = pbc((mc - 1)*1 + mb) 11696 DO ma = 1, 2 11697 p_index = p_index + 1 11698 tmp = scale*prim(p_index) 11699 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11700 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11701 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11702 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11703 END DO 11704 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11705 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11706 END DO 11707 END DO 11708 END DO 11709 END SUBROUTINE block_2_1_1_6 11710! ************************************************************************************************** 11711!> \brief ... 11712!> \param kbd ... 11713!> \param kbc ... 11714!> \param kad ... 11715!> \param kac ... 11716!> \param pbd ... 11717!> \param pbc ... 11718!> \param pad ... 11719!> \param pac ... 11720!> \param prim ... 11721!> \param scale ... 11722! ************************************************************************************************** 11723 SUBROUTINE block_2_1_1_7(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11724 REAL(KIND=dp) :: kbd(1*7), kbc(1*1), kad(2*7), kac(2*1), & 11725 pbd(1*7), pbc(1*1), pad(2*7), & 11726 pac(2*1), prim(2*1*1*7), scale 11727 11728 INTEGER :: ma, mb, mc, md, p_index 11729 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11730 11731 kbd(1:1*7) = 0.0_dp 11732 kbc(1:1*1) = 0.0_dp 11733 kad(1:2*7) = 0.0_dp 11734 kac(1:2*1) = 0.0_dp 11735 p_index = 0 11736 DO md = 1, 7 11737 DO mc = 1, 1 11738 DO mb = 1, 1 11739 ks_bd = 0.0_dp 11740 ks_bc = 0.0_dp 11741 p_bd = pbd((md - 1)*1 + mb) 11742 p_bc = pbc((mc - 1)*1 + mb) 11743 DO ma = 1, 2 11744 p_index = p_index + 1 11745 tmp = scale*prim(p_index) 11746 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11747 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11748 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11749 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11750 END DO 11751 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11752 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11753 END DO 11754 END DO 11755 END DO 11756 END SUBROUTINE block_2_1_1_7 11757! ************************************************************************************************** 11758!> \brief ... 11759!> \param kbd ... 11760!> \param kbc ... 11761!> \param kad ... 11762!> \param kac ... 11763!> \param pbd ... 11764!> \param pbc ... 11765!> \param pad ... 11766!> \param pac ... 11767!> \param prim ... 11768!> \param scale ... 11769! ************************************************************************************************** 11770 SUBROUTINE block_2_1_1_9(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11771 REAL(KIND=dp) :: kbd(1*9), kbc(1*1), kad(2*9), kac(2*1), & 11772 pbd(1*9), pbc(1*1), pad(2*9), & 11773 pac(2*1), prim(2*1*1*9), scale 11774 11775 INTEGER :: ma, mb, mc, md, p_index 11776 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11777 11778 kbd(1:1*9) = 0.0_dp 11779 kbc(1:1*1) = 0.0_dp 11780 kad(1:2*9) = 0.0_dp 11781 kac(1:2*1) = 0.0_dp 11782 p_index = 0 11783 DO md = 1, 9 11784 DO mc = 1, 1 11785 DO mb = 1, 1 11786 ks_bd = 0.0_dp 11787 ks_bc = 0.0_dp 11788 p_bd = pbd((md - 1)*1 + mb) 11789 p_bc = pbc((mc - 1)*1 + mb) 11790 DO ma = 1, 2 11791 p_index = p_index + 1 11792 tmp = scale*prim(p_index) 11793 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11794 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11795 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11796 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11797 END DO 11798 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11799 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11800 END DO 11801 END DO 11802 END DO 11803 END SUBROUTINE block_2_1_1_9 11804! ************************************************************************************************** 11805!> \brief ... 11806!> \param md_max ... 11807!> \param kbd ... 11808!> \param kbc ... 11809!> \param kad ... 11810!> \param kac ... 11811!> \param pbd ... 11812!> \param pbc ... 11813!> \param pad ... 11814!> \param pac ... 11815!> \param prim ... 11816!> \param scale ... 11817! ************************************************************************************************** 11818 SUBROUTINE block_2_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11819 INTEGER :: md_max 11820 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(2*md_max), kac(2*1), pbd(1*md_max), pbc(1*1), & 11821 pad(2*md_max), pac(2*1), prim(2*1*1*md_max), scale 11822 11823 INTEGER :: ma, mb, mc, md, p_index 11824 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11825 11826 kbd(1:1*md_max) = 0.0_dp 11827 kbc(1:1*1) = 0.0_dp 11828 kad(1:2*md_max) = 0.0_dp 11829 kac(1:2*1) = 0.0_dp 11830 p_index = 0 11831 DO md = 1, md_max 11832 DO mc = 1, 1 11833 DO mb = 1, 1 11834 ks_bd = 0.0_dp 11835 ks_bc = 0.0_dp 11836 p_bd = pbd((md - 1)*1 + mb) 11837 p_bc = pbc((mc - 1)*1 + mb) 11838 DO ma = 1, 2 11839 p_index = p_index + 1 11840 tmp = scale*prim(p_index) 11841 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11842 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11843 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11844 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11845 END DO 11846 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11847 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11848 END DO 11849 END DO 11850 END DO 11851 END SUBROUTINE block_2_1_1 11852! ************************************************************************************************** 11853!> \brief ... 11854!> \param kbd ... 11855!> \param kbc ... 11856!> \param kad ... 11857!> \param kac ... 11858!> \param pbd ... 11859!> \param pbc ... 11860!> \param pad ... 11861!> \param pac ... 11862!> \param prim ... 11863!> \param scale ... 11864! ************************************************************************************************** 11865 SUBROUTINE block_2_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11866 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(2*1), kac(2*2), & 11867 pbd(1*1), pbc(1*2), pad(2*1), & 11868 pac(2*2), prim(2*1*2*1), scale 11869 11870 INTEGER :: ma, mb, mc, md, p_index 11871 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11872 11873 kbd(1:1*1) = 0.0_dp 11874 kbc(1:1*2) = 0.0_dp 11875 kad(1:2*1) = 0.0_dp 11876 kac(1:2*2) = 0.0_dp 11877 p_index = 0 11878 DO md = 1, 1 11879 DO mc = 1, 2 11880 DO mb = 1, 1 11881 ks_bd = 0.0_dp 11882 ks_bc = 0.0_dp 11883 p_bd = pbd((md - 1)*1 + mb) 11884 p_bc = pbc((mc - 1)*1 + mb) 11885 DO ma = 1, 2 11886 p_index = p_index + 1 11887 tmp = scale*prim(p_index) 11888 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11889 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11890 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11891 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11892 END DO 11893 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11894 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11895 END DO 11896 END DO 11897 END DO 11898 END SUBROUTINE block_2_1_2_1 11899! ************************************************************************************************** 11900!> \brief ... 11901!> \param kbd ... 11902!> \param kbc ... 11903!> \param kad ... 11904!> \param kac ... 11905!> \param pbd ... 11906!> \param pbc ... 11907!> \param pad ... 11908!> \param pac ... 11909!> \param prim ... 11910!> \param scale ... 11911! ************************************************************************************************** 11912 SUBROUTINE block_2_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11913 REAL(KIND=dp) :: kbd(1*2), kbc(1*2), kad(2*2), kac(2*2), & 11914 pbd(1*2), pbc(1*2), pad(2*2), & 11915 pac(2*2), prim(2*1*2*2), scale 11916 11917 INTEGER :: ma, mb, mc, md, p_index 11918 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11919 11920 kbd(1:1*2) = 0.0_dp 11921 kbc(1:1*2) = 0.0_dp 11922 kad(1:2*2) = 0.0_dp 11923 kac(1:2*2) = 0.0_dp 11924 p_index = 0 11925 DO md = 1, 2 11926 DO mc = 1, 2 11927 DO mb = 1, 1 11928 ks_bd = 0.0_dp 11929 ks_bc = 0.0_dp 11930 p_bd = pbd((md - 1)*1 + mb) 11931 p_bc = pbc((mc - 1)*1 + mb) 11932 DO ma = 1, 2 11933 p_index = p_index + 1 11934 tmp = scale*prim(p_index) 11935 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11936 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11937 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11938 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11939 END DO 11940 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11941 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11942 END DO 11943 END DO 11944 END DO 11945 END SUBROUTINE block_2_1_2_2 11946! ************************************************************************************************** 11947!> \brief ... 11948!> \param kbd ... 11949!> \param kbc ... 11950!> \param kad ... 11951!> \param kac ... 11952!> \param pbd ... 11953!> \param pbc ... 11954!> \param pad ... 11955!> \param pac ... 11956!> \param prim ... 11957!> \param scale ... 11958! ************************************************************************************************** 11959 SUBROUTINE block_2_1_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 11960 REAL(KIND=dp) :: kbd(1*3), kbc(1*2), kad(2*3), kac(2*2), & 11961 pbd(1*3), pbc(1*2), pad(2*3), & 11962 pac(2*2), prim(2*1*2*3), scale 11963 11964 INTEGER :: ma, mb, mc, md, p_index 11965 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 11966 11967 kbd(1:1*3) = 0.0_dp 11968 kbc(1:1*2) = 0.0_dp 11969 kad(1:2*3) = 0.0_dp 11970 kac(1:2*2) = 0.0_dp 11971 p_index = 0 11972 DO md = 1, 3 11973 DO mc = 1, 2 11974 DO mb = 1, 1 11975 ks_bd = 0.0_dp 11976 ks_bc = 0.0_dp 11977 p_bd = pbd((md - 1)*1 + mb) 11978 p_bc = pbc((mc - 1)*1 + mb) 11979 DO ma = 1, 2 11980 p_index = p_index + 1 11981 tmp = scale*prim(p_index) 11982 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 11983 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 11984 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 11985 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 11986 END DO 11987 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 11988 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 11989 END DO 11990 END DO 11991 END DO 11992 END SUBROUTINE block_2_1_2_3 11993! ************************************************************************************************** 11994!> \brief ... 11995!> \param kbd ... 11996!> \param kbc ... 11997!> \param kad ... 11998!> \param kac ... 11999!> \param pbd ... 12000!> \param pbc ... 12001!> \param pad ... 12002!> \param pac ... 12003!> \param prim ... 12004!> \param scale ... 12005! ************************************************************************************************** 12006 SUBROUTINE block_2_1_2_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12007 REAL(KIND=dp) :: kbd(1*4), kbc(1*2), kad(2*4), kac(2*2), & 12008 pbd(1*4), pbc(1*2), pad(2*4), & 12009 pac(2*2), prim(2*1*2*4), scale 12010 12011 INTEGER :: ma, mb, mc, md, p_index 12012 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12013 12014 kbd(1:1*4) = 0.0_dp 12015 kbc(1:1*2) = 0.0_dp 12016 kad(1:2*4) = 0.0_dp 12017 kac(1:2*2) = 0.0_dp 12018 p_index = 0 12019 DO md = 1, 4 12020 DO mc = 1, 2 12021 DO mb = 1, 1 12022 ks_bd = 0.0_dp 12023 ks_bc = 0.0_dp 12024 p_bd = pbd((md - 1)*1 + mb) 12025 p_bc = pbc((mc - 1)*1 + mb) 12026 DO ma = 1, 2 12027 p_index = p_index + 1 12028 tmp = scale*prim(p_index) 12029 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12030 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12031 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12032 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12033 END DO 12034 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12035 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12036 END DO 12037 END DO 12038 END DO 12039 END SUBROUTINE block_2_1_2_4 12040! ************************************************************************************************** 12041!> \brief ... 12042!> \param md_max ... 12043!> \param kbd ... 12044!> \param kbc ... 12045!> \param kad ... 12046!> \param kac ... 12047!> \param pbd ... 12048!> \param pbc ... 12049!> \param pad ... 12050!> \param pac ... 12051!> \param prim ... 12052!> \param scale ... 12053! ************************************************************************************************** 12054 SUBROUTINE block_2_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12055 INTEGER :: md_max 12056 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(2*md_max), kac(2*2), pbd(1*md_max), pbc(1*2), & 12057 pad(2*md_max), pac(2*2), prim(2*1*2*md_max), scale 12058 12059 INTEGER :: ma, mb, mc, md, p_index 12060 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12061 12062 kbd(1:1*md_max) = 0.0_dp 12063 kbc(1:1*2) = 0.0_dp 12064 kad(1:2*md_max) = 0.0_dp 12065 kac(1:2*2) = 0.0_dp 12066 p_index = 0 12067 DO md = 1, md_max 12068 DO mc = 1, 2 12069 DO mb = 1, 1 12070 ks_bd = 0.0_dp 12071 ks_bc = 0.0_dp 12072 p_bd = pbd((md - 1)*1 + mb) 12073 p_bc = pbc((mc - 1)*1 + mb) 12074 DO ma = 1, 2 12075 p_index = p_index + 1 12076 tmp = scale*prim(p_index) 12077 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12078 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12079 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12080 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12081 END DO 12082 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12083 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12084 END DO 12085 END DO 12086 END DO 12087 END SUBROUTINE block_2_1_2 12088! ************************************************************************************************** 12089!> \brief ... 12090!> \param kbd ... 12091!> \param kbc ... 12092!> \param kad ... 12093!> \param kac ... 12094!> \param pbd ... 12095!> \param pbc ... 12096!> \param pad ... 12097!> \param pac ... 12098!> \param prim ... 12099!> \param scale ... 12100! ************************************************************************************************** 12101 SUBROUTINE block_2_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12102 REAL(KIND=dp) :: kbd(1*1), kbc(1*3), kad(2*1), kac(2*3), & 12103 pbd(1*1), pbc(1*3), pad(2*1), & 12104 pac(2*3), prim(2*1*3*1), scale 12105 12106 INTEGER :: ma, mb, mc, md, p_index 12107 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12108 12109 kbd(1:1*1) = 0.0_dp 12110 kbc(1:1*3) = 0.0_dp 12111 kad(1:2*1) = 0.0_dp 12112 kac(1:2*3) = 0.0_dp 12113 p_index = 0 12114 DO md = 1, 1 12115 DO mc = 1, 3 12116 DO mb = 1, 1 12117 ks_bd = 0.0_dp 12118 ks_bc = 0.0_dp 12119 p_bd = pbd((md - 1)*1 + mb) 12120 p_bc = pbc((mc - 1)*1 + mb) 12121 DO ma = 1, 2 12122 p_index = p_index + 1 12123 tmp = scale*prim(p_index) 12124 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12125 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12126 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12127 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12128 END DO 12129 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12130 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12131 END DO 12132 END DO 12133 END DO 12134 END SUBROUTINE block_2_1_3_1 12135! ************************************************************************************************** 12136!> \brief ... 12137!> \param kbd ... 12138!> \param kbc ... 12139!> \param kad ... 12140!> \param kac ... 12141!> \param pbd ... 12142!> \param pbc ... 12143!> \param pad ... 12144!> \param pac ... 12145!> \param prim ... 12146!> \param scale ... 12147! ************************************************************************************************** 12148 SUBROUTINE block_2_1_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12149 REAL(KIND=dp) :: kbd(1*2), kbc(1*3), kad(2*2), kac(2*3), & 12150 pbd(1*2), pbc(1*3), pad(2*2), & 12151 pac(2*3), prim(2*1*3*2), scale 12152 12153 INTEGER :: ma, mb, mc, md, p_index 12154 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12155 12156 kbd(1:1*2) = 0.0_dp 12157 kbc(1:1*3) = 0.0_dp 12158 kad(1:2*2) = 0.0_dp 12159 kac(1:2*3) = 0.0_dp 12160 p_index = 0 12161 DO md = 1, 2 12162 DO mc = 1, 3 12163 DO mb = 1, 1 12164 ks_bd = 0.0_dp 12165 ks_bc = 0.0_dp 12166 p_bd = pbd((md - 1)*1 + mb) 12167 p_bc = pbc((mc - 1)*1 + mb) 12168 DO ma = 1, 2 12169 p_index = p_index + 1 12170 tmp = scale*prim(p_index) 12171 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12172 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12173 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12174 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12175 END DO 12176 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12177 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12178 END DO 12179 END DO 12180 END DO 12181 END SUBROUTINE block_2_1_3_2 12182! ************************************************************************************************** 12183!> \brief ... 12184!> \param kbd ... 12185!> \param kbc ... 12186!> \param kad ... 12187!> \param kac ... 12188!> \param pbd ... 12189!> \param pbc ... 12190!> \param pad ... 12191!> \param pac ... 12192!> \param prim ... 12193!> \param scale ... 12194! ************************************************************************************************** 12195 SUBROUTINE block_2_1_3_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12196 REAL(KIND=dp) :: kbd(1*3), kbc(1*3), kad(2*3), kac(2*3), & 12197 pbd(1*3), pbc(1*3), pad(2*3), & 12198 pac(2*3), prim(2*1*3*3), scale 12199 12200 INTEGER :: ma, mb, mc, md, p_index 12201 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12202 12203 kbd(1:1*3) = 0.0_dp 12204 kbc(1:1*3) = 0.0_dp 12205 kad(1:2*3) = 0.0_dp 12206 kac(1:2*3) = 0.0_dp 12207 p_index = 0 12208 DO md = 1, 3 12209 DO mc = 1, 3 12210 DO mb = 1, 1 12211 ks_bd = 0.0_dp 12212 ks_bc = 0.0_dp 12213 p_bd = pbd((md - 1)*1 + mb) 12214 p_bc = pbc((mc - 1)*1 + mb) 12215 DO ma = 1, 2 12216 p_index = p_index + 1 12217 tmp = scale*prim(p_index) 12218 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12219 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12220 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12221 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12222 END DO 12223 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12224 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12225 END DO 12226 END DO 12227 END DO 12228 END SUBROUTINE block_2_1_3_3 12229! ************************************************************************************************** 12230!> \brief ... 12231!> \param md_max ... 12232!> \param kbd ... 12233!> \param kbc ... 12234!> \param kad ... 12235!> \param kac ... 12236!> \param pbd ... 12237!> \param pbc ... 12238!> \param pad ... 12239!> \param pac ... 12240!> \param prim ... 12241!> \param scale ... 12242! ************************************************************************************************** 12243 SUBROUTINE block_2_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12244 INTEGER :: md_max 12245 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*3), kad(2*md_max), kac(2*3), pbd(1*md_max), pbc(1*3), & 12246 pad(2*md_max), pac(2*3), prim(2*1*3*md_max), scale 12247 12248 INTEGER :: ma, mb, mc, md, p_index 12249 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12250 12251 kbd(1:1*md_max) = 0.0_dp 12252 kbc(1:1*3) = 0.0_dp 12253 kad(1:2*md_max) = 0.0_dp 12254 kac(1:2*3) = 0.0_dp 12255 p_index = 0 12256 DO md = 1, md_max 12257 DO mc = 1, 3 12258 DO mb = 1, 1 12259 ks_bd = 0.0_dp 12260 ks_bc = 0.0_dp 12261 p_bd = pbd((md - 1)*1 + mb) 12262 p_bc = pbc((mc - 1)*1 + mb) 12263 DO ma = 1, 2 12264 p_index = p_index + 1 12265 tmp = scale*prim(p_index) 12266 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12267 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12268 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12269 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12270 END DO 12271 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12272 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12273 END DO 12274 END DO 12275 END DO 12276 END SUBROUTINE block_2_1_3 12277! ************************************************************************************************** 12278!> \brief ... 12279!> \param kbd ... 12280!> \param kbc ... 12281!> \param kad ... 12282!> \param kac ... 12283!> \param pbd ... 12284!> \param pbc ... 12285!> \param pad ... 12286!> \param pac ... 12287!> \param prim ... 12288!> \param scale ... 12289! ************************************************************************************************** 12290 SUBROUTINE block_2_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12291 REAL(KIND=dp) :: kbd(1*1), kbc(1*4), kad(2*1), kac(2*4), & 12292 pbd(1*1), pbc(1*4), pad(2*1), & 12293 pac(2*4), prim(2*1*4*1), scale 12294 12295 INTEGER :: ma, mb, mc, md, p_index 12296 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12297 12298 kbd(1:1*1) = 0.0_dp 12299 kbc(1:1*4) = 0.0_dp 12300 kad(1:2*1) = 0.0_dp 12301 kac(1:2*4) = 0.0_dp 12302 p_index = 0 12303 DO md = 1, 1 12304 DO mc = 1, 4 12305 DO mb = 1, 1 12306 ks_bd = 0.0_dp 12307 ks_bc = 0.0_dp 12308 p_bd = pbd((md - 1)*1 + mb) 12309 p_bc = pbc((mc - 1)*1 + mb) 12310 DO ma = 1, 2 12311 p_index = p_index + 1 12312 tmp = scale*prim(p_index) 12313 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12314 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12315 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12316 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12317 END DO 12318 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12319 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12320 END DO 12321 END DO 12322 END DO 12323 END SUBROUTINE block_2_1_4_1 12324! ************************************************************************************************** 12325!> \brief ... 12326!> \param kbd ... 12327!> \param kbc ... 12328!> \param kad ... 12329!> \param kac ... 12330!> \param pbd ... 12331!> \param pbc ... 12332!> \param pad ... 12333!> \param pac ... 12334!> \param prim ... 12335!> \param scale ... 12336! ************************************************************************************************** 12337 SUBROUTINE block_2_1_4_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12338 REAL(KIND=dp) :: kbd(1*2), kbc(1*4), kad(2*2), kac(2*4), & 12339 pbd(1*2), pbc(1*4), pad(2*2), & 12340 pac(2*4), prim(2*1*4*2), scale 12341 12342 INTEGER :: ma, mb, mc, md, p_index 12343 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12344 12345 kbd(1:1*2) = 0.0_dp 12346 kbc(1:1*4) = 0.0_dp 12347 kad(1:2*2) = 0.0_dp 12348 kac(1:2*4) = 0.0_dp 12349 p_index = 0 12350 DO md = 1, 2 12351 DO mc = 1, 4 12352 DO mb = 1, 1 12353 ks_bd = 0.0_dp 12354 ks_bc = 0.0_dp 12355 p_bd = pbd((md - 1)*1 + mb) 12356 p_bc = pbc((mc - 1)*1 + mb) 12357 DO ma = 1, 2 12358 p_index = p_index + 1 12359 tmp = scale*prim(p_index) 12360 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12361 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12362 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12363 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12364 END DO 12365 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12366 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12367 END DO 12368 END DO 12369 END DO 12370 END SUBROUTINE block_2_1_4_2 12371! ************************************************************************************************** 12372!> \brief ... 12373!> \param md_max ... 12374!> \param kbd ... 12375!> \param kbc ... 12376!> \param kad ... 12377!> \param kac ... 12378!> \param pbd ... 12379!> \param pbc ... 12380!> \param pad ... 12381!> \param pac ... 12382!> \param prim ... 12383!> \param scale ... 12384! ************************************************************************************************** 12385 SUBROUTINE block_2_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12386 INTEGER :: md_max 12387 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*4), kad(2*md_max), kac(2*4), pbd(1*md_max), pbc(1*4), & 12388 pad(2*md_max), pac(2*4), prim(2*1*4*md_max), scale 12389 12390 INTEGER :: ma, mb, mc, md, p_index 12391 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12392 12393 kbd(1:1*md_max) = 0.0_dp 12394 kbc(1:1*4) = 0.0_dp 12395 kad(1:2*md_max) = 0.0_dp 12396 kac(1:2*4) = 0.0_dp 12397 p_index = 0 12398 DO md = 1, md_max 12399 DO mc = 1, 4 12400 DO mb = 1, 1 12401 ks_bd = 0.0_dp 12402 ks_bc = 0.0_dp 12403 p_bd = pbd((md - 1)*1 + mb) 12404 p_bc = pbc((mc - 1)*1 + mb) 12405 DO ma = 1, 2 12406 p_index = p_index + 1 12407 tmp = scale*prim(p_index) 12408 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12409 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12410 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12411 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12412 END DO 12413 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12414 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12415 END DO 12416 END DO 12417 END DO 12418 END SUBROUTINE block_2_1_4 12419! ************************************************************************************************** 12420!> \brief ... 12421!> \param kbd ... 12422!> \param kbc ... 12423!> \param kad ... 12424!> \param kac ... 12425!> \param pbd ... 12426!> \param pbc ... 12427!> \param pad ... 12428!> \param pac ... 12429!> \param prim ... 12430!> \param scale ... 12431! ************************************************************************************************** 12432 SUBROUTINE block_2_1_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12433 REAL(KIND=dp) :: kbd(1*1), kbc(1*5), kad(2*1), kac(2*5), & 12434 pbd(1*1), pbc(1*5), pad(2*1), & 12435 pac(2*5), prim(2*1*5*1), scale 12436 12437 INTEGER :: ma, mb, mc, md, p_index 12438 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12439 12440 kbd(1:1*1) = 0.0_dp 12441 kbc(1:1*5) = 0.0_dp 12442 kad(1:2*1) = 0.0_dp 12443 kac(1:2*5) = 0.0_dp 12444 p_index = 0 12445 DO md = 1, 1 12446 DO mc = 1, 5 12447 DO mb = 1, 1 12448 ks_bd = 0.0_dp 12449 ks_bc = 0.0_dp 12450 p_bd = pbd((md - 1)*1 + mb) 12451 p_bc = pbc((mc - 1)*1 + mb) 12452 DO ma = 1, 2 12453 p_index = p_index + 1 12454 tmp = scale*prim(p_index) 12455 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12456 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12457 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12458 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12459 END DO 12460 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12461 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12462 END DO 12463 END DO 12464 END DO 12465 END SUBROUTINE block_2_1_5_1 12466! ************************************************************************************************** 12467!> \brief ... 12468!> \param md_max ... 12469!> \param kbd ... 12470!> \param kbc ... 12471!> \param kad ... 12472!> \param kac ... 12473!> \param pbd ... 12474!> \param pbc ... 12475!> \param pad ... 12476!> \param pac ... 12477!> \param prim ... 12478!> \param scale ... 12479! ************************************************************************************************** 12480 SUBROUTINE block_2_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12481 INTEGER :: md_max 12482 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*5), kad(2*md_max), kac(2*5), pbd(1*md_max), pbc(1*5), & 12483 pad(2*md_max), pac(2*5), prim(2*1*5*md_max), scale 12484 12485 INTEGER :: ma, mb, mc, md, p_index 12486 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12487 12488 kbd(1:1*md_max) = 0.0_dp 12489 kbc(1:1*5) = 0.0_dp 12490 kad(1:2*md_max) = 0.0_dp 12491 kac(1:2*5) = 0.0_dp 12492 p_index = 0 12493 DO md = 1, md_max 12494 DO mc = 1, 5 12495 DO mb = 1, 1 12496 ks_bd = 0.0_dp 12497 ks_bc = 0.0_dp 12498 p_bd = pbd((md - 1)*1 + mb) 12499 p_bc = pbc((mc - 1)*1 + mb) 12500 DO ma = 1, 2 12501 p_index = p_index + 1 12502 tmp = scale*prim(p_index) 12503 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12504 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12505 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12506 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12507 END DO 12508 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12509 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12510 END DO 12511 END DO 12512 END DO 12513 END SUBROUTINE block_2_1_5 12514! ************************************************************************************************** 12515!> \brief ... 12516!> \param kbd ... 12517!> \param kbc ... 12518!> \param kad ... 12519!> \param kac ... 12520!> \param pbd ... 12521!> \param pbc ... 12522!> \param pad ... 12523!> \param pac ... 12524!> \param prim ... 12525!> \param scale ... 12526! ************************************************************************************************** 12527 SUBROUTINE block_2_1_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12528 REAL(KIND=dp) :: kbd(1*1), kbc(1*6), kad(2*1), kac(2*6), & 12529 pbd(1*1), pbc(1*6), pad(2*1), & 12530 pac(2*6), prim(2*1*6*1), scale 12531 12532 INTEGER :: ma, mb, mc, md, p_index 12533 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12534 12535 kbd(1:1*1) = 0.0_dp 12536 kbc(1:1*6) = 0.0_dp 12537 kad(1:2*1) = 0.0_dp 12538 kac(1:2*6) = 0.0_dp 12539 p_index = 0 12540 DO md = 1, 1 12541 DO mc = 1, 6 12542 DO mb = 1, 1 12543 ks_bd = 0.0_dp 12544 ks_bc = 0.0_dp 12545 p_bd = pbd((md - 1)*1 + mb) 12546 p_bc = pbc((mc - 1)*1 + mb) 12547 DO ma = 1, 2 12548 p_index = p_index + 1 12549 tmp = scale*prim(p_index) 12550 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12551 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12552 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12553 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12554 END DO 12555 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12556 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12557 END DO 12558 END DO 12559 END DO 12560 END SUBROUTINE block_2_1_6_1 12561! ************************************************************************************************** 12562!> \brief ... 12563!> \param md_max ... 12564!> \param kbd ... 12565!> \param kbc ... 12566!> \param kad ... 12567!> \param kac ... 12568!> \param pbd ... 12569!> \param pbc ... 12570!> \param pad ... 12571!> \param pac ... 12572!> \param prim ... 12573!> \param scale ... 12574! ************************************************************************************************** 12575 SUBROUTINE block_2_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12576 INTEGER :: md_max 12577 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*6), kad(2*md_max), kac(2*6), pbd(1*md_max), pbc(1*6), & 12578 pad(2*md_max), pac(2*6), prim(2*1*6*md_max), scale 12579 12580 INTEGER :: ma, mb, mc, md, p_index 12581 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12582 12583 kbd(1:1*md_max) = 0.0_dp 12584 kbc(1:1*6) = 0.0_dp 12585 kad(1:2*md_max) = 0.0_dp 12586 kac(1:2*6) = 0.0_dp 12587 p_index = 0 12588 DO md = 1, md_max 12589 DO mc = 1, 6 12590 DO mb = 1, 1 12591 ks_bd = 0.0_dp 12592 ks_bc = 0.0_dp 12593 p_bd = pbd((md - 1)*1 + mb) 12594 p_bc = pbc((mc - 1)*1 + mb) 12595 DO ma = 1, 2 12596 p_index = p_index + 1 12597 tmp = scale*prim(p_index) 12598 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12599 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12600 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12601 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12602 END DO 12603 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12604 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12605 END DO 12606 END DO 12607 END DO 12608 END SUBROUTINE block_2_1_6 12609! ************************************************************************************************** 12610!> \brief ... 12611!> \param kbd ... 12612!> \param kbc ... 12613!> \param kad ... 12614!> \param kac ... 12615!> \param pbd ... 12616!> \param pbc ... 12617!> \param pad ... 12618!> \param pac ... 12619!> \param prim ... 12620!> \param scale ... 12621! ************************************************************************************************** 12622 SUBROUTINE block_2_1_7_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12623 REAL(KIND=dp) :: kbd(1*1), kbc(1*7), kad(2*1), kac(2*7), & 12624 pbd(1*1), pbc(1*7), pad(2*1), & 12625 pac(2*7), prim(2*1*7*1), scale 12626 12627 INTEGER :: ma, mb, mc, md, p_index 12628 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12629 12630 kbd(1:1*1) = 0.0_dp 12631 kbc(1:1*7) = 0.0_dp 12632 kad(1:2*1) = 0.0_dp 12633 kac(1:2*7) = 0.0_dp 12634 p_index = 0 12635 DO md = 1, 1 12636 DO mc = 1, 7 12637 DO mb = 1, 1 12638 ks_bd = 0.0_dp 12639 ks_bc = 0.0_dp 12640 p_bd = pbd((md - 1)*1 + mb) 12641 p_bc = pbc((mc - 1)*1 + mb) 12642 DO ma = 1, 2 12643 p_index = p_index + 1 12644 tmp = scale*prim(p_index) 12645 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12646 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12647 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12648 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12649 END DO 12650 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12651 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12652 END DO 12653 END DO 12654 END DO 12655 END SUBROUTINE block_2_1_7_1 12656! ************************************************************************************************** 12657!> \brief ... 12658!> \param md_max ... 12659!> \param kbd ... 12660!> \param kbc ... 12661!> \param kad ... 12662!> \param kac ... 12663!> \param pbd ... 12664!> \param pbc ... 12665!> \param pad ... 12666!> \param pac ... 12667!> \param prim ... 12668!> \param scale ... 12669! ************************************************************************************************** 12670 SUBROUTINE block_2_1_7(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12671 INTEGER :: md_max 12672 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*7), kad(2*md_max), kac(2*7), pbd(1*md_max), pbc(1*7), & 12673 pad(2*md_max), pac(2*7), prim(2*1*7*md_max), scale 12674 12675 INTEGER :: ma, mb, mc, md, p_index 12676 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12677 12678 kbd(1:1*md_max) = 0.0_dp 12679 kbc(1:1*7) = 0.0_dp 12680 kad(1:2*md_max) = 0.0_dp 12681 kac(1:2*7) = 0.0_dp 12682 p_index = 0 12683 DO md = 1, md_max 12684 DO mc = 1, 7 12685 DO mb = 1, 1 12686 ks_bd = 0.0_dp 12687 ks_bc = 0.0_dp 12688 p_bd = pbd((md - 1)*1 + mb) 12689 p_bc = pbc((mc - 1)*1 + mb) 12690 DO ma = 1, 2 12691 p_index = p_index + 1 12692 tmp = scale*prim(p_index) 12693 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12694 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12695 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12696 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12697 END DO 12698 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12699 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12700 END DO 12701 END DO 12702 END DO 12703 END SUBROUTINE block_2_1_7 12704! ************************************************************************************************** 12705!> \brief ... 12706!> \param kbd ... 12707!> \param kbc ... 12708!> \param kad ... 12709!> \param kac ... 12710!> \param pbd ... 12711!> \param pbc ... 12712!> \param pad ... 12713!> \param pac ... 12714!> \param prim ... 12715!> \param scale ... 12716! ************************************************************************************************** 12717 SUBROUTINE block_2_1_9_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12718 REAL(KIND=dp) :: kbd(1*1), kbc(1*9), kad(2*1), kac(2*9), & 12719 pbd(1*1), pbc(1*9), pad(2*1), & 12720 pac(2*9), prim(2*1*9*1), scale 12721 12722 INTEGER :: ma, mb, mc, md, p_index 12723 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12724 12725 kbd(1:1*1) = 0.0_dp 12726 kbc(1:1*9) = 0.0_dp 12727 kad(1:2*1) = 0.0_dp 12728 kac(1:2*9) = 0.0_dp 12729 p_index = 0 12730 DO md = 1, 1 12731 DO mc = 1, 9 12732 DO mb = 1, 1 12733 ks_bd = 0.0_dp 12734 ks_bc = 0.0_dp 12735 p_bd = pbd((md - 1)*1 + mb) 12736 p_bc = pbc((mc - 1)*1 + mb) 12737 DO ma = 1, 2 12738 p_index = p_index + 1 12739 tmp = scale*prim(p_index) 12740 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12741 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12742 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12743 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12744 END DO 12745 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12746 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12747 END DO 12748 END DO 12749 END DO 12750 END SUBROUTINE block_2_1_9_1 12751! ************************************************************************************************** 12752!> \brief ... 12753!> \param md_max ... 12754!> \param kbd ... 12755!> \param kbc ... 12756!> \param kad ... 12757!> \param kac ... 12758!> \param pbd ... 12759!> \param pbc ... 12760!> \param pad ... 12761!> \param pac ... 12762!> \param prim ... 12763!> \param scale ... 12764! ************************************************************************************************** 12765 SUBROUTINE block_2_1_9(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12766 INTEGER :: md_max 12767 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*9), kad(2*md_max), kac(2*9), pbd(1*md_max), pbc(1*9), & 12768 pad(2*md_max), pac(2*9), prim(2*1*9*md_max), scale 12769 12770 INTEGER :: ma, mb, mc, md, p_index 12771 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12772 12773 kbd(1:1*md_max) = 0.0_dp 12774 kbc(1:1*9) = 0.0_dp 12775 kad(1:2*md_max) = 0.0_dp 12776 kac(1:2*9) = 0.0_dp 12777 p_index = 0 12778 DO md = 1, md_max 12779 DO mc = 1, 9 12780 DO mb = 1, 1 12781 ks_bd = 0.0_dp 12782 ks_bc = 0.0_dp 12783 p_bd = pbd((md - 1)*1 + mb) 12784 p_bc = pbc((mc - 1)*1 + mb) 12785 DO ma = 1, 2 12786 p_index = p_index + 1 12787 tmp = scale*prim(p_index) 12788 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12789 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12790 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12791 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12792 END DO 12793 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12794 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12795 END DO 12796 END DO 12797 END DO 12798 END SUBROUTINE block_2_1_9 12799! ************************************************************************************************** 12800!> \brief ... 12801!> \param mc_max ... 12802!> \param md_max ... 12803!> \param kbd ... 12804!> \param kbc ... 12805!> \param kad ... 12806!> \param kac ... 12807!> \param pbd ... 12808!> \param pbc ... 12809!> \param pad ... 12810!> \param pac ... 12811!> \param prim ... 12812!> \param scale ... 12813! ************************************************************************************************** 12814 SUBROUTINE block_2_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12815 INTEGER :: mc_max, md_max 12816 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(2*md_max), kac(2*mc_max), pbd(1*md_max), & 12817 pbc(1*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*1*mc_max*md_max), scale 12818 12819 INTEGER :: ma, mb, mc, md, p_index 12820 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12821 12822 kbd(1:1*md_max) = 0.0_dp 12823 kbc(1:1*mc_max) = 0.0_dp 12824 kad(1:2*md_max) = 0.0_dp 12825 kac(1:2*mc_max) = 0.0_dp 12826 p_index = 0 12827 DO md = 1, md_max 12828 DO mc = 1, mc_max 12829 DO mb = 1, 1 12830 ks_bd = 0.0_dp 12831 ks_bc = 0.0_dp 12832 p_bd = pbd((md - 1)*1 + mb) 12833 p_bc = pbc((mc - 1)*1 + mb) 12834 DO ma = 1, 2 12835 p_index = p_index + 1 12836 tmp = scale*prim(p_index) 12837 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12838 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12839 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12840 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12841 END DO 12842 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 12843 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 12844 END DO 12845 END DO 12846 END DO 12847 END SUBROUTINE block_2_1 12848! ************************************************************************************************** 12849!> \brief ... 12850!> \param kbd ... 12851!> \param kbc ... 12852!> \param kad ... 12853!> \param kac ... 12854!> \param pbd ... 12855!> \param pbc ... 12856!> \param pad ... 12857!> \param pac ... 12858!> \param prim ... 12859!> \param scale ... 12860! ************************************************************************************************** 12861 SUBROUTINE block_2_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12862 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(2*1), kac(2*1), & 12863 pbd(2*1), pbc(2*1), pad(2*1), & 12864 pac(2*1), prim(2*2*1*1), scale 12865 12866 INTEGER :: ma, mb, mc, md, p_index 12867 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12868 12869 kbd(1:2*1) = 0.0_dp 12870 kbc(1:2*1) = 0.0_dp 12871 kad(1:2*1) = 0.0_dp 12872 kac(1:2*1) = 0.0_dp 12873 p_index = 0 12874 DO md = 1, 1 12875 DO mc = 1, 1 12876 DO mb = 1, 2 12877 ks_bd = 0.0_dp 12878 ks_bc = 0.0_dp 12879 p_bd = pbd((md - 1)*2 + mb) 12880 p_bc = pbc((mc - 1)*2 + mb) 12881 DO ma = 1, 2 12882 p_index = p_index + 1 12883 tmp = scale*prim(p_index) 12884 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12885 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12886 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12887 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12888 END DO 12889 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 12890 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 12891 END DO 12892 END DO 12893 END DO 12894 END SUBROUTINE block_2_2_1_1 12895! ************************************************************************************************** 12896!> \brief ... 12897!> \param kbd ... 12898!> \param kbc ... 12899!> \param kad ... 12900!> \param kac ... 12901!> \param pbd ... 12902!> \param pbc ... 12903!> \param pad ... 12904!> \param pac ... 12905!> \param prim ... 12906!> \param scale ... 12907! ************************************************************************************************** 12908 SUBROUTINE block_2_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12909 REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(2*2), kac(2*1), & 12910 pbd(2*2), pbc(2*1), pad(2*2), & 12911 pac(2*1), prim(2*2*1*2), scale 12912 12913 INTEGER :: ma, mb, mc, md, p_index 12914 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12915 12916 kbd(1:2*2) = 0.0_dp 12917 kbc(1:2*1) = 0.0_dp 12918 kad(1:2*2) = 0.0_dp 12919 kac(1:2*1) = 0.0_dp 12920 p_index = 0 12921 DO md = 1, 2 12922 DO mc = 1, 1 12923 DO mb = 1, 2 12924 ks_bd = 0.0_dp 12925 ks_bc = 0.0_dp 12926 p_bd = pbd((md - 1)*2 + mb) 12927 p_bc = pbc((mc - 1)*2 + mb) 12928 DO ma = 1, 2 12929 p_index = p_index + 1 12930 tmp = scale*prim(p_index) 12931 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12932 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12933 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12934 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12935 END DO 12936 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 12937 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 12938 END DO 12939 END DO 12940 END DO 12941 END SUBROUTINE block_2_2_1_2 12942! ************************************************************************************************** 12943!> \brief ... 12944!> \param kbd ... 12945!> \param kbc ... 12946!> \param kad ... 12947!> \param kac ... 12948!> \param pbd ... 12949!> \param pbc ... 12950!> \param pad ... 12951!> \param pac ... 12952!> \param prim ... 12953!> \param scale ... 12954! ************************************************************************************************** 12955 SUBROUTINE block_2_2_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 12956 REAL(KIND=dp) :: kbd(2*3), kbc(2*1), kad(2*3), kac(2*1), & 12957 pbd(2*3), pbc(2*1), pad(2*3), & 12958 pac(2*1), prim(2*2*1*3), scale 12959 12960 INTEGER :: ma, mb, mc, md, p_index 12961 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 12962 12963 kbd(1:2*3) = 0.0_dp 12964 kbc(1:2*1) = 0.0_dp 12965 kad(1:2*3) = 0.0_dp 12966 kac(1:2*1) = 0.0_dp 12967 p_index = 0 12968 DO md = 1, 3 12969 DO mc = 1, 1 12970 DO mb = 1, 2 12971 ks_bd = 0.0_dp 12972 ks_bc = 0.0_dp 12973 p_bd = pbd((md - 1)*2 + mb) 12974 p_bc = pbc((mc - 1)*2 + mb) 12975 DO ma = 1, 2 12976 p_index = p_index + 1 12977 tmp = scale*prim(p_index) 12978 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 12979 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 12980 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 12981 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 12982 END DO 12983 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 12984 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 12985 END DO 12986 END DO 12987 END DO 12988 END SUBROUTINE block_2_2_1_3 12989! ************************************************************************************************** 12990!> \brief ... 12991!> \param kbd ... 12992!> \param kbc ... 12993!> \param kad ... 12994!> \param kac ... 12995!> \param pbd ... 12996!> \param pbc ... 12997!> \param pad ... 12998!> \param pac ... 12999!> \param prim ... 13000!> \param scale ... 13001! ************************************************************************************************** 13002 SUBROUTINE block_2_2_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13003 REAL(KIND=dp) :: kbd(2*4), kbc(2*1), kad(2*4), kac(2*1), & 13004 pbd(2*4), pbc(2*1), pad(2*4), & 13005 pac(2*1), prim(2*2*1*4), scale 13006 13007 INTEGER :: ma, mb, mc, md, p_index 13008 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13009 13010 kbd(1:2*4) = 0.0_dp 13011 kbc(1:2*1) = 0.0_dp 13012 kad(1:2*4) = 0.0_dp 13013 kac(1:2*1) = 0.0_dp 13014 p_index = 0 13015 DO md = 1, 4 13016 DO mc = 1, 1 13017 DO mb = 1, 2 13018 ks_bd = 0.0_dp 13019 ks_bc = 0.0_dp 13020 p_bd = pbd((md - 1)*2 + mb) 13021 p_bc = pbc((mc - 1)*2 + mb) 13022 DO ma = 1, 2 13023 p_index = p_index + 1 13024 tmp = scale*prim(p_index) 13025 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13026 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13027 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13028 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13029 END DO 13030 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13031 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13032 END DO 13033 END DO 13034 END DO 13035 END SUBROUTINE block_2_2_1_4 13036! ************************************************************************************************** 13037!> \brief ... 13038!> \param md_max ... 13039!> \param kbd ... 13040!> \param kbc ... 13041!> \param kad ... 13042!> \param kac ... 13043!> \param pbd ... 13044!> \param pbc ... 13045!> \param pad ... 13046!> \param pac ... 13047!> \param prim ... 13048!> \param scale ... 13049! ************************************************************************************************** 13050 SUBROUTINE block_2_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13051 INTEGER :: md_max 13052 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(2*md_max), kac(2*1), pbd(2*md_max), pbc(2*1), & 13053 pad(2*md_max), pac(2*1), prim(2*2*1*md_max), scale 13054 13055 INTEGER :: ma, mb, mc, md, p_index 13056 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13057 13058 kbd(1:2*md_max) = 0.0_dp 13059 kbc(1:2*1) = 0.0_dp 13060 kad(1:2*md_max) = 0.0_dp 13061 kac(1:2*1) = 0.0_dp 13062 p_index = 0 13063 DO md = 1, md_max 13064 DO mc = 1, 1 13065 DO mb = 1, 2 13066 ks_bd = 0.0_dp 13067 ks_bc = 0.0_dp 13068 p_bd = pbd((md - 1)*2 + mb) 13069 p_bc = pbc((mc - 1)*2 + mb) 13070 DO ma = 1, 2 13071 p_index = p_index + 1 13072 tmp = scale*prim(p_index) 13073 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13074 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13075 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13076 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13077 END DO 13078 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13079 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13080 END DO 13081 END DO 13082 END DO 13083 END SUBROUTINE block_2_2_1 13084! ************************************************************************************************** 13085!> \brief ... 13086!> \param kbd ... 13087!> \param kbc ... 13088!> \param kad ... 13089!> \param kac ... 13090!> \param pbd ... 13091!> \param pbc ... 13092!> \param pad ... 13093!> \param pac ... 13094!> \param prim ... 13095!> \param scale ... 13096! ************************************************************************************************** 13097 SUBROUTINE block_2_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13098 REAL(KIND=dp) :: kbd(2*1), kbc(2*2), kad(2*1), kac(2*2), & 13099 pbd(2*1), pbc(2*2), pad(2*1), & 13100 pac(2*2), prim(2*2*2*1), scale 13101 13102 INTEGER :: ma, mb, mc, md, p_index 13103 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13104 13105 kbd(1:2*1) = 0.0_dp 13106 kbc(1:2*2) = 0.0_dp 13107 kad(1:2*1) = 0.0_dp 13108 kac(1:2*2) = 0.0_dp 13109 p_index = 0 13110 DO md = 1, 1 13111 DO mc = 1, 2 13112 DO mb = 1, 2 13113 ks_bd = 0.0_dp 13114 ks_bc = 0.0_dp 13115 p_bd = pbd((md - 1)*2 + mb) 13116 p_bc = pbc((mc - 1)*2 + mb) 13117 DO ma = 1, 2 13118 p_index = p_index + 1 13119 tmp = scale*prim(p_index) 13120 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13121 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13122 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13123 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13124 END DO 13125 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13126 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13127 END DO 13128 END DO 13129 END DO 13130 END SUBROUTINE block_2_2_2_1 13131! ************************************************************************************************** 13132!> \brief ... 13133!> \param kbd ... 13134!> \param kbc ... 13135!> \param kad ... 13136!> \param kac ... 13137!> \param pbd ... 13138!> \param pbc ... 13139!> \param pad ... 13140!> \param pac ... 13141!> \param prim ... 13142!> \param scale ... 13143! ************************************************************************************************** 13144 SUBROUTINE block_2_2_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13145 REAL(KIND=dp) :: kbd(2*2), kbc(2*2), kad(2*2), kac(2*2), & 13146 pbd(2*2), pbc(2*2), pad(2*2), & 13147 pac(2*2), prim(2*2*2*2), scale 13148 13149 INTEGER :: ma, mb, mc, md, p_index 13150 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13151 13152 kbd(1:2*2) = 0.0_dp 13153 kbc(1:2*2) = 0.0_dp 13154 kad(1:2*2) = 0.0_dp 13155 kac(1:2*2) = 0.0_dp 13156 p_index = 0 13157 DO md = 1, 2 13158 DO mc = 1, 2 13159 DO mb = 1, 2 13160 ks_bd = 0.0_dp 13161 ks_bc = 0.0_dp 13162 p_bd = pbd((md - 1)*2 + mb) 13163 p_bc = pbc((mc - 1)*2 + mb) 13164 DO ma = 1, 2 13165 p_index = p_index + 1 13166 tmp = scale*prim(p_index) 13167 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13168 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13169 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13170 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13171 END DO 13172 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13173 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13174 END DO 13175 END DO 13176 END DO 13177 END SUBROUTINE block_2_2_2_2 13178! ************************************************************************************************** 13179!> \brief ... 13180!> \param md_max ... 13181!> \param kbd ... 13182!> \param kbc ... 13183!> \param kad ... 13184!> \param kac ... 13185!> \param pbd ... 13186!> \param pbc ... 13187!> \param pad ... 13188!> \param pac ... 13189!> \param prim ... 13190!> \param scale ... 13191! ************************************************************************************************** 13192 SUBROUTINE block_2_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13193 INTEGER :: md_max 13194 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*2), kad(2*md_max), kac(2*2), pbd(2*md_max), pbc(2*2), & 13195 pad(2*md_max), pac(2*2), prim(2*2*2*md_max), scale 13196 13197 INTEGER :: ma, mb, mc, md, p_index 13198 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13199 13200 kbd(1:2*md_max) = 0.0_dp 13201 kbc(1:2*2) = 0.0_dp 13202 kad(1:2*md_max) = 0.0_dp 13203 kac(1:2*2) = 0.0_dp 13204 p_index = 0 13205 DO md = 1, md_max 13206 DO mc = 1, 2 13207 DO mb = 1, 2 13208 ks_bd = 0.0_dp 13209 ks_bc = 0.0_dp 13210 p_bd = pbd((md - 1)*2 + mb) 13211 p_bc = pbc((mc - 1)*2 + mb) 13212 DO ma = 1, 2 13213 p_index = p_index + 1 13214 tmp = scale*prim(p_index) 13215 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13216 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13217 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13218 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13219 END DO 13220 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13221 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13222 END DO 13223 END DO 13224 END DO 13225 END SUBROUTINE block_2_2_2 13226! ************************************************************************************************** 13227!> \brief ... 13228!> \param kbd ... 13229!> \param kbc ... 13230!> \param kad ... 13231!> \param kac ... 13232!> \param pbd ... 13233!> \param pbc ... 13234!> \param pad ... 13235!> \param pac ... 13236!> \param prim ... 13237!> \param scale ... 13238! ************************************************************************************************** 13239 SUBROUTINE block_2_2_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13240 REAL(KIND=dp) :: kbd(2*1), kbc(2*3), kad(2*1), kac(2*3), & 13241 pbd(2*1), pbc(2*3), pad(2*1), & 13242 pac(2*3), prim(2*2*3*1), scale 13243 13244 INTEGER :: ma, mb, mc, md, p_index 13245 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13246 13247 kbd(1:2*1) = 0.0_dp 13248 kbc(1:2*3) = 0.0_dp 13249 kad(1:2*1) = 0.0_dp 13250 kac(1:2*3) = 0.0_dp 13251 p_index = 0 13252 DO md = 1, 1 13253 DO mc = 1, 3 13254 DO mb = 1, 2 13255 ks_bd = 0.0_dp 13256 ks_bc = 0.0_dp 13257 p_bd = pbd((md - 1)*2 + mb) 13258 p_bc = pbc((mc - 1)*2 + mb) 13259 DO ma = 1, 2 13260 p_index = p_index + 1 13261 tmp = scale*prim(p_index) 13262 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13263 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13264 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13265 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13266 END DO 13267 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13268 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13269 END DO 13270 END DO 13271 END DO 13272 END SUBROUTINE block_2_2_3_1 13273! ************************************************************************************************** 13274!> \brief ... 13275!> \param md_max ... 13276!> \param kbd ... 13277!> \param kbc ... 13278!> \param kad ... 13279!> \param kac ... 13280!> \param pbd ... 13281!> \param pbc ... 13282!> \param pad ... 13283!> \param pac ... 13284!> \param prim ... 13285!> \param scale ... 13286! ************************************************************************************************** 13287 SUBROUTINE block_2_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13288 INTEGER :: md_max 13289 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*3), kad(2*md_max), kac(2*3), pbd(2*md_max), pbc(2*3), & 13290 pad(2*md_max), pac(2*3), prim(2*2*3*md_max), scale 13291 13292 INTEGER :: ma, mb, mc, md, p_index 13293 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13294 13295 kbd(1:2*md_max) = 0.0_dp 13296 kbc(1:2*3) = 0.0_dp 13297 kad(1:2*md_max) = 0.0_dp 13298 kac(1:2*3) = 0.0_dp 13299 p_index = 0 13300 DO md = 1, md_max 13301 DO mc = 1, 3 13302 DO mb = 1, 2 13303 ks_bd = 0.0_dp 13304 ks_bc = 0.0_dp 13305 p_bd = pbd((md - 1)*2 + mb) 13306 p_bc = pbc((mc - 1)*2 + mb) 13307 DO ma = 1, 2 13308 p_index = p_index + 1 13309 tmp = scale*prim(p_index) 13310 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13311 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13312 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13313 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13314 END DO 13315 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13316 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13317 END DO 13318 END DO 13319 END DO 13320 END SUBROUTINE block_2_2_3 13321! ************************************************************************************************** 13322!> \brief ... 13323!> \param kbd ... 13324!> \param kbc ... 13325!> \param kad ... 13326!> \param kac ... 13327!> \param pbd ... 13328!> \param pbc ... 13329!> \param pad ... 13330!> \param pac ... 13331!> \param prim ... 13332!> \param scale ... 13333! ************************************************************************************************** 13334 SUBROUTINE block_2_2_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13335 REAL(KIND=dp) :: kbd(2*1), kbc(2*4), kad(2*1), kac(2*4), & 13336 pbd(2*1), pbc(2*4), pad(2*1), & 13337 pac(2*4), prim(2*2*4*1), scale 13338 13339 INTEGER :: ma, mb, mc, md, p_index 13340 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13341 13342 kbd(1:2*1) = 0.0_dp 13343 kbc(1:2*4) = 0.0_dp 13344 kad(1:2*1) = 0.0_dp 13345 kac(1:2*4) = 0.0_dp 13346 p_index = 0 13347 DO md = 1, 1 13348 DO mc = 1, 4 13349 DO mb = 1, 2 13350 ks_bd = 0.0_dp 13351 ks_bc = 0.0_dp 13352 p_bd = pbd((md - 1)*2 + mb) 13353 p_bc = pbc((mc - 1)*2 + mb) 13354 DO ma = 1, 2 13355 p_index = p_index + 1 13356 tmp = scale*prim(p_index) 13357 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13358 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13359 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13360 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13361 END DO 13362 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13363 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13364 END DO 13365 END DO 13366 END DO 13367 END SUBROUTINE block_2_2_4_1 13368! ************************************************************************************************** 13369!> \brief ... 13370!> \param md_max ... 13371!> \param kbd ... 13372!> \param kbc ... 13373!> \param kad ... 13374!> \param kac ... 13375!> \param pbd ... 13376!> \param pbc ... 13377!> \param pad ... 13378!> \param pac ... 13379!> \param prim ... 13380!> \param scale ... 13381! ************************************************************************************************** 13382 SUBROUTINE block_2_2_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13383 INTEGER :: md_max 13384 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*4), kad(2*md_max), kac(2*4), pbd(2*md_max), pbc(2*4), & 13385 pad(2*md_max), pac(2*4), prim(2*2*4*md_max), scale 13386 13387 INTEGER :: ma, mb, mc, md, p_index 13388 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13389 13390 kbd(1:2*md_max) = 0.0_dp 13391 kbc(1:2*4) = 0.0_dp 13392 kad(1:2*md_max) = 0.0_dp 13393 kac(1:2*4) = 0.0_dp 13394 p_index = 0 13395 DO md = 1, md_max 13396 DO mc = 1, 4 13397 DO mb = 1, 2 13398 ks_bd = 0.0_dp 13399 ks_bc = 0.0_dp 13400 p_bd = pbd((md - 1)*2 + mb) 13401 p_bc = pbc((mc - 1)*2 + mb) 13402 DO ma = 1, 2 13403 p_index = p_index + 1 13404 tmp = scale*prim(p_index) 13405 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13406 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13407 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13408 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13409 END DO 13410 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13411 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13412 END DO 13413 END DO 13414 END DO 13415 END SUBROUTINE block_2_2_4 13416! ************************************************************************************************** 13417!> \brief ... 13418!> \param mc_max ... 13419!> \param md_max ... 13420!> \param kbd ... 13421!> \param kbc ... 13422!> \param kad ... 13423!> \param kac ... 13424!> \param pbd ... 13425!> \param pbc ... 13426!> \param pad ... 13427!> \param pac ... 13428!> \param prim ... 13429!> \param scale ... 13430! ************************************************************************************************** 13431 SUBROUTINE block_2_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13432 INTEGER :: mc_max, md_max 13433 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(2*md_max), kac(2*mc_max), pbd(2*md_max), & 13434 pbc(2*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*2*mc_max*md_max), scale 13435 13436 INTEGER :: ma, mb, mc, md, p_index 13437 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13438 13439 kbd(1:2*md_max) = 0.0_dp 13440 kbc(1:2*mc_max) = 0.0_dp 13441 kad(1:2*md_max) = 0.0_dp 13442 kac(1:2*mc_max) = 0.0_dp 13443 p_index = 0 13444 DO md = 1, md_max 13445 DO mc = 1, mc_max 13446 DO mb = 1, 2 13447 ks_bd = 0.0_dp 13448 ks_bc = 0.0_dp 13449 p_bd = pbd((md - 1)*2 + mb) 13450 p_bc = pbc((mc - 1)*2 + mb) 13451 DO ma = 1, 2 13452 p_index = p_index + 1 13453 tmp = scale*prim(p_index) 13454 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13455 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13456 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13457 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13458 END DO 13459 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 13460 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 13461 END DO 13462 END DO 13463 END DO 13464 END SUBROUTINE block_2_2 13465! ************************************************************************************************** 13466!> \brief ... 13467!> \param kbd ... 13468!> \param kbc ... 13469!> \param kad ... 13470!> \param kac ... 13471!> \param pbd ... 13472!> \param pbc ... 13473!> \param pad ... 13474!> \param pac ... 13475!> \param prim ... 13476!> \param scale ... 13477! ************************************************************************************************** 13478 SUBROUTINE block_2_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13479 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(2*1), kac(2*1), & 13480 pbd(3*1), pbc(3*1), pad(2*1), & 13481 pac(2*1), prim(2*3*1*1), scale 13482 13483 INTEGER :: ma, mb, mc, md, p_index 13484 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13485 13486 kbd(1:3*1) = 0.0_dp 13487 kbc(1:3*1) = 0.0_dp 13488 kad(1:2*1) = 0.0_dp 13489 kac(1:2*1) = 0.0_dp 13490 p_index = 0 13491 DO md = 1, 1 13492 DO mc = 1, 1 13493 DO mb = 1, 3 13494 ks_bd = 0.0_dp 13495 ks_bc = 0.0_dp 13496 p_bd = pbd((md - 1)*3 + mb) 13497 p_bc = pbc((mc - 1)*3 + mb) 13498 DO ma = 1, 2 13499 p_index = p_index + 1 13500 tmp = scale*prim(p_index) 13501 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13502 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13503 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13504 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13505 END DO 13506 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13507 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13508 END DO 13509 END DO 13510 END DO 13511 END SUBROUTINE block_2_3_1_1 13512! ************************************************************************************************** 13513!> \brief ... 13514!> \param kbd ... 13515!> \param kbc ... 13516!> \param kad ... 13517!> \param kac ... 13518!> \param pbd ... 13519!> \param pbc ... 13520!> \param pad ... 13521!> \param pac ... 13522!> \param prim ... 13523!> \param scale ... 13524! ************************************************************************************************** 13525 SUBROUTINE block_2_3_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13526 REAL(KIND=dp) :: kbd(3*2), kbc(3*1), kad(2*2), kac(2*1), & 13527 pbd(3*2), pbc(3*1), pad(2*2), & 13528 pac(2*1), prim(2*3*1*2), scale 13529 13530 INTEGER :: ma, mb, mc, md, p_index 13531 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13532 13533 kbd(1:3*2) = 0.0_dp 13534 kbc(1:3*1) = 0.0_dp 13535 kad(1:2*2) = 0.0_dp 13536 kac(1:2*1) = 0.0_dp 13537 p_index = 0 13538 DO md = 1, 2 13539 DO mc = 1, 1 13540 DO mb = 1, 3 13541 ks_bd = 0.0_dp 13542 ks_bc = 0.0_dp 13543 p_bd = pbd((md - 1)*3 + mb) 13544 p_bc = pbc((mc - 1)*3 + mb) 13545 DO ma = 1, 2 13546 p_index = p_index + 1 13547 tmp = scale*prim(p_index) 13548 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13549 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13550 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13551 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13552 END DO 13553 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13554 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13555 END DO 13556 END DO 13557 END DO 13558 END SUBROUTINE block_2_3_1_2 13559! ************************************************************************************************** 13560!> \brief ... 13561!> \param kbd ... 13562!> \param kbc ... 13563!> \param kad ... 13564!> \param kac ... 13565!> \param pbd ... 13566!> \param pbc ... 13567!> \param pad ... 13568!> \param pac ... 13569!> \param prim ... 13570!> \param scale ... 13571! ************************************************************************************************** 13572 SUBROUTINE block_2_3_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13573 REAL(KIND=dp) :: kbd(3*3), kbc(3*1), kad(2*3), kac(2*1), & 13574 pbd(3*3), pbc(3*1), pad(2*3), & 13575 pac(2*1), prim(2*3*1*3), scale 13576 13577 INTEGER :: ma, mb, mc, md, p_index 13578 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13579 13580 kbd(1:3*3) = 0.0_dp 13581 kbc(1:3*1) = 0.0_dp 13582 kad(1:2*3) = 0.0_dp 13583 kac(1:2*1) = 0.0_dp 13584 p_index = 0 13585 DO md = 1, 3 13586 DO mc = 1, 1 13587 DO mb = 1, 3 13588 ks_bd = 0.0_dp 13589 ks_bc = 0.0_dp 13590 p_bd = pbd((md - 1)*3 + mb) 13591 p_bc = pbc((mc - 1)*3 + mb) 13592 DO ma = 1, 2 13593 p_index = p_index + 1 13594 tmp = scale*prim(p_index) 13595 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13596 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13597 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13598 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13599 END DO 13600 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13601 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13602 END DO 13603 END DO 13604 END DO 13605 END SUBROUTINE block_2_3_1_3 13606! ************************************************************************************************** 13607!> \brief ... 13608!> \param md_max ... 13609!> \param kbd ... 13610!> \param kbc ... 13611!> \param kad ... 13612!> \param kac ... 13613!> \param pbd ... 13614!> \param pbc ... 13615!> \param pad ... 13616!> \param pac ... 13617!> \param prim ... 13618!> \param scale ... 13619! ************************************************************************************************** 13620 SUBROUTINE block_2_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13621 INTEGER :: md_max 13622 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(2*md_max), kac(2*1), pbd(3*md_max), pbc(3*1), & 13623 pad(2*md_max), pac(2*1), prim(2*3*1*md_max), scale 13624 13625 INTEGER :: ma, mb, mc, md, p_index 13626 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13627 13628 kbd(1:3*md_max) = 0.0_dp 13629 kbc(1:3*1) = 0.0_dp 13630 kad(1:2*md_max) = 0.0_dp 13631 kac(1:2*1) = 0.0_dp 13632 p_index = 0 13633 DO md = 1, md_max 13634 DO mc = 1, 1 13635 DO mb = 1, 3 13636 ks_bd = 0.0_dp 13637 ks_bc = 0.0_dp 13638 p_bd = pbd((md - 1)*3 + mb) 13639 p_bc = pbc((mc - 1)*3 + mb) 13640 DO ma = 1, 2 13641 p_index = p_index + 1 13642 tmp = scale*prim(p_index) 13643 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13644 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13645 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13646 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13647 END DO 13648 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13649 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13650 END DO 13651 END DO 13652 END DO 13653 END SUBROUTINE block_2_3_1 13654! ************************************************************************************************** 13655!> \brief ... 13656!> \param kbd ... 13657!> \param kbc ... 13658!> \param kad ... 13659!> \param kac ... 13660!> \param pbd ... 13661!> \param pbc ... 13662!> \param pad ... 13663!> \param pac ... 13664!> \param prim ... 13665!> \param scale ... 13666! ************************************************************************************************** 13667 SUBROUTINE block_2_3_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13668 REAL(KIND=dp) :: kbd(3*1), kbc(3*2), kad(2*1), kac(2*2), & 13669 pbd(3*1), pbc(3*2), pad(2*1), & 13670 pac(2*2), prim(2*3*2*1), scale 13671 13672 INTEGER :: ma, mb, mc, md, p_index 13673 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13674 13675 kbd(1:3*1) = 0.0_dp 13676 kbc(1:3*2) = 0.0_dp 13677 kad(1:2*1) = 0.0_dp 13678 kac(1:2*2) = 0.0_dp 13679 p_index = 0 13680 DO md = 1, 1 13681 DO mc = 1, 2 13682 DO mb = 1, 3 13683 ks_bd = 0.0_dp 13684 ks_bc = 0.0_dp 13685 p_bd = pbd((md - 1)*3 + mb) 13686 p_bc = pbc((mc - 1)*3 + mb) 13687 DO ma = 1, 2 13688 p_index = p_index + 1 13689 tmp = scale*prim(p_index) 13690 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13691 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13692 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13693 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13694 END DO 13695 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13696 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13697 END DO 13698 END DO 13699 END DO 13700 END SUBROUTINE block_2_3_2_1 13701! ************************************************************************************************** 13702!> \brief ... 13703!> \param md_max ... 13704!> \param kbd ... 13705!> \param kbc ... 13706!> \param kad ... 13707!> \param kac ... 13708!> \param pbd ... 13709!> \param pbc ... 13710!> \param pad ... 13711!> \param pac ... 13712!> \param prim ... 13713!> \param scale ... 13714! ************************************************************************************************** 13715 SUBROUTINE block_2_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13716 INTEGER :: md_max 13717 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*2), kad(2*md_max), kac(2*2), pbd(3*md_max), pbc(3*2), & 13718 pad(2*md_max), pac(2*2), prim(2*3*2*md_max), scale 13719 13720 INTEGER :: ma, mb, mc, md, p_index 13721 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13722 13723 kbd(1:3*md_max) = 0.0_dp 13724 kbc(1:3*2) = 0.0_dp 13725 kad(1:2*md_max) = 0.0_dp 13726 kac(1:2*2) = 0.0_dp 13727 p_index = 0 13728 DO md = 1, md_max 13729 DO mc = 1, 2 13730 DO mb = 1, 3 13731 ks_bd = 0.0_dp 13732 ks_bc = 0.0_dp 13733 p_bd = pbd((md - 1)*3 + mb) 13734 p_bc = pbc((mc - 1)*3 + mb) 13735 DO ma = 1, 2 13736 p_index = p_index + 1 13737 tmp = scale*prim(p_index) 13738 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13739 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13740 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13741 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13742 END DO 13743 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13744 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13745 END DO 13746 END DO 13747 END DO 13748 END SUBROUTINE block_2_3_2 13749! ************************************************************************************************** 13750!> \brief ... 13751!> \param kbd ... 13752!> \param kbc ... 13753!> \param kad ... 13754!> \param kac ... 13755!> \param pbd ... 13756!> \param pbc ... 13757!> \param pad ... 13758!> \param pac ... 13759!> \param prim ... 13760!> \param scale ... 13761! ************************************************************************************************** 13762 SUBROUTINE block_2_3_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13763 REAL(KIND=dp) :: kbd(3*1), kbc(3*3), kad(2*1), kac(2*3), & 13764 pbd(3*1), pbc(3*3), pad(2*1), & 13765 pac(2*3), prim(2*3*3*1), scale 13766 13767 INTEGER :: ma, mb, mc, md, p_index 13768 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13769 13770 kbd(1:3*1) = 0.0_dp 13771 kbc(1:3*3) = 0.0_dp 13772 kad(1:2*1) = 0.0_dp 13773 kac(1:2*3) = 0.0_dp 13774 p_index = 0 13775 DO md = 1, 1 13776 DO mc = 1, 3 13777 DO mb = 1, 3 13778 ks_bd = 0.0_dp 13779 ks_bc = 0.0_dp 13780 p_bd = pbd((md - 1)*3 + mb) 13781 p_bc = pbc((mc - 1)*3 + mb) 13782 DO ma = 1, 2 13783 p_index = p_index + 1 13784 tmp = scale*prim(p_index) 13785 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13786 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13787 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13788 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13789 END DO 13790 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13791 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13792 END DO 13793 END DO 13794 END DO 13795 END SUBROUTINE block_2_3_3_1 13796! ************************************************************************************************** 13797!> \brief ... 13798!> \param md_max ... 13799!> \param kbd ... 13800!> \param kbc ... 13801!> \param kad ... 13802!> \param kac ... 13803!> \param pbd ... 13804!> \param pbc ... 13805!> \param pad ... 13806!> \param pac ... 13807!> \param prim ... 13808!> \param scale ... 13809! ************************************************************************************************** 13810 SUBROUTINE block_2_3_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13811 INTEGER :: md_max 13812 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*3), kad(2*md_max), kac(2*3), pbd(3*md_max), pbc(3*3), & 13813 pad(2*md_max), pac(2*3), prim(2*3*3*md_max), scale 13814 13815 INTEGER :: ma, mb, mc, md, p_index 13816 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13817 13818 kbd(1:3*md_max) = 0.0_dp 13819 kbc(1:3*3) = 0.0_dp 13820 kad(1:2*md_max) = 0.0_dp 13821 kac(1:2*3) = 0.0_dp 13822 p_index = 0 13823 DO md = 1, md_max 13824 DO mc = 1, 3 13825 DO mb = 1, 3 13826 ks_bd = 0.0_dp 13827 ks_bc = 0.0_dp 13828 p_bd = pbd((md - 1)*3 + mb) 13829 p_bc = pbc((mc - 1)*3 + mb) 13830 DO ma = 1, 2 13831 p_index = p_index + 1 13832 tmp = scale*prim(p_index) 13833 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13834 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13835 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13836 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13837 END DO 13838 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13839 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13840 END DO 13841 END DO 13842 END DO 13843 END SUBROUTINE block_2_3_3 13844! ************************************************************************************************** 13845!> \brief ... 13846!> \param mc_max ... 13847!> \param md_max ... 13848!> \param kbd ... 13849!> \param kbc ... 13850!> \param kad ... 13851!> \param kac ... 13852!> \param pbd ... 13853!> \param pbc ... 13854!> \param pad ... 13855!> \param pac ... 13856!> \param prim ... 13857!> \param scale ... 13858! ************************************************************************************************** 13859 SUBROUTINE block_2_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13860 INTEGER :: mc_max, md_max 13861 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(2*md_max), kac(2*mc_max), pbd(3*md_max), & 13862 pbc(3*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*3*mc_max*md_max), scale 13863 13864 INTEGER :: ma, mb, mc, md, p_index 13865 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13866 13867 kbd(1:3*md_max) = 0.0_dp 13868 kbc(1:3*mc_max) = 0.0_dp 13869 kad(1:2*md_max) = 0.0_dp 13870 kac(1:2*mc_max) = 0.0_dp 13871 p_index = 0 13872 DO md = 1, md_max 13873 DO mc = 1, mc_max 13874 DO mb = 1, 3 13875 ks_bd = 0.0_dp 13876 ks_bc = 0.0_dp 13877 p_bd = pbd((md - 1)*3 + mb) 13878 p_bc = pbc((mc - 1)*3 + mb) 13879 DO ma = 1, 2 13880 p_index = p_index + 1 13881 tmp = scale*prim(p_index) 13882 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13883 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13884 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13885 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13886 END DO 13887 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 13888 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 13889 END DO 13890 END DO 13891 END DO 13892 END SUBROUTINE block_2_3 13893! ************************************************************************************************** 13894!> \brief ... 13895!> \param kbd ... 13896!> \param kbc ... 13897!> \param kad ... 13898!> \param kac ... 13899!> \param pbd ... 13900!> \param pbc ... 13901!> \param pad ... 13902!> \param pac ... 13903!> \param prim ... 13904!> \param scale ... 13905! ************************************************************************************************** 13906 SUBROUTINE block_2_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13907 REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(2*1), kac(2*1), & 13908 pbd(4*1), pbc(4*1), pad(2*1), & 13909 pac(2*1), prim(2*4*1*1), scale 13910 13911 INTEGER :: ma, mb, mc, md, p_index 13912 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13913 13914 kbd(1:4*1) = 0.0_dp 13915 kbc(1:4*1) = 0.0_dp 13916 kad(1:2*1) = 0.0_dp 13917 kac(1:2*1) = 0.0_dp 13918 p_index = 0 13919 DO md = 1, 1 13920 DO mc = 1, 1 13921 DO mb = 1, 4 13922 ks_bd = 0.0_dp 13923 ks_bc = 0.0_dp 13924 p_bd = pbd((md - 1)*4 + mb) 13925 p_bc = pbc((mc - 1)*4 + mb) 13926 DO ma = 1, 2 13927 p_index = p_index + 1 13928 tmp = scale*prim(p_index) 13929 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13930 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13931 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13932 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13933 END DO 13934 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 13935 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 13936 END DO 13937 END DO 13938 END DO 13939 END SUBROUTINE block_2_4_1_1 13940! ************************************************************************************************** 13941!> \brief ... 13942!> \param kbd ... 13943!> \param kbc ... 13944!> \param kad ... 13945!> \param kac ... 13946!> \param pbd ... 13947!> \param pbc ... 13948!> \param pad ... 13949!> \param pac ... 13950!> \param prim ... 13951!> \param scale ... 13952! ************************************************************************************************** 13953 SUBROUTINE block_2_4_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 13954 REAL(KIND=dp) :: kbd(4*2), kbc(4*1), kad(2*2), kac(2*1), & 13955 pbd(4*2), pbc(4*1), pad(2*2), & 13956 pac(2*1), prim(2*4*1*2), scale 13957 13958 INTEGER :: ma, mb, mc, md, p_index 13959 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 13960 13961 kbd(1:4*2) = 0.0_dp 13962 kbc(1:4*1) = 0.0_dp 13963 kad(1:2*2) = 0.0_dp 13964 kac(1:2*1) = 0.0_dp 13965 p_index = 0 13966 DO md = 1, 2 13967 DO mc = 1, 1 13968 DO mb = 1, 4 13969 ks_bd = 0.0_dp 13970 ks_bc = 0.0_dp 13971 p_bd = pbd((md - 1)*4 + mb) 13972 p_bc = pbc((mc - 1)*4 + mb) 13973 DO ma = 1, 2 13974 p_index = p_index + 1 13975 tmp = scale*prim(p_index) 13976 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 13977 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 13978 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 13979 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 13980 END DO 13981 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 13982 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 13983 END DO 13984 END DO 13985 END DO 13986 END SUBROUTINE block_2_4_1_2 13987! ************************************************************************************************** 13988!> \brief ... 13989!> \param md_max ... 13990!> \param kbd ... 13991!> \param kbc ... 13992!> \param kad ... 13993!> \param kac ... 13994!> \param pbd ... 13995!> \param pbc ... 13996!> \param pad ... 13997!> \param pac ... 13998!> \param prim ... 13999!> \param scale ... 14000! ************************************************************************************************** 14001 SUBROUTINE block_2_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14002 INTEGER :: md_max 14003 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*1), kad(2*md_max), kac(2*1), pbd(4*md_max), pbc(4*1), & 14004 pad(2*md_max), pac(2*1), prim(2*4*1*md_max), scale 14005 14006 INTEGER :: ma, mb, mc, md, p_index 14007 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14008 14009 kbd(1:4*md_max) = 0.0_dp 14010 kbc(1:4*1) = 0.0_dp 14011 kad(1:2*md_max) = 0.0_dp 14012 kac(1:2*1) = 0.0_dp 14013 p_index = 0 14014 DO md = 1, md_max 14015 DO mc = 1, 1 14016 DO mb = 1, 4 14017 ks_bd = 0.0_dp 14018 ks_bc = 0.0_dp 14019 p_bd = pbd((md - 1)*4 + mb) 14020 p_bc = pbc((mc - 1)*4 + mb) 14021 DO ma = 1, 2 14022 p_index = p_index + 1 14023 tmp = scale*prim(p_index) 14024 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14025 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14026 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14027 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14028 END DO 14029 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 14030 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 14031 END DO 14032 END DO 14033 END DO 14034 END SUBROUTINE block_2_4_1 14035! ************************************************************************************************** 14036!> \brief ... 14037!> \param kbd ... 14038!> \param kbc ... 14039!> \param kad ... 14040!> \param kac ... 14041!> \param pbd ... 14042!> \param pbc ... 14043!> \param pad ... 14044!> \param pac ... 14045!> \param prim ... 14046!> \param scale ... 14047! ************************************************************************************************** 14048 SUBROUTINE block_2_4_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14049 REAL(KIND=dp) :: kbd(4*1), kbc(4*2), kad(2*1), kac(2*2), & 14050 pbd(4*1), pbc(4*2), pad(2*1), & 14051 pac(2*2), prim(2*4*2*1), scale 14052 14053 INTEGER :: ma, mb, mc, md, p_index 14054 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14055 14056 kbd(1:4*1) = 0.0_dp 14057 kbc(1:4*2) = 0.0_dp 14058 kad(1:2*1) = 0.0_dp 14059 kac(1:2*2) = 0.0_dp 14060 p_index = 0 14061 DO md = 1, 1 14062 DO mc = 1, 2 14063 DO mb = 1, 4 14064 ks_bd = 0.0_dp 14065 ks_bc = 0.0_dp 14066 p_bd = pbd((md - 1)*4 + mb) 14067 p_bc = pbc((mc - 1)*4 + mb) 14068 DO ma = 1, 2 14069 p_index = p_index + 1 14070 tmp = scale*prim(p_index) 14071 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14072 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14073 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14074 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14075 END DO 14076 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 14077 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 14078 END DO 14079 END DO 14080 END DO 14081 END SUBROUTINE block_2_4_2_1 14082! ************************************************************************************************** 14083!> \brief ... 14084!> \param md_max ... 14085!> \param kbd ... 14086!> \param kbc ... 14087!> \param kad ... 14088!> \param kac ... 14089!> \param pbd ... 14090!> \param pbc ... 14091!> \param pad ... 14092!> \param pac ... 14093!> \param prim ... 14094!> \param scale ... 14095! ************************************************************************************************** 14096 SUBROUTINE block_2_4_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14097 INTEGER :: md_max 14098 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*2), kad(2*md_max), kac(2*2), pbd(4*md_max), pbc(4*2), & 14099 pad(2*md_max), pac(2*2), prim(2*4*2*md_max), scale 14100 14101 INTEGER :: ma, mb, mc, md, p_index 14102 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14103 14104 kbd(1:4*md_max) = 0.0_dp 14105 kbc(1:4*2) = 0.0_dp 14106 kad(1:2*md_max) = 0.0_dp 14107 kac(1:2*2) = 0.0_dp 14108 p_index = 0 14109 DO md = 1, md_max 14110 DO mc = 1, 2 14111 DO mb = 1, 4 14112 ks_bd = 0.0_dp 14113 ks_bc = 0.0_dp 14114 p_bd = pbd((md - 1)*4 + mb) 14115 p_bc = pbc((mc - 1)*4 + mb) 14116 DO ma = 1, 2 14117 p_index = p_index + 1 14118 tmp = scale*prim(p_index) 14119 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14120 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14121 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14122 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14123 END DO 14124 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 14125 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 14126 END DO 14127 END DO 14128 END DO 14129 END SUBROUTINE block_2_4_2 14130! ************************************************************************************************** 14131!> \brief ... 14132!> \param mc_max ... 14133!> \param md_max ... 14134!> \param kbd ... 14135!> \param kbc ... 14136!> \param kad ... 14137!> \param kac ... 14138!> \param pbd ... 14139!> \param pbc ... 14140!> \param pad ... 14141!> \param pac ... 14142!> \param prim ... 14143!> \param scale ... 14144! ************************************************************************************************** 14145 SUBROUTINE block_2_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14146 INTEGER :: mc_max, md_max 14147 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(2*md_max), kac(2*mc_max), pbd(4*md_max), & 14148 pbc(4*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*4*mc_max*md_max), scale 14149 14150 INTEGER :: ma, mb, mc, md, p_index 14151 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14152 14153 kbd(1:4*md_max) = 0.0_dp 14154 kbc(1:4*mc_max) = 0.0_dp 14155 kad(1:2*md_max) = 0.0_dp 14156 kac(1:2*mc_max) = 0.0_dp 14157 p_index = 0 14158 DO md = 1, md_max 14159 DO mc = 1, mc_max 14160 DO mb = 1, 4 14161 ks_bd = 0.0_dp 14162 ks_bc = 0.0_dp 14163 p_bd = pbd((md - 1)*4 + mb) 14164 p_bc = pbc((mc - 1)*4 + mb) 14165 DO ma = 1, 2 14166 p_index = p_index + 1 14167 tmp = scale*prim(p_index) 14168 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14169 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14170 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14171 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14172 END DO 14173 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 14174 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 14175 END DO 14176 END DO 14177 END DO 14178 END SUBROUTINE block_2_4 14179! ************************************************************************************************** 14180!> \brief ... 14181!> \param kbd ... 14182!> \param kbc ... 14183!> \param kad ... 14184!> \param kac ... 14185!> \param pbd ... 14186!> \param pbc ... 14187!> \param pad ... 14188!> \param pac ... 14189!> \param prim ... 14190!> \param scale ... 14191! ************************************************************************************************** 14192 SUBROUTINE block_2_5_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14193 REAL(KIND=dp) :: kbd(5*1), kbc(5*1), kad(2*1), kac(2*1), & 14194 pbd(5*1), pbc(5*1), pad(2*1), & 14195 pac(2*1), prim(2*5*1*1), scale 14196 14197 INTEGER :: ma, mb, mc, md, p_index 14198 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14199 14200 kbd(1:5*1) = 0.0_dp 14201 kbc(1:5*1) = 0.0_dp 14202 kad(1:2*1) = 0.0_dp 14203 kac(1:2*1) = 0.0_dp 14204 p_index = 0 14205 DO md = 1, 1 14206 DO mc = 1, 1 14207 DO mb = 1, 5 14208 ks_bd = 0.0_dp 14209 ks_bc = 0.0_dp 14210 p_bd = pbd((md - 1)*5 + mb) 14211 p_bc = pbc((mc - 1)*5 + mb) 14212 DO ma = 1, 2 14213 p_index = p_index + 1 14214 tmp = scale*prim(p_index) 14215 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14216 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14217 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14218 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14219 END DO 14220 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 14221 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 14222 END DO 14223 END DO 14224 END DO 14225 END SUBROUTINE block_2_5_1_1 14226! ************************************************************************************************** 14227!> \brief ... 14228!> \param md_max ... 14229!> \param kbd ... 14230!> \param kbc ... 14231!> \param kad ... 14232!> \param kac ... 14233!> \param pbd ... 14234!> \param pbc ... 14235!> \param pad ... 14236!> \param pac ... 14237!> \param prim ... 14238!> \param scale ... 14239! ************************************************************************************************** 14240 SUBROUTINE block_2_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14241 INTEGER :: md_max 14242 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(2*md_max), kac(2*1), pbd(5*md_max), pbc(5*1), & 14243 pad(2*md_max), pac(2*1), prim(2*5*1*md_max), scale 14244 14245 INTEGER :: ma, mb, mc, md, p_index 14246 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14247 14248 kbd(1:5*md_max) = 0.0_dp 14249 kbc(1:5*1) = 0.0_dp 14250 kad(1:2*md_max) = 0.0_dp 14251 kac(1:2*1) = 0.0_dp 14252 p_index = 0 14253 DO md = 1, md_max 14254 DO mc = 1, 1 14255 DO mb = 1, 5 14256 ks_bd = 0.0_dp 14257 ks_bc = 0.0_dp 14258 p_bd = pbd((md - 1)*5 + mb) 14259 p_bc = pbc((mc - 1)*5 + mb) 14260 DO ma = 1, 2 14261 p_index = p_index + 1 14262 tmp = scale*prim(p_index) 14263 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14264 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14265 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14266 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14267 END DO 14268 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 14269 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 14270 END DO 14271 END DO 14272 END DO 14273 END SUBROUTINE block_2_5_1 14274! ************************************************************************************************** 14275!> \brief ... 14276!> \param mc_max ... 14277!> \param md_max ... 14278!> \param kbd ... 14279!> \param kbc ... 14280!> \param kad ... 14281!> \param kac ... 14282!> \param pbd ... 14283!> \param pbc ... 14284!> \param pad ... 14285!> \param pac ... 14286!> \param prim ... 14287!> \param scale ... 14288! ************************************************************************************************** 14289 SUBROUTINE block_2_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14290 INTEGER :: mc_max, md_max 14291 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(2*md_max), kac(2*mc_max), pbd(5*md_max), & 14292 pbc(5*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*5*mc_max*md_max), scale 14293 14294 INTEGER :: ma, mb, mc, md, p_index 14295 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14296 14297 kbd(1:5*md_max) = 0.0_dp 14298 kbc(1:5*mc_max) = 0.0_dp 14299 kad(1:2*md_max) = 0.0_dp 14300 kac(1:2*mc_max) = 0.0_dp 14301 p_index = 0 14302 DO md = 1, md_max 14303 DO mc = 1, mc_max 14304 DO mb = 1, 5 14305 ks_bd = 0.0_dp 14306 ks_bc = 0.0_dp 14307 p_bd = pbd((md - 1)*5 + mb) 14308 p_bc = pbc((mc - 1)*5 + mb) 14309 DO ma = 1, 2 14310 p_index = p_index + 1 14311 tmp = scale*prim(p_index) 14312 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14313 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14314 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14315 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14316 END DO 14317 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 14318 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 14319 END DO 14320 END DO 14321 END DO 14322 END SUBROUTINE block_2_5 14323! ************************************************************************************************** 14324!> \brief ... 14325!> \param kbd ... 14326!> \param kbc ... 14327!> \param kad ... 14328!> \param kac ... 14329!> \param pbd ... 14330!> \param pbc ... 14331!> \param pad ... 14332!> \param pac ... 14333!> \param prim ... 14334!> \param scale ... 14335! ************************************************************************************************** 14336 SUBROUTINE block_2_6_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14337 REAL(KIND=dp) :: kbd(6*1), kbc(6*1), kad(2*1), kac(2*1), & 14338 pbd(6*1), pbc(6*1), pad(2*1), & 14339 pac(2*1), prim(2*6*1*1), scale 14340 14341 INTEGER :: ma, mb, mc, md, p_index 14342 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14343 14344 kbd(1:6*1) = 0.0_dp 14345 kbc(1:6*1) = 0.0_dp 14346 kad(1:2*1) = 0.0_dp 14347 kac(1:2*1) = 0.0_dp 14348 p_index = 0 14349 DO md = 1, 1 14350 DO mc = 1, 1 14351 DO mb = 1, 6 14352 ks_bd = 0.0_dp 14353 ks_bc = 0.0_dp 14354 p_bd = pbd((md - 1)*6 + mb) 14355 p_bc = pbc((mc - 1)*6 + mb) 14356 DO ma = 1, 2 14357 p_index = p_index + 1 14358 tmp = scale*prim(p_index) 14359 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14360 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14361 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14362 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14363 END DO 14364 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 14365 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 14366 END DO 14367 END DO 14368 END DO 14369 END SUBROUTINE block_2_6_1_1 14370! ************************************************************************************************** 14371!> \brief ... 14372!> \param md_max ... 14373!> \param kbd ... 14374!> \param kbc ... 14375!> \param kad ... 14376!> \param kac ... 14377!> \param pbd ... 14378!> \param pbc ... 14379!> \param pad ... 14380!> \param pac ... 14381!> \param prim ... 14382!> \param scale ... 14383! ************************************************************************************************** 14384 SUBROUTINE block_2_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14385 INTEGER :: md_max 14386 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*1), kad(2*md_max), kac(2*1), pbd(6*md_max), pbc(6*1), & 14387 pad(2*md_max), pac(2*1), prim(2*6*1*md_max), scale 14388 14389 INTEGER :: ma, mb, mc, md, p_index 14390 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14391 14392 kbd(1:6*md_max) = 0.0_dp 14393 kbc(1:6*1) = 0.0_dp 14394 kad(1:2*md_max) = 0.0_dp 14395 kac(1:2*1) = 0.0_dp 14396 p_index = 0 14397 DO md = 1, md_max 14398 DO mc = 1, 1 14399 DO mb = 1, 6 14400 ks_bd = 0.0_dp 14401 ks_bc = 0.0_dp 14402 p_bd = pbd((md - 1)*6 + mb) 14403 p_bc = pbc((mc - 1)*6 + mb) 14404 DO ma = 1, 2 14405 p_index = p_index + 1 14406 tmp = scale*prim(p_index) 14407 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14408 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14409 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14410 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14411 END DO 14412 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 14413 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 14414 END DO 14415 END DO 14416 END DO 14417 END SUBROUTINE block_2_6_1 14418! ************************************************************************************************** 14419!> \brief ... 14420!> \param mc_max ... 14421!> \param md_max ... 14422!> \param kbd ... 14423!> \param kbc ... 14424!> \param kad ... 14425!> \param kac ... 14426!> \param pbd ... 14427!> \param pbc ... 14428!> \param pad ... 14429!> \param pac ... 14430!> \param prim ... 14431!> \param scale ... 14432! ************************************************************************************************** 14433 SUBROUTINE block_2_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14434 INTEGER :: mc_max, md_max 14435 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(2*md_max), kac(2*mc_max), pbd(6*md_max), & 14436 pbc(6*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*6*mc_max*md_max), scale 14437 14438 INTEGER :: ma, mb, mc, md, p_index 14439 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14440 14441 kbd(1:6*md_max) = 0.0_dp 14442 kbc(1:6*mc_max) = 0.0_dp 14443 kad(1:2*md_max) = 0.0_dp 14444 kac(1:2*mc_max) = 0.0_dp 14445 p_index = 0 14446 DO md = 1, md_max 14447 DO mc = 1, mc_max 14448 DO mb = 1, 6 14449 ks_bd = 0.0_dp 14450 ks_bc = 0.0_dp 14451 p_bd = pbd((md - 1)*6 + mb) 14452 p_bc = pbc((mc - 1)*6 + mb) 14453 DO ma = 1, 2 14454 p_index = p_index + 1 14455 tmp = scale*prim(p_index) 14456 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14457 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14458 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14459 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14460 END DO 14461 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 14462 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 14463 END DO 14464 END DO 14465 END DO 14466 END SUBROUTINE block_2_6 14467! ************************************************************************************************** 14468!> \brief ... 14469!> \param kbd ... 14470!> \param kbc ... 14471!> \param kad ... 14472!> \param kac ... 14473!> \param pbd ... 14474!> \param pbc ... 14475!> \param pad ... 14476!> \param pac ... 14477!> \param prim ... 14478!> \param scale ... 14479! ************************************************************************************************** 14480 SUBROUTINE block_2_7_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14481 REAL(KIND=dp) :: kbd(7*1), kbc(7*1), kad(2*1), kac(2*1), & 14482 pbd(7*1), pbc(7*1), pad(2*1), & 14483 pac(2*1), prim(2*7*1*1), scale 14484 14485 INTEGER :: ma, mb, mc, md, p_index 14486 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14487 14488 kbd(1:7*1) = 0.0_dp 14489 kbc(1:7*1) = 0.0_dp 14490 kad(1:2*1) = 0.0_dp 14491 kac(1:2*1) = 0.0_dp 14492 p_index = 0 14493 DO md = 1, 1 14494 DO mc = 1, 1 14495 DO mb = 1, 7 14496 ks_bd = 0.0_dp 14497 ks_bc = 0.0_dp 14498 p_bd = pbd((md - 1)*7 + mb) 14499 p_bc = pbc((mc - 1)*7 + mb) 14500 DO ma = 1, 2 14501 p_index = p_index + 1 14502 tmp = scale*prim(p_index) 14503 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14504 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14505 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14506 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14507 END DO 14508 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 14509 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 14510 END DO 14511 END DO 14512 END DO 14513 END SUBROUTINE block_2_7_1_1 14514! ************************************************************************************************** 14515!> \brief ... 14516!> \param md_max ... 14517!> \param kbd ... 14518!> \param kbc ... 14519!> \param kad ... 14520!> \param kac ... 14521!> \param pbd ... 14522!> \param pbc ... 14523!> \param pad ... 14524!> \param pac ... 14525!> \param prim ... 14526!> \param scale ... 14527! ************************************************************************************************** 14528 SUBROUTINE block_2_7_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14529 INTEGER :: md_max 14530 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*1), kad(2*md_max), kac(2*1), pbd(7*md_max), pbc(7*1), & 14531 pad(2*md_max), pac(2*1), prim(2*7*1*md_max), scale 14532 14533 INTEGER :: ma, mb, mc, md, p_index 14534 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14535 14536 kbd(1:7*md_max) = 0.0_dp 14537 kbc(1:7*1) = 0.0_dp 14538 kad(1:2*md_max) = 0.0_dp 14539 kac(1:2*1) = 0.0_dp 14540 p_index = 0 14541 DO md = 1, md_max 14542 DO mc = 1, 1 14543 DO mb = 1, 7 14544 ks_bd = 0.0_dp 14545 ks_bc = 0.0_dp 14546 p_bd = pbd((md - 1)*7 + mb) 14547 p_bc = pbc((mc - 1)*7 + mb) 14548 DO ma = 1, 2 14549 p_index = p_index + 1 14550 tmp = scale*prim(p_index) 14551 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14552 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14553 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14554 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14555 END DO 14556 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 14557 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 14558 END DO 14559 END DO 14560 END DO 14561 END SUBROUTINE block_2_7_1 14562! ************************************************************************************************** 14563!> \brief ... 14564!> \param mc_max ... 14565!> \param md_max ... 14566!> \param kbd ... 14567!> \param kbc ... 14568!> \param kad ... 14569!> \param kac ... 14570!> \param pbd ... 14571!> \param pbc ... 14572!> \param pad ... 14573!> \param pac ... 14574!> \param prim ... 14575!> \param scale ... 14576! ************************************************************************************************** 14577 SUBROUTINE block_2_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14578 INTEGER :: mc_max, md_max 14579 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(2*md_max), kac(2*mc_max), pbd(7*md_max), & 14580 pbc(7*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*7*mc_max*md_max), scale 14581 14582 INTEGER :: ma, mb, mc, md, p_index 14583 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14584 14585 kbd(1:7*md_max) = 0.0_dp 14586 kbc(1:7*mc_max) = 0.0_dp 14587 kad(1:2*md_max) = 0.0_dp 14588 kac(1:2*mc_max) = 0.0_dp 14589 p_index = 0 14590 DO md = 1, md_max 14591 DO mc = 1, mc_max 14592 DO mb = 1, 7 14593 ks_bd = 0.0_dp 14594 ks_bc = 0.0_dp 14595 p_bd = pbd((md - 1)*7 + mb) 14596 p_bc = pbc((mc - 1)*7 + mb) 14597 DO ma = 1, 2 14598 p_index = p_index + 1 14599 tmp = scale*prim(p_index) 14600 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14601 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14602 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14603 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14604 END DO 14605 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 14606 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 14607 END DO 14608 END DO 14609 END DO 14610 END SUBROUTINE block_2_7 14611! ************************************************************************************************** 14612!> \brief ... 14613!> \param kbd ... 14614!> \param kbc ... 14615!> \param kad ... 14616!> \param kac ... 14617!> \param pbd ... 14618!> \param pbc ... 14619!> \param pad ... 14620!> \param pac ... 14621!> \param prim ... 14622!> \param scale ... 14623! ************************************************************************************************** 14624 SUBROUTINE block_2_9_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14625 REAL(KIND=dp) :: kbd(9*1), kbc(9*1), kad(2*1), kac(2*1), & 14626 pbd(9*1), pbc(9*1), pad(2*1), & 14627 pac(2*1), prim(2*9*1*1), scale 14628 14629 INTEGER :: ma, mb, mc, md, p_index 14630 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14631 14632 kbd(1:9*1) = 0.0_dp 14633 kbc(1:9*1) = 0.0_dp 14634 kad(1:2*1) = 0.0_dp 14635 kac(1:2*1) = 0.0_dp 14636 p_index = 0 14637 DO md = 1, 1 14638 DO mc = 1, 1 14639 DO mb = 1, 9 14640 ks_bd = 0.0_dp 14641 ks_bc = 0.0_dp 14642 p_bd = pbd((md - 1)*9 + mb) 14643 p_bc = pbc((mc - 1)*9 + mb) 14644 DO ma = 1, 2 14645 p_index = p_index + 1 14646 tmp = scale*prim(p_index) 14647 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14648 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14649 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14650 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14651 END DO 14652 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 14653 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 14654 END DO 14655 END DO 14656 END DO 14657 END SUBROUTINE block_2_9_1_1 14658! ************************************************************************************************** 14659!> \brief ... 14660!> \param md_max ... 14661!> \param kbd ... 14662!> \param kbc ... 14663!> \param kad ... 14664!> \param kac ... 14665!> \param pbd ... 14666!> \param pbc ... 14667!> \param pad ... 14668!> \param pac ... 14669!> \param prim ... 14670!> \param scale ... 14671! ************************************************************************************************** 14672 SUBROUTINE block_2_9_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14673 INTEGER :: md_max 14674 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*1), kad(2*md_max), kac(2*1), pbd(9*md_max), pbc(9*1), & 14675 pad(2*md_max), pac(2*1), prim(2*9*1*md_max), scale 14676 14677 INTEGER :: ma, mb, mc, md, p_index 14678 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14679 14680 kbd(1:9*md_max) = 0.0_dp 14681 kbc(1:9*1) = 0.0_dp 14682 kad(1:2*md_max) = 0.0_dp 14683 kac(1:2*1) = 0.0_dp 14684 p_index = 0 14685 DO md = 1, md_max 14686 DO mc = 1, 1 14687 DO mb = 1, 9 14688 ks_bd = 0.0_dp 14689 ks_bc = 0.0_dp 14690 p_bd = pbd((md - 1)*9 + mb) 14691 p_bc = pbc((mc - 1)*9 + mb) 14692 DO ma = 1, 2 14693 p_index = p_index + 1 14694 tmp = scale*prim(p_index) 14695 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14696 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14697 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14698 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14699 END DO 14700 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 14701 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 14702 END DO 14703 END DO 14704 END DO 14705 END SUBROUTINE block_2_9_1 14706! ************************************************************************************************** 14707!> \brief ... 14708!> \param mc_max ... 14709!> \param md_max ... 14710!> \param kbd ... 14711!> \param kbc ... 14712!> \param kad ... 14713!> \param kac ... 14714!> \param pbd ... 14715!> \param pbc ... 14716!> \param pad ... 14717!> \param pac ... 14718!> \param prim ... 14719!> \param scale ... 14720! ************************************************************************************************** 14721 SUBROUTINE block_2_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14722 INTEGER :: mc_max, md_max 14723 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(2*md_max), kac(2*mc_max), pbd(9*md_max), & 14724 pbc(9*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*9*mc_max*md_max), scale 14725 14726 INTEGER :: ma, mb, mc, md, p_index 14727 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14728 14729 kbd(1:9*md_max) = 0.0_dp 14730 kbc(1:9*mc_max) = 0.0_dp 14731 kad(1:2*md_max) = 0.0_dp 14732 kac(1:2*mc_max) = 0.0_dp 14733 p_index = 0 14734 DO md = 1, md_max 14735 DO mc = 1, mc_max 14736 DO mb = 1, 9 14737 ks_bd = 0.0_dp 14738 ks_bc = 0.0_dp 14739 p_bd = pbd((md - 1)*9 + mb) 14740 p_bc = pbc((mc - 1)*9 + mb) 14741 DO ma = 1, 2 14742 p_index = p_index + 1 14743 tmp = scale*prim(p_index) 14744 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14745 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14746 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14747 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14748 END DO 14749 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 14750 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 14751 END DO 14752 END DO 14753 END DO 14754 END SUBROUTINE block_2_9 14755! ************************************************************************************************** 14756!> \brief ... 14757!> \param mc_max ... 14758!> \param md_max ... 14759!> \param kbd ... 14760!> \param kbc ... 14761!> \param kad ... 14762!> \param kac ... 14763!> \param pbd ... 14764!> \param pbc ... 14765!> \param pad ... 14766!> \param pac ... 14767!> \param prim ... 14768!> \param scale ... 14769! ************************************************************************************************** 14770 SUBROUTINE block_2_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14771 INTEGER :: mc_max, md_max 14772 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(2*md_max), kac(2*mc_max), & 14773 pbd(10*md_max), pbc(10*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*10*mc_max*md_max), & 14774 scale 14775 14776 INTEGER :: ma, mb, mc, md, p_index 14777 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14778 14779 kbd(1:10*md_max) = 0.0_dp 14780 kbc(1:10*mc_max) = 0.0_dp 14781 kad(1:2*md_max) = 0.0_dp 14782 kac(1:2*mc_max) = 0.0_dp 14783 p_index = 0 14784 DO md = 1, md_max 14785 DO mc = 1, mc_max 14786 DO mb = 1, 10 14787 ks_bd = 0.0_dp 14788 ks_bc = 0.0_dp 14789 p_bd = pbd((md - 1)*10 + mb) 14790 p_bc = pbc((mc - 1)*10 + mb) 14791 DO ma = 1, 2 14792 p_index = p_index + 1 14793 tmp = scale*prim(p_index) 14794 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14795 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14796 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14797 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14798 END DO 14799 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 14800 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 14801 END DO 14802 END DO 14803 END DO 14804 END SUBROUTINE block_2_10 14805! ************************************************************************************************** 14806!> \brief ... 14807!> \param mc_max ... 14808!> \param md_max ... 14809!> \param kbd ... 14810!> \param kbc ... 14811!> \param kad ... 14812!> \param kac ... 14813!> \param pbd ... 14814!> \param pbc ... 14815!> \param pad ... 14816!> \param pac ... 14817!> \param prim ... 14818!> \param scale ... 14819! ************************************************************************************************** 14820 SUBROUTINE block_2_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14821 INTEGER :: mc_max, md_max 14822 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(2*md_max), kac(2*mc_max), & 14823 pbd(11*md_max), pbc(11*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*11*mc_max*md_max), & 14824 scale 14825 14826 INTEGER :: ma, mb, mc, md, p_index 14827 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14828 14829 kbd(1:11*md_max) = 0.0_dp 14830 kbc(1:11*mc_max) = 0.0_dp 14831 kad(1:2*md_max) = 0.0_dp 14832 kac(1:2*mc_max) = 0.0_dp 14833 p_index = 0 14834 DO md = 1, md_max 14835 DO mc = 1, mc_max 14836 DO mb = 1, 11 14837 ks_bd = 0.0_dp 14838 ks_bc = 0.0_dp 14839 p_bd = pbd((md - 1)*11 + mb) 14840 p_bc = pbc((mc - 1)*11 + mb) 14841 DO ma = 1, 2 14842 p_index = p_index + 1 14843 tmp = scale*prim(p_index) 14844 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14845 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14846 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14847 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14848 END DO 14849 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 14850 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 14851 END DO 14852 END DO 14853 END DO 14854 END SUBROUTINE block_2_11 14855! ************************************************************************************************** 14856!> \brief ... 14857!> \param mc_max ... 14858!> \param md_max ... 14859!> \param kbd ... 14860!> \param kbc ... 14861!> \param kad ... 14862!> \param kac ... 14863!> \param pbd ... 14864!> \param pbc ... 14865!> \param pad ... 14866!> \param pac ... 14867!> \param prim ... 14868!> \param scale ... 14869! ************************************************************************************************** 14870 SUBROUTINE block_2_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14871 INTEGER :: mc_max, md_max 14872 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(2*md_max), kac(2*mc_max), & 14873 pbd(15*md_max), pbc(15*mc_max), pad(2*md_max), pac(2*mc_max), prim(2*15*mc_max*md_max), & 14874 scale 14875 14876 INTEGER :: ma, mb, mc, md, p_index 14877 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14878 14879 kbd(1:15*md_max) = 0.0_dp 14880 kbc(1:15*mc_max) = 0.0_dp 14881 kad(1:2*md_max) = 0.0_dp 14882 kac(1:2*mc_max) = 0.0_dp 14883 p_index = 0 14884 DO md = 1, md_max 14885 DO mc = 1, mc_max 14886 DO mb = 1, 15 14887 ks_bd = 0.0_dp 14888 ks_bc = 0.0_dp 14889 p_bd = pbd((md - 1)*15 + mb) 14890 p_bc = pbc((mc - 1)*15 + mb) 14891 DO ma = 1, 2 14892 p_index = p_index + 1 14893 tmp = scale*prim(p_index) 14894 ks_bc = ks_bc + tmp*pad((md - 1)*2 + ma) 14895 ks_bd = ks_bd + tmp*pac((mc - 1)*2 + ma) 14896 kad((md - 1)*2 + ma) = kad((md - 1)*2 + ma) - tmp*p_bc 14897 kac((mc - 1)*2 + ma) = kac((mc - 1)*2 + ma) - tmp*p_bd 14898 END DO 14899 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 14900 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 14901 END DO 14902 END DO 14903 END DO 14904 END SUBROUTINE block_2_15 14905! ************************************************************************************************** 14906!> \brief ... 14907!> \param kbd ... 14908!> \param kbc ... 14909!> \param kad ... 14910!> \param kac ... 14911!> \param pbd ... 14912!> \param pbc ... 14913!> \param pad ... 14914!> \param pac ... 14915!> \param prim ... 14916!> \param scale ... 14917! ************************************************************************************************** 14918 SUBROUTINE block_3_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14919 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(3*1), kac(3*1), & 14920 pbd(1*1), pbc(1*1), pad(3*1), & 14921 pac(3*1), prim(3*1*1*1), scale 14922 14923 INTEGER :: ma, mb, mc, md, p_index 14924 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14925 14926 kbd(1:1*1) = 0.0_dp 14927 kbc(1:1*1) = 0.0_dp 14928 kad(1:3*1) = 0.0_dp 14929 kac(1:3*1) = 0.0_dp 14930 p_index = 0 14931 DO md = 1, 1 14932 DO mc = 1, 1 14933 DO mb = 1, 1 14934 ks_bd = 0.0_dp 14935 ks_bc = 0.0_dp 14936 p_bd = pbd((md - 1)*1 + mb) 14937 p_bc = pbc((mc - 1)*1 + mb) 14938 DO ma = 1, 3 14939 p_index = p_index + 1 14940 tmp = scale*prim(p_index) 14941 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 14942 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 14943 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 14944 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 14945 END DO 14946 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 14947 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 14948 END DO 14949 END DO 14950 END DO 14951 END SUBROUTINE block_3_1_1_1 14952! ************************************************************************************************** 14953!> \brief ... 14954!> \param kbd ... 14955!> \param kbc ... 14956!> \param kad ... 14957!> \param kac ... 14958!> \param pbd ... 14959!> \param pbc ... 14960!> \param pad ... 14961!> \param pac ... 14962!> \param prim ... 14963!> \param scale ... 14964! ************************************************************************************************** 14965 SUBROUTINE block_3_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 14966 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(3*2), kac(3*1), & 14967 pbd(1*2), pbc(1*1), pad(3*2), & 14968 pac(3*1), prim(3*1*1*2), scale 14969 14970 INTEGER :: ma, mb, mc, md, p_index 14971 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 14972 14973 kbd(1:1*2) = 0.0_dp 14974 kbc(1:1*1) = 0.0_dp 14975 kad(1:3*2) = 0.0_dp 14976 kac(1:3*1) = 0.0_dp 14977 p_index = 0 14978 DO md = 1, 2 14979 DO mc = 1, 1 14980 DO mb = 1, 1 14981 ks_bd = 0.0_dp 14982 ks_bc = 0.0_dp 14983 p_bd = pbd((md - 1)*1 + mb) 14984 p_bc = pbc((mc - 1)*1 + mb) 14985 DO ma = 1, 3 14986 p_index = p_index + 1 14987 tmp = scale*prim(p_index) 14988 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 14989 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 14990 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 14991 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 14992 END DO 14993 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 14994 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 14995 END DO 14996 END DO 14997 END DO 14998 END SUBROUTINE block_3_1_1_2 14999! ************************************************************************************************** 15000!> \brief ... 15001!> \param kbd ... 15002!> \param kbc ... 15003!> \param kad ... 15004!> \param kac ... 15005!> \param pbd ... 15006!> \param pbc ... 15007!> \param pad ... 15008!> \param pac ... 15009!> \param prim ... 15010!> \param scale ... 15011! ************************************************************************************************** 15012 SUBROUTINE block_3_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15013 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(3*3), kac(3*1), & 15014 pbd(1*3), pbc(1*1), pad(3*3), & 15015 pac(3*1), prim(3*1*1*3), scale 15016 15017 INTEGER :: ma, mb, mc, md, p_index 15018 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15019 15020 kbd(1:1*3) = 0.0_dp 15021 kbc(1:1*1) = 0.0_dp 15022 kad(1:3*3) = 0.0_dp 15023 kac(1:3*1) = 0.0_dp 15024 p_index = 0 15025 DO md = 1, 3 15026 DO mc = 1, 1 15027 DO mb = 1, 1 15028 ks_bd = 0.0_dp 15029 ks_bc = 0.0_dp 15030 p_bd = pbd((md - 1)*1 + mb) 15031 p_bc = pbc((mc - 1)*1 + mb) 15032 DO ma = 1, 3 15033 p_index = p_index + 1 15034 tmp = scale*prim(p_index) 15035 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15036 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15037 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15038 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15039 END DO 15040 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15041 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15042 END DO 15043 END DO 15044 END DO 15045 END SUBROUTINE block_3_1_1_3 15046! ************************************************************************************************** 15047!> \brief ... 15048!> \param kbd ... 15049!> \param kbc ... 15050!> \param kad ... 15051!> \param kac ... 15052!> \param pbd ... 15053!> \param pbc ... 15054!> \param pad ... 15055!> \param pac ... 15056!> \param prim ... 15057!> \param scale ... 15058! ************************************************************************************************** 15059 SUBROUTINE block_3_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15060 REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(3*4), kac(3*1), & 15061 pbd(1*4), pbc(1*1), pad(3*4), & 15062 pac(3*1), prim(3*1*1*4), scale 15063 15064 INTEGER :: ma, mb, mc, md, p_index 15065 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15066 15067 kbd(1:1*4) = 0.0_dp 15068 kbc(1:1*1) = 0.0_dp 15069 kad(1:3*4) = 0.0_dp 15070 kac(1:3*1) = 0.0_dp 15071 p_index = 0 15072 DO md = 1, 4 15073 DO mc = 1, 1 15074 DO mb = 1, 1 15075 ks_bd = 0.0_dp 15076 ks_bc = 0.0_dp 15077 p_bd = pbd((md - 1)*1 + mb) 15078 p_bc = pbc((mc - 1)*1 + mb) 15079 DO ma = 1, 3 15080 p_index = p_index + 1 15081 tmp = scale*prim(p_index) 15082 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15083 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15084 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15085 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15086 END DO 15087 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15088 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15089 END DO 15090 END DO 15091 END DO 15092 END SUBROUTINE block_3_1_1_4 15093! ************************************************************************************************** 15094!> \brief ... 15095!> \param kbd ... 15096!> \param kbc ... 15097!> \param kad ... 15098!> \param kac ... 15099!> \param pbd ... 15100!> \param pbc ... 15101!> \param pad ... 15102!> \param pac ... 15103!> \param prim ... 15104!> \param scale ... 15105! ************************************************************************************************** 15106 SUBROUTINE block_3_1_1_5(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15107 REAL(KIND=dp) :: kbd(1*5), kbc(1*1), kad(3*5), kac(3*1), & 15108 pbd(1*5), pbc(1*1), pad(3*5), & 15109 pac(3*1), prim(3*1*1*5), scale 15110 15111 INTEGER :: ma, mb, mc, md, p_index 15112 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15113 15114 kbd(1:1*5) = 0.0_dp 15115 kbc(1:1*1) = 0.0_dp 15116 kad(1:3*5) = 0.0_dp 15117 kac(1:3*1) = 0.0_dp 15118 p_index = 0 15119 DO md = 1, 5 15120 DO mc = 1, 1 15121 DO mb = 1, 1 15122 ks_bd = 0.0_dp 15123 ks_bc = 0.0_dp 15124 p_bd = pbd((md - 1)*1 + mb) 15125 p_bc = pbc((mc - 1)*1 + mb) 15126 DO ma = 1, 3 15127 p_index = p_index + 1 15128 tmp = scale*prim(p_index) 15129 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15130 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15131 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15132 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15133 END DO 15134 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15135 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15136 END DO 15137 END DO 15138 END DO 15139 END SUBROUTINE block_3_1_1_5 15140! ************************************************************************************************** 15141!> \brief ... 15142!> \param kbd ... 15143!> \param kbc ... 15144!> \param kad ... 15145!> \param kac ... 15146!> \param pbd ... 15147!> \param pbc ... 15148!> \param pad ... 15149!> \param pac ... 15150!> \param prim ... 15151!> \param scale ... 15152! ************************************************************************************************** 15153 SUBROUTINE block_3_1_1_6(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15154 REAL(KIND=dp) :: kbd(1*6), kbc(1*1), kad(3*6), kac(3*1), & 15155 pbd(1*6), pbc(1*1), pad(3*6), & 15156 pac(3*1), prim(3*1*1*6), scale 15157 15158 INTEGER :: ma, mb, mc, md, p_index 15159 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15160 15161 kbd(1:1*6) = 0.0_dp 15162 kbc(1:1*1) = 0.0_dp 15163 kad(1:3*6) = 0.0_dp 15164 kac(1:3*1) = 0.0_dp 15165 p_index = 0 15166 DO md = 1, 6 15167 DO mc = 1, 1 15168 DO mb = 1, 1 15169 ks_bd = 0.0_dp 15170 ks_bc = 0.0_dp 15171 p_bd = pbd((md - 1)*1 + mb) 15172 p_bc = pbc((mc - 1)*1 + mb) 15173 DO ma = 1, 3 15174 p_index = p_index + 1 15175 tmp = scale*prim(p_index) 15176 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15177 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15178 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15179 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15180 END DO 15181 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15182 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15183 END DO 15184 END DO 15185 END DO 15186 END SUBROUTINE block_3_1_1_6 15187! ************************************************************************************************** 15188!> \brief ... 15189!> \param md_max ... 15190!> \param kbd ... 15191!> \param kbc ... 15192!> \param kad ... 15193!> \param kac ... 15194!> \param pbd ... 15195!> \param pbc ... 15196!> \param pad ... 15197!> \param pac ... 15198!> \param prim ... 15199!> \param scale ... 15200! ************************************************************************************************** 15201 SUBROUTINE block_3_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15202 INTEGER :: md_max 15203 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(3*md_max), kac(3*1), pbd(1*md_max), pbc(1*1), & 15204 pad(3*md_max), pac(3*1), prim(3*1*1*md_max), scale 15205 15206 INTEGER :: ma, mb, mc, md, p_index 15207 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15208 15209 kbd(1:1*md_max) = 0.0_dp 15210 kbc(1:1*1) = 0.0_dp 15211 kad(1:3*md_max) = 0.0_dp 15212 kac(1:3*1) = 0.0_dp 15213 p_index = 0 15214 DO md = 1, md_max 15215 DO mc = 1, 1 15216 DO mb = 1, 1 15217 ks_bd = 0.0_dp 15218 ks_bc = 0.0_dp 15219 p_bd = pbd((md - 1)*1 + mb) 15220 p_bc = pbc((mc - 1)*1 + mb) 15221 DO ma = 1, 3 15222 p_index = p_index + 1 15223 tmp = scale*prim(p_index) 15224 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15225 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15226 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15227 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15228 END DO 15229 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15230 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15231 END DO 15232 END DO 15233 END DO 15234 END SUBROUTINE block_3_1_1 15235! ************************************************************************************************** 15236!> \brief ... 15237!> \param kbd ... 15238!> \param kbc ... 15239!> \param kad ... 15240!> \param kac ... 15241!> \param pbd ... 15242!> \param pbc ... 15243!> \param pad ... 15244!> \param pac ... 15245!> \param prim ... 15246!> \param scale ... 15247! ************************************************************************************************** 15248 SUBROUTINE block_3_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15249 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(3*1), kac(3*2), & 15250 pbd(1*1), pbc(1*2), pad(3*1), & 15251 pac(3*2), prim(3*1*2*1), scale 15252 15253 INTEGER :: ma, mb, mc, md, p_index 15254 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15255 15256 kbd(1:1*1) = 0.0_dp 15257 kbc(1:1*2) = 0.0_dp 15258 kad(1:3*1) = 0.0_dp 15259 kac(1:3*2) = 0.0_dp 15260 p_index = 0 15261 DO md = 1, 1 15262 DO mc = 1, 2 15263 DO mb = 1, 1 15264 ks_bd = 0.0_dp 15265 ks_bc = 0.0_dp 15266 p_bd = pbd((md - 1)*1 + mb) 15267 p_bc = pbc((mc - 1)*1 + mb) 15268 DO ma = 1, 3 15269 p_index = p_index + 1 15270 tmp = scale*prim(p_index) 15271 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15272 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15273 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15274 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15275 END DO 15276 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15277 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15278 END DO 15279 END DO 15280 END DO 15281 END SUBROUTINE block_3_1_2_1 15282! ************************************************************************************************** 15283!> \brief ... 15284!> \param kbd ... 15285!> \param kbc ... 15286!> \param kad ... 15287!> \param kac ... 15288!> \param pbd ... 15289!> \param pbc ... 15290!> \param pad ... 15291!> \param pac ... 15292!> \param prim ... 15293!> \param scale ... 15294! ************************************************************************************************** 15295 SUBROUTINE block_3_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15296 REAL(KIND=dp) :: kbd(1*2), kbc(1*2), kad(3*2), kac(3*2), & 15297 pbd(1*2), pbc(1*2), pad(3*2), & 15298 pac(3*2), prim(3*1*2*2), scale 15299 15300 INTEGER :: ma, mb, mc, md, p_index 15301 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15302 15303 kbd(1:1*2) = 0.0_dp 15304 kbc(1:1*2) = 0.0_dp 15305 kad(1:3*2) = 0.0_dp 15306 kac(1:3*2) = 0.0_dp 15307 p_index = 0 15308 DO md = 1, 2 15309 DO mc = 1, 2 15310 DO mb = 1, 1 15311 ks_bd = 0.0_dp 15312 ks_bc = 0.0_dp 15313 p_bd = pbd((md - 1)*1 + mb) 15314 p_bc = pbc((mc - 1)*1 + mb) 15315 DO ma = 1, 3 15316 p_index = p_index + 1 15317 tmp = scale*prim(p_index) 15318 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15319 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15320 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15321 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15322 END DO 15323 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15324 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15325 END DO 15326 END DO 15327 END DO 15328 END SUBROUTINE block_3_1_2_2 15329! ************************************************************************************************** 15330!> \brief ... 15331!> \param kbd ... 15332!> \param kbc ... 15333!> \param kad ... 15334!> \param kac ... 15335!> \param pbd ... 15336!> \param pbc ... 15337!> \param pad ... 15338!> \param pac ... 15339!> \param prim ... 15340!> \param scale ... 15341! ************************************************************************************************** 15342 SUBROUTINE block_3_1_2_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15343 REAL(KIND=dp) :: kbd(1*3), kbc(1*2), kad(3*3), kac(3*2), & 15344 pbd(1*3), pbc(1*2), pad(3*3), & 15345 pac(3*2), prim(3*1*2*3), scale 15346 15347 INTEGER :: ma, mb, mc, md, p_index 15348 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15349 15350 kbd(1:1*3) = 0.0_dp 15351 kbc(1:1*2) = 0.0_dp 15352 kad(1:3*3) = 0.0_dp 15353 kac(1:3*2) = 0.0_dp 15354 p_index = 0 15355 DO md = 1, 3 15356 DO mc = 1, 2 15357 DO mb = 1, 1 15358 ks_bd = 0.0_dp 15359 ks_bc = 0.0_dp 15360 p_bd = pbd((md - 1)*1 + mb) 15361 p_bc = pbc((mc - 1)*1 + mb) 15362 DO ma = 1, 3 15363 p_index = p_index + 1 15364 tmp = scale*prim(p_index) 15365 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15366 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15367 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15368 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15369 END DO 15370 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15371 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15372 END DO 15373 END DO 15374 END DO 15375 END SUBROUTINE block_3_1_2_3 15376! ************************************************************************************************** 15377!> \brief ... 15378!> \param md_max ... 15379!> \param kbd ... 15380!> \param kbc ... 15381!> \param kad ... 15382!> \param kac ... 15383!> \param pbd ... 15384!> \param pbc ... 15385!> \param pad ... 15386!> \param pac ... 15387!> \param prim ... 15388!> \param scale ... 15389! ************************************************************************************************** 15390 SUBROUTINE block_3_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15391 INTEGER :: md_max 15392 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(3*md_max), kac(3*2), pbd(1*md_max), pbc(1*2), & 15393 pad(3*md_max), pac(3*2), prim(3*1*2*md_max), scale 15394 15395 INTEGER :: ma, mb, mc, md, p_index 15396 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15397 15398 kbd(1:1*md_max) = 0.0_dp 15399 kbc(1:1*2) = 0.0_dp 15400 kad(1:3*md_max) = 0.0_dp 15401 kac(1:3*2) = 0.0_dp 15402 p_index = 0 15403 DO md = 1, md_max 15404 DO mc = 1, 2 15405 DO mb = 1, 1 15406 ks_bd = 0.0_dp 15407 ks_bc = 0.0_dp 15408 p_bd = pbd((md - 1)*1 + mb) 15409 p_bc = pbc((mc - 1)*1 + mb) 15410 DO ma = 1, 3 15411 p_index = p_index + 1 15412 tmp = scale*prim(p_index) 15413 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15414 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15415 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15416 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15417 END DO 15418 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15419 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15420 END DO 15421 END DO 15422 END DO 15423 END SUBROUTINE block_3_1_2 15424! ************************************************************************************************** 15425!> \brief ... 15426!> \param kbd ... 15427!> \param kbc ... 15428!> \param kad ... 15429!> \param kac ... 15430!> \param pbd ... 15431!> \param pbc ... 15432!> \param pad ... 15433!> \param pac ... 15434!> \param prim ... 15435!> \param scale ... 15436! ************************************************************************************************** 15437 SUBROUTINE block_3_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15438 REAL(KIND=dp) :: kbd(1*1), kbc(1*3), kad(3*1), kac(3*3), & 15439 pbd(1*1), pbc(1*3), pad(3*1), & 15440 pac(3*3), prim(3*1*3*1), scale 15441 15442 INTEGER :: ma, mb, mc, md, p_index 15443 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15444 15445 kbd(1:1*1) = 0.0_dp 15446 kbc(1:1*3) = 0.0_dp 15447 kad(1:3*1) = 0.0_dp 15448 kac(1:3*3) = 0.0_dp 15449 p_index = 0 15450 DO md = 1, 1 15451 DO mc = 1, 3 15452 DO mb = 1, 1 15453 ks_bd = 0.0_dp 15454 ks_bc = 0.0_dp 15455 p_bd = pbd((md - 1)*1 + mb) 15456 p_bc = pbc((mc - 1)*1 + mb) 15457 DO ma = 1, 3 15458 p_index = p_index + 1 15459 tmp = scale*prim(p_index) 15460 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15461 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15462 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15463 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15464 END DO 15465 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15466 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15467 END DO 15468 END DO 15469 END DO 15470 END SUBROUTINE block_3_1_3_1 15471! ************************************************************************************************** 15472!> \brief ... 15473!> \param kbd ... 15474!> \param kbc ... 15475!> \param kad ... 15476!> \param kac ... 15477!> \param pbd ... 15478!> \param pbc ... 15479!> \param pad ... 15480!> \param pac ... 15481!> \param prim ... 15482!> \param scale ... 15483! ************************************************************************************************** 15484 SUBROUTINE block_3_1_3_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15485 REAL(KIND=dp) :: kbd(1*2), kbc(1*3), kad(3*2), kac(3*3), & 15486 pbd(1*2), pbc(1*3), pad(3*2), & 15487 pac(3*3), prim(3*1*3*2), scale 15488 15489 INTEGER :: ma, mb, mc, md, p_index 15490 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15491 15492 kbd(1:1*2) = 0.0_dp 15493 kbc(1:1*3) = 0.0_dp 15494 kad(1:3*2) = 0.0_dp 15495 kac(1:3*3) = 0.0_dp 15496 p_index = 0 15497 DO md = 1, 2 15498 DO mc = 1, 3 15499 DO mb = 1, 1 15500 ks_bd = 0.0_dp 15501 ks_bc = 0.0_dp 15502 p_bd = pbd((md - 1)*1 + mb) 15503 p_bc = pbc((mc - 1)*1 + mb) 15504 DO ma = 1, 3 15505 p_index = p_index + 1 15506 tmp = scale*prim(p_index) 15507 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15508 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15509 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15510 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15511 END DO 15512 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15513 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15514 END DO 15515 END DO 15516 END DO 15517 END SUBROUTINE block_3_1_3_2 15518! ************************************************************************************************** 15519!> \brief ... 15520!> \param md_max ... 15521!> \param kbd ... 15522!> \param kbc ... 15523!> \param kad ... 15524!> \param kac ... 15525!> \param pbd ... 15526!> \param pbc ... 15527!> \param pad ... 15528!> \param pac ... 15529!> \param prim ... 15530!> \param scale ... 15531! ************************************************************************************************** 15532 SUBROUTINE block_3_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15533 INTEGER :: md_max 15534 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*3), kad(3*md_max), kac(3*3), pbd(1*md_max), pbc(1*3), & 15535 pad(3*md_max), pac(3*3), prim(3*1*3*md_max), scale 15536 15537 INTEGER :: ma, mb, mc, md, p_index 15538 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15539 15540 kbd(1:1*md_max) = 0.0_dp 15541 kbc(1:1*3) = 0.0_dp 15542 kad(1:3*md_max) = 0.0_dp 15543 kac(1:3*3) = 0.0_dp 15544 p_index = 0 15545 DO md = 1, md_max 15546 DO mc = 1, 3 15547 DO mb = 1, 1 15548 ks_bd = 0.0_dp 15549 ks_bc = 0.0_dp 15550 p_bd = pbd((md - 1)*1 + mb) 15551 p_bc = pbc((mc - 1)*1 + mb) 15552 DO ma = 1, 3 15553 p_index = p_index + 1 15554 tmp = scale*prim(p_index) 15555 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15556 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15557 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15558 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15559 END DO 15560 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15561 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15562 END DO 15563 END DO 15564 END DO 15565 END SUBROUTINE block_3_1_3 15566! ************************************************************************************************** 15567!> \brief ... 15568!> \param kbd ... 15569!> \param kbc ... 15570!> \param kad ... 15571!> \param kac ... 15572!> \param pbd ... 15573!> \param pbc ... 15574!> \param pad ... 15575!> \param pac ... 15576!> \param prim ... 15577!> \param scale ... 15578! ************************************************************************************************** 15579 SUBROUTINE block_3_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15580 REAL(KIND=dp) :: kbd(1*1), kbc(1*4), kad(3*1), kac(3*4), & 15581 pbd(1*1), pbc(1*4), pad(3*1), & 15582 pac(3*4), prim(3*1*4*1), scale 15583 15584 INTEGER :: ma, mb, mc, md, p_index 15585 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15586 15587 kbd(1:1*1) = 0.0_dp 15588 kbc(1:1*4) = 0.0_dp 15589 kad(1:3*1) = 0.0_dp 15590 kac(1:3*4) = 0.0_dp 15591 p_index = 0 15592 DO md = 1, 1 15593 DO mc = 1, 4 15594 DO mb = 1, 1 15595 ks_bd = 0.0_dp 15596 ks_bc = 0.0_dp 15597 p_bd = pbd((md - 1)*1 + mb) 15598 p_bc = pbc((mc - 1)*1 + mb) 15599 DO ma = 1, 3 15600 p_index = p_index + 1 15601 tmp = scale*prim(p_index) 15602 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15603 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15604 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15605 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15606 END DO 15607 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15608 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15609 END DO 15610 END DO 15611 END DO 15612 END SUBROUTINE block_3_1_4_1 15613! ************************************************************************************************** 15614!> \brief ... 15615!> \param md_max ... 15616!> \param kbd ... 15617!> \param kbc ... 15618!> \param kad ... 15619!> \param kac ... 15620!> \param pbd ... 15621!> \param pbc ... 15622!> \param pad ... 15623!> \param pac ... 15624!> \param prim ... 15625!> \param scale ... 15626! ************************************************************************************************** 15627 SUBROUTINE block_3_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15628 INTEGER :: md_max 15629 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*4), kad(3*md_max), kac(3*4), pbd(1*md_max), pbc(1*4), & 15630 pad(3*md_max), pac(3*4), prim(3*1*4*md_max), scale 15631 15632 INTEGER :: ma, mb, mc, md, p_index 15633 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15634 15635 kbd(1:1*md_max) = 0.0_dp 15636 kbc(1:1*4) = 0.0_dp 15637 kad(1:3*md_max) = 0.0_dp 15638 kac(1:3*4) = 0.0_dp 15639 p_index = 0 15640 DO md = 1, md_max 15641 DO mc = 1, 4 15642 DO mb = 1, 1 15643 ks_bd = 0.0_dp 15644 ks_bc = 0.0_dp 15645 p_bd = pbd((md - 1)*1 + mb) 15646 p_bc = pbc((mc - 1)*1 + mb) 15647 DO ma = 1, 3 15648 p_index = p_index + 1 15649 tmp = scale*prim(p_index) 15650 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15651 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15652 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15653 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15654 END DO 15655 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15656 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15657 END DO 15658 END DO 15659 END DO 15660 END SUBROUTINE block_3_1_4 15661! ************************************************************************************************** 15662!> \brief ... 15663!> \param kbd ... 15664!> \param kbc ... 15665!> \param kad ... 15666!> \param kac ... 15667!> \param pbd ... 15668!> \param pbc ... 15669!> \param pad ... 15670!> \param pac ... 15671!> \param prim ... 15672!> \param scale ... 15673! ************************************************************************************************** 15674 SUBROUTINE block_3_1_5_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15675 REAL(KIND=dp) :: kbd(1*1), kbc(1*5), kad(3*1), kac(3*5), & 15676 pbd(1*1), pbc(1*5), pad(3*1), & 15677 pac(3*5), prim(3*1*5*1), scale 15678 15679 INTEGER :: ma, mb, mc, md, p_index 15680 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15681 15682 kbd(1:1*1) = 0.0_dp 15683 kbc(1:1*5) = 0.0_dp 15684 kad(1:3*1) = 0.0_dp 15685 kac(1:3*5) = 0.0_dp 15686 p_index = 0 15687 DO md = 1, 1 15688 DO mc = 1, 5 15689 DO mb = 1, 1 15690 ks_bd = 0.0_dp 15691 ks_bc = 0.0_dp 15692 p_bd = pbd((md - 1)*1 + mb) 15693 p_bc = pbc((mc - 1)*1 + mb) 15694 DO ma = 1, 3 15695 p_index = p_index + 1 15696 tmp = scale*prim(p_index) 15697 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15698 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15699 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15700 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15701 END DO 15702 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15703 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15704 END DO 15705 END DO 15706 END DO 15707 END SUBROUTINE block_3_1_5_1 15708! ************************************************************************************************** 15709!> \brief ... 15710!> \param md_max ... 15711!> \param kbd ... 15712!> \param kbc ... 15713!> \param kad ... 15714!> \param kac ... 15715!> \param pbd ... 15716!> \param pbc ... 15717!> \param pad ... 15718!> \param pac ... 15719!> \param prim ... 15720!> \param scale ... 15721! ************************************************************************************************** 15722 SUBROUTINE block_3_1_5(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15723 INTEGER :: md_max 15724 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*5), kad(3*md_max), kac(3*5), pbd(1*md_max), pbc(1*5), & 15725 pad(3*md_max), pac(3*5), prim(3*1*5*md_max), scale 15726 15727 INTEGER :: ma, mb, mc, md, p_index 15728 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15729 15730 kbd(1:1*md_max) = 0.0_dp 15731 kbc(1:1*5) = 0.0_dp 15732 kad(1:3*md_max) = 0.0_dp 15733 kac(1:3*5) = 0.0_dp 15734 p_index = 0 15735 DO md = 1, md_max 15736 DO mc = 1, 5 15737 DO mb = 1, 1 15738 ks_bd = 0.0_dp 15739 ks_bc = 0.0_dp 15740 p_bd = pbd((md - 1)*1 + mb) 15741 p_bc = pbc((mc - 1)*1 + mb) 15742 DO ma = 1, 3 15743 p_index = p_index + 1 15744 tmp = scale*prim(p_index) 15745 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15746 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15747 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15748 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15749 END DO 15750 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15751 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15752 END DO 15753 END DO 15754 END DO 15755 END SUBROUTINE block_3_1_5 15756! ************************************************************************************************** 15757!> \brief ... 15758!> \param kbd ... 15759!> \param kbc ... 15760!> \param kad ... 15761!> \param kac ... 15762!> \param pbd ... 15763!> \param pbc ... 15764!> \param pad ... 15765!> \param pac ... 15766!> \param prim ... 15767!> \param scale ... 15768! ************************************************************************************************** 15769 SUBROUTINE block_3_1_6_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15770 REAL(KIND=dp) :: kbd(1*1), kbc(1*6), kad(3*1), kac(3*6), & 15771 pbd(1*1), pbc(1*6), pad(3*1), & 15772 pac(3*6), prim(3*1*6*1), scale 15773 15774 INTEGER :: ma, mb, mc, md, p_index 15775 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15776 15777 kbd(1:1*1) = 0.0_dp 15778 kbc(1:1*6) = 0.0_dp 15779 kad(1:3*1) = 0.0_dp 15780 kac(1:3*6) = 0.0_dp 15781 p_index = 0 15782 DO md = 1, 1 15783 DO mc = 1, 6 15784 DO mb = 1, 1 15785 ks_bd = 0.0_dp 15786 ks_bc = 0.0_dp 15787 p_bd = pbd((md - 1)*1 + mb) 15788 p_bc = pbc((mc - 1)*1 + mb) 15789 DO ma = 1, 3 15790 p_index = p_index + 1 15791 tmp = scale*prim(p_index) 15792 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15793 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15794 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15795 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15796 END DO 15797 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15798 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15799 END DO 15800 END DO 15801 END DO 15802 END SUBROUTINE block_3_1_6_1 15803! ************************************************************************************************** 15804!> \brief ... 15805!> \param md_max ... 15806!> \param kbd ... 15807!> \param kbc ... 15808!> \param kad ... 15809!> \param kac ... 15810!> \param pbd ... 15811!> \param pbc ... 15812!> \param pad ... 15813!> \param pac ... 15814!> \param prim ... 15815!> \param scale ... 15816! ************************************************************************************************** 15817 SUBROUTINE block_3_1_6(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15818 INTEGER :: md_max 15819 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*6), kad(3*md_max), kac(3*6), pbd(1*md_max), pbc(1*6), & 15820 pad(3*md_max), pac(3*6), prim(3*1*6*md_max), scale 15821 15822 INTEGER :: ma, mb, mc, md, p_index 15823 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15824 15825 kbd(1:1*md_max) = 0.0_dp 15826 kbc(1:1*6) = 0.0_dp 15827 kad(1:3*md_max) = 0.0_dp 15828 kac(1:3*6) = 0.0_dp 15829 p_index = 0 15830 DO md = 1, md_max 15831 DO mc = 1, 6 15832 DO mb = 1, 1 15833 ks_bd = 0.0_dp 15834 ks_bc = 0.0_dp 15835 p_bd = pbd((md - 1)*1 + mb) 15836 p_bc = pbc((mc - 1)*1 + mb) 15837 DO ma = 1, 3 15838 p_index = p_index + 1 15839 tmp = scale*prim(p_index) 15840 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15841 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15842 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15843 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15844 END DO 15845 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15846 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15847 END DO 15848 END DO 15849 END DO 15850 END SUBROUTINE block_3_1_6 15851! ************************************************************************************************** 15852!> \brief ... 15853!> \param mc_max ... 15854!> \param md_max ... 15855!> \param kbd ... 15856!> \param kbc ... 15857!> \param kad ... 15858!> \param kac ... 15859!> \param pbd ... 15860!> \param pbc ... 15861!> \param pad ... 15862!> \param pac ... 15863!> \param prim ... 15864!> \param scale ... 15865! ************************************************************************************************** 15866 SUBROUTINE block_3_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15867 INTEGER :: mc_max, md_max 15868 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(3*md_max), kac(3*mc_max), pbd(1*md_max), & 15869 pbc(1*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*1*mc_max*md_max), scale 15870 15871 INTEGER :: ma, mb, mc, md, p_index 15872 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15873 15874 kbd(1:1*md_max) = 0.0_dp 15875 kbc(1:1*mc_max) = 0.0_dp 15876 kad(1:3*md_max) = 0.0_dp 15877 kac(1:3*mc_max) = 0.0_dp 15878 p_index = 0 15879 DO md = 1, md_max 15880 DO mc = 1, mc_max 15881 DO mb = 1, 1 15882 ks_bd = 0.0_dp 15883 ks_bc = 0.0_dp 15884 p_bd = pbd((md - 1)*1 + mb) 15885 p_bc = pbc((mc - 1)*1 + mb) 15886 DO ma = 1, 3 15887 p_index = p_index + 1 15888 tmp = scale*prim(p_index) 15889 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15890 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15891 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15892 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15893 END DO 15894 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 15895 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 15896 END DO 15897 END DO 15898 END DO 15899 END SUBROUTINE block_3_1 15900! ************************************************************************************************** 15901!> \brief ... 15902!> \param kbd ... 15903!> \param kbc ... 15904!> \param kad ... 15905!> \param kac ... 15906!> \param pbd ... 15907!> \param pbc ... 15908!> \param pad ... 15909!> \param pac ... 15910!> \param prim ... 15911!> \param scale ... 15912! ************************************************************************************************** 15913 SUBROUTINE block_3_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15914 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(3*1), kac(3*1), & 15915 pbd(2*1), pbc(2*1), pad(3*1), & 15916 pac(3*1), prim(3*2*1*1), scale 15917 15918 INTEGER :: ma, mb, mc, md, p_index 15919 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15920 15921 kbd(1:2*1) = 0.0_dp 15922 kbc(1:2*1) = 0.0_dp 15923 kad(1:3*1) = 0.0_dp 15924 kac(1:3*1) = 0.0_dp 15925 p_index = 0 15926 DO md = 1, 1 15927 DO mc = 1, 1 15928 DO mb = 1, 2 15929 ks_bd = 0.0_dp 15930 ks_bc = 0.0_dp 15931 p_bd = pbd((md - 1)*2 + mb) 15932 p_bc = pbc((mc - 1)*2 + mb) 15933 DO ma = 1, 3 15934 p_index = p_index + 1 15935 tmp = scale*prim(p_index) 15936 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15937 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15938 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15939 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15940 END DO 15941 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 15942 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 15943 END DO 15944 END DO 15945 END DO 15946 END SUBROUTINE block_3_2_1_1 15947! ************************************************************************************************** 15948!> \brief ... 15949!> \param kbd ... 15950!> \param kbc ... 15951!> \param kad ... 15952!> \param kac ... 15953!> \param pbd ... 15954!> \param pbc ... 15955!> \param pad ... 15956!> \param pac ... 15957!> \param prim ... 15958!> \param scale ... 15959! ************************************************************************************************** 15960 SUBROUTINE block_3_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 15961 REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(3*2), kac(3*1), & 15962 pbd(2*2), pbc(2*1), pad(3*2), & 15963 pac(3*1), prim(3*2*1*2), scale 15964 15965 INTEGER :: ma, mb, mc, md, p_index 15966 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 15967 15968 kbd(1:2*2) = 0.0_dp 15969 kbc(1:2*1) = 0.0_dp 15970 kad(1:3*2) = 0.0_dp 15971 kac(1:3*1) = 0.0_dp 15972 p_index = 0 15973 DO md = 1, 2 15974 DO mc = 1, 1 15975 DO mb = 1, 2 15976 ks_bd = 0.0_dp 15977 ks_bc = 0.0_dp 15978 p_bd = pbd((md - 1)*2 + mb) 15979 p_bc = pbc((mc - 1)*2 + mb) 15980 DO ma = 1, 3 15981 p_index = p_index + 1 15982 tmp = scale*prim(p_index) 15983 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 15984 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 15985 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 15986 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 15987 END DO 15988 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 15989 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 15990 END DO 15991 END DO 15992 END DO 15993 END SUBROUTINE block_3_2_1_2 15994! ************************************************************************************************** 15995!> \brief ... 15996!> \param kbd ... 15997!> \param kbc ... 15998!> \param kad ... 15999!> \param kac ... 16000!> \param pbd ... 16001!> \param pbc ... 16002!> \param pad ... 16003!> \param pac ... 16004!> \param prim ... 16005!> \param scale ... 16006! ************************************************************************************************** 16007 SUBROUTINE block_3_2_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16008 REAL(KIND=dp) :: kbd(2*3), kbc(2*1), kad(3*3), kac(3*1), & 16009 pbd(2*3), pbc(2*1), pad(3*3), & 16010 pac(3*1), prim(3*2*1*3), scale 16011 16012 INTEGER :: ma, mb, mc, md, p_index 16013 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16014 16015 kbd(1:2*3) = 0.0_dp 16016 kbc(1:2*1) = 0.0_dp 16017 kad(1:3*3) = 0.0_dp 16018 kac(1:3*1) = 0.0_dp 16019 p_index = 0 16020 DO md = 1, 3 16021 DO mc = 1, 1 16022 DO mb = 1, 2 16023 ks_bd = 0.0_dp 16024 ks_bc = 0.0_dp 16025 p_bd = pbd((md - 1)*2 + mb) 16026 p_bc = pbc((mc - 1)*2 + mb) 16027 DO ma = 1, 3 16028 p_index = p_index + 1 16029 tmp = scale*prim(p_index) 16030 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16031 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16032 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16033 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16034 END DO 16035 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 16036 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 16037 END DO 16038 END DO 16039 END DO 16040 END SUBROUTINE block_3_2_1_3 16041! ************************************************************************************************** 16042!> \brief ... 16043!> \param md_max ... 16044!> \param kbd ... 16045!> \param kbc ... 16046!> \param kad ... 16047!> \param kac ... 16048!> \param pbd ... 16049!> \param pbc ... 16050!> \param pad ... 16051!> \param pac ... 16052!> \param prim ... 16053!> \param scale ... 16054! ************************************************************************************************** 16055 SUBROUTINE block_3_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16056 INTEGER :: md_max 16057 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(3*md_max), kac(3*1), pbd(2*md_max), pbc(2*1), & 16058 pad(3*md_max), pac(3*1), prim(3*2*1*md_max), scale 16059 16060 INTEGER :: ma, mb, mc, md, p_index 16061 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16062 16063 kbd(1:2*md_max) = 0.0_dp 16064 kbc(1:2*1) = 0.0_dp 16065 kad(1:3*md_max) = 0.0_dp 16066 kac(1:3*1) = 0.0_dp 16067 p_index = 0 16068 DO md = 1, md_max 16069 DO mc = 1, 1 16070 DO mb = 1, 2 16071 ks_bd = 0.0_dp 16072 ks_bc = 0.0_dp 16073 p_bd = pbd((md - 1)*2 + mb) 16074 p_bc = pbc((mc - 1)*2 + mb) 16075 DO ma = 1, 3 16076 p_index = p_index + 1 16077 tmp = scale*prim(p_index) 16078 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16079 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16080 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16081 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16082 END DO 16083 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 16084 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 16085 END DO 16086 END DO 16087 END DO 16088 END SUBROUTINE block_3_2_1 16089! ************************************************************************************************** 16090!> \brief ... 16091!> \param kbd ... 16092!> \param kbc ... 16093!> \param kad ... 16094!> \param kac ... 16095!> \param pbd ... 16096!> \param pbc ... 16097!> \param pad ... 16098!> \param pac ... 16099!> \param prim ... 16100!> \param scale ... 16101! ************************************************************************************************** 16102 SUBROUTINE block_3_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16103 REAL(KIND=dp) :: kbd(2*1), kbc(2*2), kad(3*1), kac(3*2), & 16104 pbd(2*1), pbc(2*2), pad(3*1), & 16105 pac(3*2), prim(3*2*2*1), scale 16106 16107 INTEGER :: ma, mb, mc, md, p_index 16108 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16109 16110 kbd(1:2*1) = 0.0_dp 16111 kbc(1:2*2) = 0.0_dp 16112 kad(1:3*1) = 0.0_dp 16113 kac(1:3*2) = 0.0_dp 16114 p_index = 0 16115 DO md = 1, 1 16116 DO mc = 1, 2 16117 DO mb = 1, 2 16118 ks_bd = 0.0_dp 16119 ks_bc = 0.0_dp 16120 p_bd = pbd((md - 1)*2 + mb) 16121 p_bc = pbc((mc - 1)*2 + mb) 16122 DO ma = 1, 3 16123 p_index = p_index + 1 16124 tmp = scale*prim(p_index) 16125 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16126 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16127 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16128 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16129 END DO 16130 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 16131 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 16132 END DO 16133 END DO 16134 END DO 16135 END SUBROUTINE block_3_2_2_1 16136! ************************************************************************************************** 16137!> \brief ... 16138!> \param md_max ... 16139!> \param kbd ... 16140!> \param kbc ... 16141!> \param kad ... 16142!> \param kac ... 16143!> \param pbd ... 16144!> \param pbc ... 16145!> \param pad ... 16146!> \param pac ... 16147!> \param prim ... 16148!> \param scale ... 16149! ************************************************************************************************** 16150 SUBROUTINE block_3_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16151 INTEGER :: md_max 16152 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*2), kad(3*md_max), kac(3*2), pbd(2*md_max), pbc(2*2), & 16153 pad(3*md_max), pac(3*2), prim(3*2*2*md_max), scale 16154 16155 INTEGER :: ma, mb, mc, md, p_index 16156 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16157 16158 kbd(1:2*md_max) = 0.0_dp 16159 kbc(1:2*2) = 0.0_dp 16160 kad(1:3*md_max) = 0.0_dp 16161 kac(1:3*2) = 0.0_dp 16162 p_index = 0 16163 DO md = 1, md_max 16164 DO mc = 1, 2 16165 DO mb = 1, 2 16166 ks_bd = 0.0_dp 16167 ks_bc = 0.0_dp 16168 p_bd = pbd((md - 1)*2 + mb) 16169 p_bc = pbc((mc - 1)*2 + mb) 16170 DO ma = 1, 3 16171 p_index = p_index + 1 16172 tmp = scale*prim(p_index) 16173 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16174 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16175 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16176 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16177 END DO 16178 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 16179 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 16180 END DO 16181 END DO 16182 END DO 16183 END SUBROUTINE block_3_2_2 16184! ************************************************************************************************** 16185!> \brief ... 16186!> \param kbd ... 16187!> \param kbc ... 16188!> \param kad ... 16189!> \param kac ... 16190!> \param pbd ... 16191!> \param pbc ... 16192!> \param pad ... 16193!> \param pac ... 16194!> \param prim ... 16195!> \param scale ... 16196! ************************************************************************************************** 16197 SUBROUTINE block_3_2_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16198 REAL(KIND=dp) :: kbd(2*1), kbc(2*3), kad(3*1), kac(3*3), & 16199 pbd(2*1), pbc(2*3), pad(3*1), & 16200 pac(3*3), prim(3*2*3*1), scale 16201 16202 INTEGER :: ma, mb, mc, md, p_index 16203 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16204 16205 kbd(1:2*1) = 0.0_dp 16206 kbc(1:2*3) = 0.0_dp 16207 kad(1:3*1) = 0.0_dp 16208 kac(1:3*3) = 0.0_dp 16209 p_index = 0 16210 DO md = 1, 1 16211 DO mc = 1, 3 16212 DO mb = 1, 2 16213 ks_bd = 0.0_dp 16214 ks_bc = 0.0_dp 16215 p_bd = pbd((md - 1)*2 + mb) 16216 p_bc = pbc((mc - 1)*2 + mb) 16217 DO ma = 1, 3 16218 p_index = p_index + 1 16219 tmp = scale*prim(p_index) 16220 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16221 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16222 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16223 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16224 END DO 16225 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 16226 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 16227 END DO 16228 END DO 16229 END DO 16230 END SUBROUTINE block_3_2_3_1 16231! ************************************************************************************************** 16232!> \brief ... 16233!> \param md_max ... 16234!> \param kbd ... 16235!> \param kbc ... 16236!> \param kad ... 16237!> \param kac ... 16238!> \param pbd ... 16239!> \param pbc ... 16240!> \param pad ... 16241!> \param pac ... 16242!> \param prim ... 16243!> \param scale ... 16244! ************************************************************************************************** 16245 SUBROUTINE block_3_2_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16246 INTEGER :: md_max 16247 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*3), kad(3*md_max), kac(3*3), pbd(2*md_max), pbc(2*3), & 16248 pad(3*md_max), pac(3*3), prim(3*2*3*md_max), scale 16249 16250 INTEGER :: ma, mb, mc, md, p_index 16251 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16252 16253 kbd(1:2*md_max) = 0.0_dp 16254 kbc(1:2*3) = 0.0_dp 16255 kad(1:3*md_max) = 0.0_dp 16256 kac(1:3*3) = 0.0_dp 16257 p_index = 0 16258 DO md = 1, md_max 16259 DO mc = 1, 3 16260 DO mb = 1, 2 16261 ks_bd = 0.0_dp 16262 ks_bc = 0.0_dp 16263 p_bd = pbd((md - 1)*2 + mb) 16264 p_bc = pbc((mc - 1)*2 + mb) 16265 DO ma = 1, 3 16266 p_index = p_index + 1 16267 tmp = scale*prim(p_index) 16268 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16269 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16270 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16271 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16272 END DO 16273 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 16274 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 16275 END DO 16276 END DO 16277 END DO 16278 END SUBROUTINE block_3_2_3 16279! ************************************************************************************************** 16280!> \brief ... 16281!> \param mc_max ... 16282!> \param md_max ... 16283!> \param kbd ... 16284!> \param kbc ... 16285!> \param kad ... 16286!> \param kac ... 16287!> \param pbd ... 16288!> \param pbc ... 16289!> \param pad ... 16290!> \param pac ... 16291!> \param prim ... 16292!> \param scale ... 16293! ************************************************************************************************** 16294 SUBROUTINE block_3_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16295 INTEGER :: mc_max, md_max 16296 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(3*md_max), kac(3*mc_max), pbd(2*md_max), & 16297 pbc(2*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*2*mc_max*md_max), scale 16298 16299 INTEGER :: ma, mb, mc, md, p_index 16300 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16301 16302 kbd(1:2*md_max) = 0.0_dp 16303 kbc(1:2*mc_max) = 0.0_dp 16304 kad(1:3*md_max) = 0.0_dp 16305 kac(1:3*mc_max) = 0.0_dp 16306 p_index = 0 16307 DO md = 1, md_max 16308 DO mc = 1, mc_max 16309 DO mb = 1, 2 16310 ks_bd = 0.0_dp 16311 ks_bc = 0.0_dp 16312 p_bd = pbd((md - 1)*2 + mb) 16313 p_bc = pbc((mc - 1)*2 + mb) 16314 DO ma = 1, 3 16315 p_index = p_index + 1 16316 tmp = scale*prim(p_index) 16317 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16318 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16319 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16320 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16321 END DO 16322 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 16323 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 16324 END DO 16325 END DO 16326 END DO 16327 END SUBROUTINE block_3_2 16328! ************************************************************************************************** 16329!> \brief ... 16330!> \param kbd ... 16331!> \param kbc ... 16332!> \param kad ... 16333!> \param kac ... 16334!> \param pbd ... 16335!> \param pbc ... 16336!> \param pad ... 16337!> \param pac ... 16338!> \param prim ... 16339!> \param scale ... 16340! ************************************************************************************************** 16341 SUBROUTINE block_3_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16342 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(3*1), kac(3*1), & 16343 pbd(3*1), pbc(3*1), pad(3*1), & 16344 pac(3*1), prim(3*3*1*1), scale 16345 16346 INTEGER :: ma, mb, mc, md, p_index 16347 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16348 16349 kbd(1:3*1) = 0.0_dp 16350 kbc(1:3*1) = 0.0_dp 16351 kad(1:3*1) = 0.0_dp 16352 kac(1:3*1) = 0.0_dp 16353 p_index = 0 16354 DO md = 1, 1 16355 DO mc = 1, 1 16356 DO mb = 1, 3 16357 ks_bd = 0.0_dp 16358 ks_bc = 0.0_dp 16359 p_bd = pbd((md - 1)*3 + mb) 16360 p_bc = pbc((mc - 1)*3 + mb) 16361 DO ma = 1, 3 16362 p_index = p_index + 1 16363 tmp = scale*prim(p_index) 16364 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16365 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16366 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16367 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16368 END DO 16369 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 16370 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 16371 END DO 16372 END DO 16373 END DO 16374 END SUBROUTINE block_3_3_1_1 16375! ************************************************************************************************** 16376!> \brief ... 16377!> \param kbd ... 16378!> \param kbc ... 16379!> \param kad ... 16380!> \param kac ... 16381!> \param pbd ... 16382!> \param pbc ... 16383!> \param pad ... 16384!> \param pac ... 16385!> \param prim ... 16386!> \param scale ... 16387! ************************************************************************************************** 16388 SUBROUTINE block_3_3_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16389 REAL(KIND=dp) :: kbd(3*2), kbc(3*1), kad(3*2), kac(3*1), & 16390 pbd(3*2), pbc(3*1), pad(3*2), & 16391 pac(3*1), prim(3*3*1*2), scale 16392 16393 INTEGER :: ma, mb, mc, md, p_index 16394 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16395 16396 kbd(1:3*2) = 0.0_dp 16397 kbc(1:3*1) = 0.0_dp 16398 kad(1:3*2) = 0.0_dp 16399 kac(1:3*1) = 0.0_dp 16400 p_index = 0 16401 DO md = 1, 2 16402 DO mc = 1, 1 16403 DO mb = 1, 3 16404 ks_bd = 0.0_dp 16405 ks_bc = 0.0_dp 16406 p_bd = pbd((md - 1)*3 + mb) 16407 p_bc = pbc((mc - 1)*3 + mb) 16408 DO ma = 1, 3 16409 p_index = p_index + 1 16410 tmp = scale*prim(p_index) 16411 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16412 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16413 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16414 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16415 END DO 16416 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 16417 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 16418 END DO 16419 END DO 16420 END DO 16421 END SUBROUTINE block_3_3_1_2 16422! ************************************************************************************************** 16423!> \brief ... 16424!> \param md_max ... 16425!> \param kbd ... 16426!> \param kbc ... 16427!> \param kad ... 16428!> \param kac ... 16429!> \param pbd ... 16430!> \param pbc ... 16431!> \param pad ... 16432!> \param pac ... 16433!> \param prim ... 16434!> \param scale ... 16435! ************************************************************************************************** 16436 SUBROUTINE block_3_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16437 INTEGER :: md_max 16438 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(3*md_max), kac(3*1), pbd(3*md_max), pbc(3*1), & 16439 pad(3*md_max), pac(3*1), prim(3*3*1*md_max), scale 16440 16441 INTEGER :: ma, mb, mc, md, p_index 16442 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16443 16444 kbd(1:3*md_max) = 0.0_dp 16445 kbc(1:3*1) = 0.0_dp 16446 kad(1:3*md_max) = 0.0_dp 16447 kac(1:3*1) = 0.0_dp 16448 p_index = 0 16449 DO md = 1, md_max 16450 DO mc = 1, 1 16451 DO mb = 1, 3 16452 ks_bd = 0.0_dp 16453 ks_bc = 0.0_dp 16454 p_bd = pbd((md - 1)*3 + mb) 16455 p_bc = pbc((mc - 1)*3 + mb) 16456 DO ma = 1, 3 16457 p_index = p_index + 1 16458 tmp = scale*prim(p_index) 16459 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16460 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16461 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16462 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16463 END DO 16464 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 16465 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 16466 END DO 16467 END DO 16468 END DO 16469 END SUBROUTINE block_3_3_1 16470! ************************************************************************************************** 16471!> \brief ... 16472!> \param kbd ... 16473!> \param kbc ... 16474!> \param kad ... 16475!> \param kac ... 16476!> \param pbd ... 16477!> \param pbc ... 16478!> \param pad ... 16479!> \param pac ... 16480!> \param prim ... 16481!> \param scale ... 16482! ************************************************************************************************** 16483 SUBROUTINE block_3_3_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16484 REAL(KIND=dp) :: kbd(3*1), kbc(3*2), kad(3*1), kac(3*2), & 16485 pbd(3*1), pbc(3*2), pad(3*1), & 16486 pac(3*2), prim(3*3*2*1), scale 16487 16488 INTEGER :: ma, mb, mc, md, p_index 16489 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16490 16491 kbd(1:3*1) = 0.0_dp 16492 kbc(1:3*2) = 0.0_dp 16493 kad(1:3*1) = 0.0_dp 16494 kac(1:3*2) = 0.0_dp 16495 p_index = 0 16496 DO md = 1, 1 16497 DO mc = 1, 2 16498 DO mb = 1, 3 16499 ks_bd = 0.0_dp 16500 ks_bc = 0.0_dp 16501 p_bd = pbd((md - 1)*3 + mb) 16502 p_bc = pbc((mc - 1)*3 + mb) 16503 DO ma = 1, 3 16504 p_index = p_index + 1 16505 tmp = scale*prim(p_index) 16506 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16507 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16508 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16509 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16510 END DO 16511 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 16512 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 16513 END DO 16514 END DO 16515 END DO 16516 END SUBROUTINE block_3_3_2_1 16517! ************************************************************************************************** 16518!> \brief ... 16519!> \param md_max ... 16520!> \param kbd ... 16521!> \param kbc ... 16522!> \param kad ... 16523!> \param kac ... 16524!> \param pbd ... 16525!> \param pbc ... 16526!> \param pad ... 16527!> \param pac ... 16528!> \param prim ... 16529!> \param scale ... 16530! ************************************************************************************************** 16531 SUBROUTINE block_3_3_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16532 INTEGER :: md_max 16533 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*2), kad(3*md_max), kac(3*2), pbd(3*md_max), pbc(3*2), & 16534 pad(3*md_max), pac(3*2), prim(3*3*2*md_max), scale 16535 16536 INTEGER :: ma, mb, mc, md, p_index 16537 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16538 16539 kbd(1:3*md_max) = 0.0_dp 16540 kbc(1:3*2) = 0.0_dp 16541 kad(1:3*md_max) = 0.0_dp 16542 kac(1:3*2) = 0.0_dp 16543 p_index = 0 16544 DO md = 1, md_max 16545 DO mc = 1, 2 16546 DO mb = 1, 3 16547 ks_bd = 0.0_dp 16548 ks_bc = 0.0_dp 16549 p_bd = pbd((md - 1)*3 + mb) 16550 p_bc = pbc((mc - 1)*3 + mb) 16551 DO ma = 1, 3 16552 p_index = p_index + 1 16553 tmp = scale*prim(p_index) 16554 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16555 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16556 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16557 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16558 END DO 16559 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 16560 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 16561 END DO 16562 END DO 16563 END DO 16564 END SUBROUTINE block_3_3_2 16565! ************************************************************************************************** 16566!> \brief ... 16567!> \param mc_max ... 16568!> \param md_max ... 16569!> \param kbd ... 16570!> \param kbc ... 16571!> \param kad ... 16572!> \param kac ... 16573!> \param pbd ... 16574!> \param pbc ... 16575!> \param pad ... 16576!> \param pac ... 16577!> \param prim ... 16578!> \param scale ... 16579! ************************************************************************************************** 16580 SUBROUTINE block_3_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16581 INTEGER :: mc_max, md_max 16582 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(3*md_max), kac(3*mc_max), pbd(3*md_max), & 16583 pbc(3*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*3*mc_max*md_max), scale 16584 16585 INTEGER :: ma, mb, mc, md, p_index 16586 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16587 16588 kbd(1:3*md_max) = 0.0_dp 16589 kbc(1:3*mc_max) = 0.0_dp 16590 kad(1:3*md_max) = 0.0_dp 16591 kac(1:3*mc_max) = 0.0_dp 16592 p_index = 0 16593 DO md = 1, md_max 16594 DO mc = 1, mc_max 16595 DO mb = 1, 3 16596 ks_bd = 0.0_dp 16597 ks_bc = 0.0_dp 16598 p_bd = pbd((md - 1)*3 + mb) 16599 p_bc = pbc((mc - 1)*3 + mb) 16600 DO ma = 1, 3 16601 p_index = p_index + 1 16602 tmp = scale*prim(p_index) 16603 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16604 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16605 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16606 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16607 END DO 16608 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 16609 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 16610 END DO 16611 END DO 16612 END DO 16613 END SUBROUTINE block_3_3 16614! ************************************************************************************************** 16615!> \brief ... 16616!> \param kbd ... 16617!> \param kbc ... 16618!> \param kad ... 16619!> \param kac ... 16620!> \param pbd ... 16621!> \param pbc ... 16622!> \param pad ... 16623!> \param pac ... 16624!> \param prim ... 16625!> \param scale ... 16626! ************************************************************************************************** 16627 SUBROUTINE block_3_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16628 REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(3*1), kac(3*1), & 16629 pbd(4*1), pbc(4*1), pad(3*1), & 16630 pac(3*1), prim(3*4*1*1), scale 16631 16632 INTEGER :: ma, mb, mc, md, p_index 16633 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16634 16635 kbd(1:4*1) = 0.0_dp 16636 kbc(1:4*1) = 0.0_dp 16637 kad(1:3*1) = 0.0_dp 16638 kac(1:3*1) = 0.0_dp 16639 p_index = 0 16640 DO md = 1, 1 16641 DO mc = 1, 1 16642 DO mb = 1, 4 16643 ks_bd = 0.0_dp 16644 ks_bc = 0.0_dp 16645 p_bd = pbd((md - 1)*4 + mb) 16646 p_bc = pbc((mc - 1)*4 + mb) 16647 DO ma = 1, 3 16648 p_index = p_index + 1 16649 tmp = scale*prim(p_index) 16650 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16651 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16652 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16653 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16654 END DO 16655 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 16656 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 16657 END DO 16658 END DO 16659 END DO 16660 END SUBROUTINE block_3_4_1_1 16661! ************************************************************************************************** 16662!> \brief ... 16663!> \param md_max ... 16664!> \param kbd ... 16665!> \param kbc ... 16666!> \param kad ... 16667!> \param kac ... 16668!> \param pbd ... 16669!> \param pbc ... 16670!> \param pad ... 16671!> \param pac ... 16672!> \param prim ... 16673!> \param scale ... 16674! ************************************************************************************************** 16675 SUBROUTINE block_3_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16676 INTEGER :: md_max 16677 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*1), kad(3*md_max), kac(3*1), pbd(4*md_max), pbc(4*1), & 16678 pad(3*md_max), pac(3*1), prim(3*4*1*md_max), scale 16679 16680 INTEGER :: ma, mb, mc, md, p_index 16681 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16682 16683 kbd(1:4*md_max) = 0.0_dp 16684 kbc(1:4*1) = 0.0_dp 16685 kad(1:3*md_max) = 0.0_dp 16686 kac(1:3*1) = 0.0_dp 16687 p_index = 0 16688 DO md = 1, md_max 16689 DO mc = 1, 1 16690 DO mb = 1, 4 16691 ks_bd = 0.0_dp 16692 ks_bc = 0.0_dp 16693 p_bd = pbd((md - 1)*4 + mb) 16694 p_bc = pbc((mc - 1)*4 + mb) 16695 DO ma = 1, 3 16696 p_index = p_index + 1 16697 tmp = scale*prim(p_index) 16698 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16699 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16700 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16701 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16702 END DO 16703 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 16704 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 16705 END DO 16706 END DO 16707 END DO 16708 END SUBROUTINE block_3_4_1 16709! ************************************************************************************************** 16710!> \brief ... 16711!> \param mc_max ... 16712!> \param md_max ... 16713!> \param kbd ... 16714!> \param kbc ... 16715!> \param kad ... 16716!> \param kac ... 16717!> \param pbd ... 16718!> \param pbc ... 16719!> \param pad ... 16720!> \param pac ... 16721!> \param prim ... 16722!> \param scale ... 16723! ************************************************************************************************** 16724 SUBROUTINE block_3_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16725 INTEGER :: mc_max, md_max 16726 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(3*md_max), kac(3*mc_max), pbd(4*md_max), & 16727 pbc(4*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*4*mc_max*md_max), scale 16728 16729 INTEGER :: ma, mb, mc, md, p_index 16730 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16731 16732 kbd(1:4*md_max) = 0.0_dp 16733 kbc(1:4*mc_max) = 0.0_dp 16734 kad(1:3*md_max) = 0.0_dp 16735 kac(1:3*mc_max) = 0.0_dp 16736 p_index = 0 16737 DO md = 1, md_max 16738 DO mc = 1, mc_max 16739 DO mb = 1, 4 16740 ks_bd = 0.0_dp 16741 ks_bc = 0.0_dp 16742 p_bd = pbd((md - 1)*4 + mb) 16743 p_bc = pbc((mc - 1)*4 + mb) 16744 DO ma = 1, 3 16745 p_index = p_index + 1 16746 tmp = scale*prim(p_index) 16747 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16748 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16749 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16750 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16751 END DO 16752 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 16753 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 16754 END DO 16755 END DO 16756 END DO 16757 END SUBROUTINE block_3_4 16758! ************************************************************************************************** 16759!> \brief ... 16760!> \param kbd ... 16761!> \param kbc ... 16762!> \param kad ... 16763!> \param kac ... 16764!> \param pbd ... 16765!> \param pbc ... 16766!> \param pad ... 16767!> \param pac ... 16768!> \param prim ... 16769!> \param scale ... 16770! ************************************************************************************************** 16771 SUBROUTINE block_3_5_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16772 REAL(KIND=dp) :: kbd(5*1), kbc(5*1), kad(3*1), kac(3*1), & 16773 pbd(5*1), pbc(5*1), pad(3*1), & 16774 pac(3*1), prim(3*5*1*1), scale 16775 16776 INTEGER :: ma, mb, mc, md, p_index 16777 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16778 16779 kbd(1:5*1) = 0.0_dp 16780 kbc(1:5*1) = 0.0_dp 16781 kad(1:3*1) = 0.0_dp 16782 kac(1:3*1) = 0.0_dp 16783 p_index = 0 16784 DO md = 1, 1 16785 DO mc = 1, 1 16786 DO mb = 1, 5 16787 ks_bd = 0.0_dp 16788 ks_bc = 0.0_dp 16789 p_bd = pbd((md - 1)*5 + mb) 16790 p_bc = pbc((mc - 1)*5 + mb) 16791 DO ma = 1, 3 16792 p_index = p_index + 1 16793 tmp = scale*prim(p_index) 16794 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16795 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16796 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16797 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16798 END DO 16799 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 16800 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 16801 END DO 16802 END DO 16803 END DO 16804 END SUBROUTINE block_3_5_1_1 16805! ************************************************************************************************** 16806!> \brief ... 16807!> \param md_max ... 16808!> \param kbd ... 16809!> \param kbc ... 16810!> \param kad ... 16811!> \param kac ... 16812!> \param pbd ... 16813!> \param pbc ... 16814!> \param pad ... 16815!> \param pac ... 16816!> \param prim ... 16817!> \param scale ... 16818! ************************************************************************************************** 16819 SUBROUTINE block_3_5_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16820 INTEGER :: md_max 16821 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(3*md_max), kac(3*1), pbd(5*md_max), pbc(5*1), & 16822 pad(3*md_max), pac(3*1), prim(3*5*1*md_max), scale 16823 16824 INTEGER :: ma, mb, mc, md, p_index 16825 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16826 16827 kbd(1:5*md_max) = 0.0_dp 16828 kbc(1:5*1) = 0.0_dp 16829 kad(1:3*md_max) = 0.0_dp 16830 kac(1:3*1) = 0.0_dp 16831 p_index = 0 16832 DO md = 1, md_max 16833 DO mc = 1, 1 16834 DO mb = 1, 5 16835 ks_bd = 0.0_dp 16836 ks_bc = 0.0_dp 16837 p_bd = pbd((md - 1)*5 + mb) 16838 p_bc = pbc((mc - 1)*5 + mb) 16839 DO ma = 1, 3 16840 p_index = p_index + 1 16841 tmp = scale*prim(p_index) 16842 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16843 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16844 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16845 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16846 END DO 16847 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 16848 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 16849 END DO 16850 END DO 16851 END DO 16852 END SUBROUTINE block_3_5_1 16853! ************************************************************************************************** 16854!> \brief ... 16855!> \param mc_max ... 16856!> \param md_max ... 16857!> \param kbd ... 16858!> \param kbc ... 16859!> \param kad ... 16860!> \param kac ... 16861!> \param pbd ... 16862!> \param pbc ... 16863!> \param pad ... 16864!> \param pac ... 16865!> \param prim ... 16866!> \param scale ... 16867! ************************************************************************************************** 16868 SUBROUTINE block_3_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16869 INTEGER :: mc_max, md_max 16870 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(3*md_max), kac(3*mc_max), pbd(5*md_max), & 16871 pbc(5*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*5*mc_max*md_max), scale 16872 16873 INTEGER :: ma, mb, mc, md, p_index 16874 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16875 16876 kbd(1:5*md_max) = 0.0_dp 16877 kbc(1:5*mc_max) = 0.0_dp 16878 kad(1:3*md_max) = 0.0_dp 16879 kac(1:3*mc_max) = 0.0_dp 16880 p_index = 0 16881 DO md = 1, md_max 16882 DO mc = 1, mc_max 16883 DO mb = 1, 5 16884 ks_bd = 0.0_dp 16885 ks_bc = 0.0_dp 16886 p_bd = pbd((md - 1)*5 + mb) 16887 p_bc = pbc((mc - 1)*5 + mb) 16888 DO ma = 1, 3 16889 p_index = p_index + 1 16890 tmp = scale*prim(p_index) 16891 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16892 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16893 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16894 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16895 END DO 16896 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 16897 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 16898 END DO 16899 END DO 16900 END DO 16901 END SUBROUTINE block_3_5 16902! ************************************************************************************************** 16903!> \brief ... 16904!> \param kbd ... 16905!> \param kbc ... 16906!> \param kad ... 16907!> \param kac ... 16908!> \param pbd ... 16909!> \param pbc ... 16910!> \param pad ... 16911!> \param pac ... 16912!> \param prim ... 16913!> \param scale ... 16914! ************************************************************************************************** 16915 SUBROUTINE block_3_6_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16916 REAL(KIND=dp) :: kbd(6*1), kbc(6*1), kad(3*1), kac(3*1), & 16917 pbd(6*1), pbc(6*1), pad(3*1), & 16918 pac(3*1), prim(3*6*1*1), scale 16919 16920 INTEGER :: ma, mb, mc, md, p_index 16921 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16922 16923 kbd(1:6*1) = 0.0_dp 16924 kbc(1:6*1) = 0.0_dp 16925 kad(1:3*1) = 0.0_dp 16926 kac(1:3*1) = 0.0_dp 16927 p_index = 0 16928 DO md = 1, 1 16929 DO mc = 1, 1 16930 DO mb = 1, 6 16931 ks_bd = 0.0_dp 16932 ks_bc = 0.0_dp 16933 p_bd = pbd((md - 1)*6 + mb) 16934 p_bc = pbc((mc - 1)*6 + mb) 16935 DO ma = 1, 3 16936 p_index = p_index + 1 16937 tmp = scale*prim(p_index) 16938 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16939 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16940 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16941 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16942 END DO 16943 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 16944 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 16945 END DO 16946 END DO 16947 END DO 16948 END SUBROUTINE block_3_6_1_1 16949! ************************************************************************************************** 16950!> \brief ... 16951!> \param md_max ... 16952!> \param kbd ... 16953!> \param kbc ... 16954!> \param kad ... 16955!> \param kac ... 16956!> \param pbd ... 16957!> \param pbc ... 16958!> \param pad ... 16959!> \param pac ... 16960!> \param prim ... 16961!> \param scale ... 16962! ************************************************************************************************** 16963 SUBROUTINE block_3_6_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 16964 INTEGER :: md_max 16965 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*1), kad(3*md_max), kac(3*1), pbd(6*md_max), pbc(6*1), & 16966 pad(3*md_max), pac(3*1), prim(3*6*1*md_max), scale 16967 16968 INTEGER :: ma, mb, mc, md, p_index 16969 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 16970 16971 kbd(1:6*md_max) = 0.0_dp 16972 kbc(1:6*1) = 0.0_dp 16973 kad(1:3*md_max) = 0.0_dp 16974 kac(1:3*1) = 0.0_dp 16975 p_index = 0 16976 DO md = 1, md_max 16977 DO mc = 1, 1 16978 DO mb = 1, 6 16979 ks_bd = 0.0_dp 16980 ks_bc = 0.0_dp 16981 p_bd = pbd((md - 1)*6 + mb) 16982 p_bc = pbc((mc - 1)*6 + mb) 16983 DO ma = 1, 3 16984 p_index = p_index + 1 16985 tmp = scale*prim(p_index) 16986 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 16987 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 16988 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 16989 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 16990 END DO 16991 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 16992 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 16993 END DO 16994 END DO 16995 END DO 16996 END SUBROUTINE block_3_6_1 16997! ************************************************************************************************** 16998!> \brief ... 16999!> \param mc_max ... 17000!> \param md_max ... 17001!> \param kbd ... 17002!> \param kbc ... 17003!> \param kad ... 17004!> \param kac ... 17005!> \param pbd ... 17006!> \param pbc ... 17007!> \param pad ... 17008!> \param pac ... 17009!> \param prim ... 17010!> \param scale ... 17011! ************************************************************************************************** 17012 SUBROUTINE block_3_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17013 INTEGER :: mc_max, md_max 17014 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(3*md_max), kac(3*mc_max), pbd(6*md_max), & 17015 pbc(6*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*6*mc_max*md_max), scale 17016 17017 INTEGER :: ma, mb, mc, md, p_index 17018 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17019 17020 kbd(1:6*md_max) = 0.0_dp 17021 kbc(1:6*mc_max) = 0.0_dp 17022 kad(1:3*md_max) = 0.0_dp 17023 kac(1:3*mc_max) = 0.0_dp 17024 p_index = 0 17025 DO md = 1, md_max 17026 DO mc = 1, mc_max 17027 DO mb = 1, 6 17028 ks_bd = 0.0_dp 17029 ks_bc = 0.0_dp 17030 p_bd = pbd((md - 1)*6 + mb) 17031 p_bc = pbc((mc - 1)*6 + mb) 17032 DO ma = 1, 3 17033 p_index = p_index + 1 17034 tmp = scale*prim(p_index) 17035 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 17036 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 17037 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 17038 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 17039 END DO 17040 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 17041 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 17042 END DO 17043 END DO 17044 END DO 17045 END SUBROUTINE block_3_6 17046! ************************************************************************************************** 17047!> \brief ... 17048!> \param mc_max ... 17049!> \param md_max ... 17050!> \param kbd ... 17051!> \param kbc ... 17052!> \param kad ... 17053!> \param kac ... 17054!> \param pbd ... 17055!> \param pbc ... 17056!> \param pad ... 17057!> \param pac ... 17058!> \param prim ... 17059!> \param scale ... 17060! ************************************************************************************************** 17061 SUBROUTINE block_3_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17062 INTEGER :: mc_max, md_max 17063 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(3*md_max), kac(3*mc_max), pbd(7*md_max), & 17064 pbc(7*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*7*mc_max*md_max), scale 17065 17066 INTEGER :: ma, mb, mc, md, p_index 17067 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17068 17069 kbd(1:7*md_max) = 0.0_dp 17070 kbc(1:7*mc_max) = 0.0_dp 17071 kad(1:3*md_max) = 0.0_dp 17072 kac(1:3*mc_max) = 0.0_dp 17073 p_index = 0 17074 DO md = 1, md_max 17075 DO mc = 1, mc_max 17076 DO mb = 1, 7 17077 ks_bd = 0.0_dp 17078 ks_bc = 0.0_dp 17079 p_bd = pbd((md - 1)*7 + mb) 17080 p_bc = pbc((mc - 1)*7 + mb) 17081 DO ma = 1, 3 17082 p_index = p_index + 1 17083 tmp = scale*prim(p_index) 17084 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 17085 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 17086 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 17087 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 17088 END DO 17089 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 17090 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 17091 END DO 17092 END DO 17093 END DO 17094 END SUBROUTINE block_3_7 17095! ************************************************************************************************** 17096!> \brief ... 17097!> \param mc_max ... 17098!> \param md_max ... 17099!> \param kbd ... 17100!> \param kbc ... 17101!> \param kad ... 17102!> \param kac ... 17103!> \param pbd ... 17104!> \param pbc ... 17105!> \param pad ... 17106!> \param pac ... 17107!> \param prim ... 17108!> \param scale ... 17109! ************************************************************************************************** 17110 SUBROUTINE block_3_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17111 INTEGER :: mc_max, md_max 17112 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(3*md_max), kac(3*mc_max), pbd(9*md_max), & 17113 pbc(9*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*9*mc_max*md_max), scale 17114 17115 INTEGER :: ma, mb, mc, md, p_index 17116 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17117 17118 kbd(1:9*md_max) = 0.0_dp 17119 kbc(1:9*mc_max) = 0.0_dp 17120 kad(1:3*md_max) = 0.0_dp 17121 kac(1:3*mc_max) = 0.0_dp 17122 p_index = 0 17123 DO md = 1, md_max 17124 DO mc = 1, mc_max 17125 DO mb = 1, 9 17126 ks_bd = 0.0_dp 17127 ks_bc = 0.0_dp 17128 p_bd = pbd((md - 1)*9 + mb) 17129 p_bc = pbc((mc - 1)*9 + mb) 17130 DO ma = 1, 3 17131 p_index = p_index + 1 17132 tmp = scale*prim(p_index) 17133 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 17134 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 17135 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 17136 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 17137 END DO 17138 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 17139 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 17140 END DO 17141 END DO 17142 END DO 17143 END SUBROUTINE block_3_9 17144! ************************************************************************************************** 17145!> \brief ... 17146!> \param mc_max ... 17147!> \param md_max ... 17148!> \param kbd ... 17149!> \param kbc ... 17150!> \param kad ... 17151!> \param kac ... 17152!> \param pbd ... 17153!> \param pbc ... 17154!> \param pad ... 17155!> \param pac ... 17156!> \param prim ... 17157!> \param scale ... 17158! ************************************************************************************************** 17159 SUBROUTINE block_3_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17160 INTEGER :: mc_max, md_max 17161 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(3*md_max), kac(3*mc_max), & 17162 pbd(10*md_max), pbc(10*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*10*mc_max*md_max), & 17163 scale 17164 17165 INTEGER :: ma, mb, mc, md, p_index 17166 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17167 17168 kbd(1:10*md_max) = 0.0_dp 17169 kbc(1:10*mc_max) = 0.0_dp 17170 kad(1:3*md_max) = 0.0_dp 17171 kac(1:3*mc_max) = 0.0_dp 17172 p_index = 0 17173 DO md = 1, md_max 17174 DO mc = 1, mc_max 17175 DO mb = 1, 10 17176 ks_bd = 0.0_dp 17177 ks_bc = 0.0_dp 17178 p_bd = pbd((md - 1)*10 + mb) 17179 p_bc = pbc((mc - 1)*10 + mb) 17180 DO ma = 1, 3 17181 p_index = p_index + 1 17182 tmp = scale*prim(p_index) 17183 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 17184 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 17185 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 17186 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 17187 END DO 17188 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 17189 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 17190 END DO 17191 END DO 17192 END DO 17193 END SUBROUTINE block_3_10 17194! ************************************************************************************************** 17195!> \brief ... 17196!> \param mc_max ... 17197!> \param md_max ... 17198!> \param kbd ... 17199!> \param kbc ... 17200!> \param kad ... 17201!> \param kac ... 17202!> \param pbd ... 17203!> \param pbc ... 17204!> \param pad ... 17205!> \param pac ... 17206!> \param prim ... 17207!> \param scale ... 17208! ************************************************************************************************** 17209 SUBROUTINE block_3_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17210 INTEGER :: mc_max, md_max 17211 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(3*md_max), kac(3*mc_max), & 17212 pbd(11*md_max), pbc(11*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*11*mc_max*md_max), & 17213 scale 17214 17215 INTEGER :: ma, mb, mc, md, p_index 17216 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17217 17218 kbd(1:11*md_max) = 0.0_dp 17219 kbc(1:11*mc_max) = 0.0_dp 17220 kad(1:3*md_max) = 0.0_dp 17221 kac(1:3*mc_max) = 0.0_dp 17222 p_index = 0 17223 DO md = 1, md_max 17224 DO mc = 1, mc_max 17225 DO mb = 1, 11 17226 ks_bd = 0.0_dp 17227 ks_bc = 0.0_dp 17228 p_bd = pbd((md - 1)*11 + mb) 17229 p_bc = pbc((mc - 1)*11 + mb) 17230 DO ma = 1, 3 17231 p_index = p_index + 1 17232 tmp = scale*prim(p_index) 17233 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 17234 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 17235 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 17236 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 17237 END DO 17238 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 17239 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 17240 END DO 17241 END DO 17242 END DO 17243 END SUBROUTINE block_3_11 17244! ************************************************************************************************** 17245!> \brief ... 17246!> \param mc_max ... 17247!> \param md_max ... 17248!> \param kbd ... 17249!> \param kbc ... 17250!> \param kad ... 17251!> \param kac ... 17252!> \param pbd ... 17253!> \param pbc ... 17254!> \param pad ... 17255!> \param pac ... 17256!> \param prim ... 17257!> \param scale ... 17258! ************************************************************************************************** 17259 SUBROUTINE block_3_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17260 INTEGER :: mc_max, md_max 17261 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(3*md_max), kac(3*mc_max), & 17262 pbd(15*md_max), pbc(15*mc_max), pad(3*md_max), pac(3*mc_max), prim(3*15*mc_max*md_max), & 17263 scale 17264 17265 INTEGER :: ma, mb, mc, md, p_index 17266 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17267 17268 kbd(1:15*md_max) = 0.0_dp 17269 kbc(1:15*mc_max) = 0.0_dp 17270 kad(1:3*md_max) = 0.0_dp 17271 kac(1:3*mc_max) = 0.0_dp 17272 p_index = 0 17273 DO md = 1, md_max 17274 DO mc = 1, mc_max 17275 DO mb = 1, 15 17276 ks_bd = 0.0_dp 17277 ks_bc = 0.0_dp 17278 p_bd = pbd((md - 1)*15 + mb) 17279 p_bc = pbc((mc - 1)*15 + mb) 17280 DO ma = 1, 3 17281 p_index = p_index + 1 17282 tmp = scale*prim(p_index) 17283 ks_bc = ks_bc + tmp*pad((md - 1)*3 + ma) 17284 ks_bd = ks_bd + tmp*pac((mc - 1)*3 + ma) 17285 kad((md - 1)*3 + ma) = kad((md - 1)*3 + ma) - tmp*p_bc 17286 kac((mc - 1)*3 + ma) = kac((mc - 1)*3 + ma) - tmp*p_bd 17287 END DO 17288 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 17289 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 17290 END DO 17291 END DO 17292 END DO 17293 END SUBROUTINE block_3_15 17294! ************************************************************************************************** 17295!> \brief ... 17296!> \param kbd ... 17297!> \param kbc ... 17298!> \param kad ... 17299!> \param kac ... 17300!> \param pbd ... 17301!> \param pbc ... 17302!> \param pad ... 17303!> \param pac ... 17304!> \param prim ... 17305!> \param scale ... 17306! ************************************************************************************************** 17307 SUBROUTINE block_4_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17308 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(4*1), kac(4*1), & 17309 pbd(1*1), pbc(1*1), pad(4*1), & 17310 pac(4*1), prim(4*1*1*1), scale 17311 17312 INTEGER :: ma, mb, mc, md, p_index 17313 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17314 17315 kbd(1:1*1) = 0.0_dp 17316 kbc(1:1*1) = 0.0_dp 17317 kad(1:4*1) = 0.0_dp 17318 kac(1:4*1) = 0.0_dp 17319 p_index = 0 17320 DO md = 1, 1 17321 DO mc = 1, 1 17322 DO mb = 1, 1 17323 ks_bd = 0.0_dp 17324 ks_bc = 0.0_dp 17325 p_bd = pbd((md - 1)*1 + mb) 17326 p_bc = pbc((mc - 1)*1 + mb) 17327 DO ma = 1, 4 17328 p_index = p_index + 1 17329 tmp = scale*prim(p_index) 17330 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17331 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17332 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17333 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17334 END DO 17335 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17336 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17337 END DO 17338 END DO 17339 END DO 17340 END SUBROUTINE block_4_1_1_1 17341! ************************************************************************************************** 17342!> \brief ... 17343!> \param kbd ... 17344!> \param kbc ... 17345!> \param kad ... 17346!> \param kac ... 17347!> \param pbd ... 17348!> \param pbc ... 17349!> \param pad ... 17350!> \param pac ... 17351!> \param prim ... 17352!> \param scale ... 17353! ************************************************************************************************** 17354 SUBROUTINE block_4_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17355 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(4*2), kac(4*1), & 17356 pbd(1*2), pbc(1*1), pad(4*2), & 17357 pac(4*1), prim(4*1*1*2), scale 17358 17359 INTEGER :: ma, mb, mc, md, p_index 17360 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17361 17362 kbd(1:1*2) = 0.0_dp 17363 kbc(1:1*1) = 0.0_dp 17364 kad(1:4*2) = 0.0_dp 17365 kac(1:4*1) = 0.0_dp 17366 p_index = 0 17367 DO md = 1, 2 17368 DO mc = 1, 1 17369 DO mb = 1, 1 17370 ks_bd = 0.0_dp 17371 ks_bc = 0.0_dp 17372 p_bd = pbd((md - 1)*1 + mb) 17373 p_bc = pbc((mc - 1)*1 + mb) 17374 DO ma = 1, 4 17375 p_index = p_index + 1 17376 tmp = scale*prim(p_index) 17377 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17378 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17379 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17380 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17381 END DO 17382 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17383 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17384 END DO 17385 END DO 17386 END DO 17387 END SUBROUTINE block_4_1_1_2 17388! ************************************************************************************************** 17389!> \brief ... 17390!> \param kbd ... 17391!> \param kbc ... 17392!> \param kad ... 17393!> \param kac ... 17394!> \param pbd ... 17395!> \param pbc ... 17396!> \param pad ... 17397!> \param pac ... 17398!> \param prim ... 17399!> \param scale ... 17400! ************************************************************************************************** 17401 SUBROUTINE block_4_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17402 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(4*3), kac(4*1), & 17403 pbd(1*3), pbc(1*1), pad(4*3), & 17404 pac(4*1), prim(4*1*1*3), scale 17405 17406 INTEGER :: ma, mb, mc, md, p_index 17407 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17408 17409 kbd(1:1*3) = 0.0_dp 17410 kbc(1:1*1) = 0.0_dp 17411 kad(1:4*3) = 0.0_dp 17412 kac(1:4*1) = 0.0_dp 17413 p_index = 0 17414 DO md = 1, 3 17415 DO mc = 1, 1 17416 DO mb = 1, 1 17417 ks_bd = 0.0_dp 17418 ks_bc = 0.0_dp 17419 p_bd = pbd((md - 1)*1 + mb) 17420 p_bc = pbc((mc - 1)*1 + mb) 17421 DO ma = 1, 4 17422 p_index = p_index + 1 17423 tmp = scale*prim(p_index) 17424 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17425 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17426 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17427 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17428 END DO 17429 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17430 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17431 END DO 17432 END DO 17433 END DO 17434 END SUBROUTINE block_4_1_1_3 17435! ************************************************************************************************** 17436!> \brief ... 17437!> \param kbd ... 17438!> \param kbc ... 17439!> \param kad ... 17440!> \param kac ... 17441!> \param pbd ... 17442!> \param pbc ... 17443!> \param pad ... 17444!> \param pac ... 17445!> \param prim ... 17446!> \param scale ... 17447! ************************************************************************************************** 17448 SUBROUTINE block_4_1_1_4(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17449 REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(4*4), kac(4*1), & 17450 pbd(1*4), pbc(1*1), pad(4*4), & 17451 pac(4*1), prim(4*1*1*4), scale 17452 17453 INTEGER :: ma, mb, mc, md, p_index 17454 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17455 17456 kbd(1:1*4) = 0.0_dp 17457 kbc(1:1*1) = 0.0_dp 17458 kad(1:4*4) = 0.0_dp 17459 kac(1:4*1) = 0.0_dp 17460 p_index = 0 17461 DO md = 1, 4 17462 DO mc = 1, 1 17463 DO mb = 1, 1 17464 ks_bd = 0.0_dp 17465 ks_bc = 0.0_dp 17466 p_bd = pbd((md - 1)*1 + mb) 17467 p_bc = pbc((mc - 1)*1 + mb) 17468 DO ma = 1, 4 17469 p_index = p_index + 1 17470 tmp = scale*prim(p_index) 17471 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17472 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17473 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17474 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17475 END DO 17476 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17477 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17478 END DO 17479 END DO 17480 END DO 17481 END SUBROUTINE block_4_1_1_4 17482! ************************************************************************************************** 17483!> \brief ... 17484!> \param md_max ... 17485!> \param kbd ... 17486!> \param kbc ... 17487!> \param kad ... 17488!> \param kac ... 17489!> \param pbd ... 17490!> \param pbc ... 17491!> \param pad ... 17492!> \param pac ... 17493!> \param prim ... 17494!> \param scale ... 17495! ************************************************************************************************** 17496 SUBROUTINE block_4_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17497 INTEGER :: md_max 17498 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(4*md_max), kac(4*1), pbd(1*md_max), pbc(1*1), & 17499 pad(4*md_max), pac(4*1), prim(4*1*1*md_max), scale 17500 17501 INTEGER :: ma, mb, mc, md, p_index 17502 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17503 17504 kbd(1:1*md_max) = 0.0_dp 17505 kbc(1:1*1) = 0.0_dp 17506 kad(1:4*md_max) = 0.0_dp 17507 kac(1:4*1) = 0.0_dp 17508 p_index = 0 17509 DO md = 1, md_max 17510 DO mc = 1, 1 17511 DO mb = 1, 1 17512 ks_bd = 0.0_dp 17513 ks_bc = 0.0_dp 17514 p_bd = pbd((md - 1)*1 + mb) 17515 p_bc = pbc((mc - 1)*1 + mb) 17516 DO ma = 1, 4 17517 p_index = p_index + 1 17518 tmp = scale*prim(p_index) 17519 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17520 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17521 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17522 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17523 END DO 17524 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17525 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17526 END DO 17527 END DO 17528 END DO 17529 END SUBROUTINE block_4_1_1 17530! ************************************************************************************************** 17531!> \brief ... 17532!> \param kbd ... 17533!> \param kbc ... 17534!> \param kad ... 17535!> \param kac ... 17536!> \param pbd ... 17537!> \param pbc ... 17538!> \param pad ... 17539!> \param pac ... 17540!> \param prim ... 17541!> \param scale ... 17542! ************************************************************************************************** 17543 SUBROUTINE block_4_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17544 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(4*1), kac(4*2), & 17545 pbd(1*1), pbc(1*2), pad(4*1), & 17546 pac(4*2), prim(4*1*2*1), scale 17547 17548 INTEGER :: ma, mb, mc, md, p_index 17549 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17550 17551 kbd(1:1*1) = 0.0_dp 17552 kbc(1:1*2) = 0.0_dp 17553 kad(1:4*1) = 0.0_dp 17554 kac(1:4*2) = 0.0_dp 17555 p_index = 0 17556 DO md = 1, 1 17557 DO mc = 1, 2 17558 DO mb = 1, 1 17559 ks_bd = 0.0_dp 17560 ks_bc = 0.0_dp 17561 p_bd = pbd((md - 1)*1 + mb) 17562 p_bc = pbc((mc - 1)*1 + mb) 17563 DO ma = 1, 4 17564 p_index = p_index + 1 17565 tmp = scale*prim(p_index) 17566 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17567 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17568 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17569 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17570 END DO 17571 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17572 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17573 END DO 17574 END DO 17575 END DO 17576 END SUBROUTINE block_4_1_2_1 17577! ************************************************************************************************** 17578!> \brief ... 17579!> \param kbd ... 17580!> \param kbc ... 17581!> \param kad ... 17582!> \param kac ... 17583!> \param pbd ... 17584!> \param pbc ... 17585!> \param pad ... 17586!> \param pac ... 17587!> \param prim ... 17588!> \param scale ... 17589! ************************************************************************************************** 17590 SUBROUTINE block_4_1_2_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17591 REAL(KIND=dp) :: kbd(1*2), kbc(1*2), kad(4*2), kac(4*2), & 17592 pbd(1*2), pbc(1*2), pad(4*2), & 17593 pac(4*2), prim(4*1*2*2), scale 17594 17595 INTEGER :: ma, mb, mc, md, p_index 17596 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17597 17598 kbd(1:1*2) = 0.0_dp 17599 kbc(1:1*2) = 0.0_dp 17600 kad(1:4*2) = 0.0_dp 17601 kac(1:4*2) = 0.0_dp 17602 p_index = 0 17603 DO md = 1, 2 17604 DO mc = 1, 2 17605 DO mb = 1, 1 17606 ks_bd = 0.0_dp 17607 ks_bc = 0.0_dp 17608 p_bd = pbd((md - 1)*1 + mb) 17609 p_bc = pbc((mc - 1)*1 + mb) 17610 DO ma = 1, 4 17611 p_index = p_index + 1 17612 tmp = scale*prim(p_index) 17613 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17614 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17615 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17616 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17617 END DO 17618 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17619 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17620 END DO 17621 END DO 17622 END DO 17623 END SUBROUTINE block_4_1_2_2 17624! ************************************************************************************************** 17625!> \brief ... 17626!> \param md_max ... 17627!> \param kbd ... 17628!> \param kbc ... 17629!> \param kad ... 17630!> \param kac ... 17631!> \param pbd ... 17632!> \param pbc ... 17633!> \param pad ... 17634!> \param pac ... 17635!> \param prim ... 17636!> \param scale ... 17637! ************************************************************************************************** 17638 SUBROUTINE block_4_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17639 INTEGER :: md_max 17640 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(4*md_max), kac(4*2), pbd(1*md_max), pbc(1*2), & 17641 pad(4*md_max), pac(4*2), prim(4*1*2*md_max), scale 17642 17643 INTEGER :: ma, mb, mc, md, p_index 17644 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17645 17646 kbd(1:1*md_max) = 0.0_dp 17647 kbc(1:1*2) = 0.0_dp 17648 kad(1:4*md_max) = 0.0_dp 17649 kac(1:4*2) = 0.0_dp 17650 p_index = 0 17651 DO md = 1, md_max 17652 DO mc = 1, 2 17653 DO mb = 1, 1 17654 ks_bd = 0.0_dp 17655 ks_bc = 0.0_dp 17656 p_bd = pbd((md - 1)*1 + mb) 17657 p_bc = pbc((mc - 1)*1 + mb) 17658 DO ma = 1, 4 17659 p_index = p_index + 1 17660 tmp = scale*prim(p_index) 17661 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17662 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17663 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17664 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17665 END DO 17666 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17667 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17668 END DO 17669 END DO 17670 END DO 17671 END SUBROUTINE block_4_1_2 17672! ************************************************************************************************** 17673!> \brief ... 17674!> \param kbd ... 17675!> \param kbc ... 17676!> \param kad ... 17677!> \param kac ... 17678!> \param pbd ... 17679!> \param pbc ... 17680!> \param pad ... 17681!> \param pac ... 17682!> \param prim ... 17683!> \param scale ... 17684! ************************************************************************************************** 17685 SUBROUTINE block_4_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17686 REAL(KIND=dp) :: kbd(1*1), kbc(1*3), kad(4*1), kac(4*3), & 17687 pbd(1*1), pbc(1*3), pad(4*1), & 17688 pac(4*3), prim(4*1*3*1), scale 17689 17690 INTEGER :: ma, mb, mc, md, p_index 17691 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17692 17693 kbd(1:1*1) = 0.0_dp 17694 kbc(1:1*3) = 0.0_dp 17695 kad(1:4*1) = 0.0_dp 17696 kac(1:4*3) = 0.0_dp 17697 p_index = 0 17698 DO md = 1, 1 17699 DO mc = 1, 3 17700 DO mb = 1, 1 17701 ks_bd = 0.0_dp 17702 ks_bc = 0.0_dp 17703 p_bd = pbd((md - 1)*1 + mb) 17704 p_bc = pbc((mc - 1)*1 + mb) 17705 DO ma = 1, 4 17706 p_index = p_index + 1 17707 tmp = scale*prim(p_index) 17708 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17709 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17710 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17711 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17712 END DO 17713 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17714 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17715 END DO 17716 END DO 17717 END DO 17718 END SUBROUTINE block_4_1_3_1 17719! ************************************************************************************************** 17720!> \brief ... 17721!> \param md_max ... 17722!> \param kbd ... 17723!> \param kbc ... 17724!> \param kad ... 17725!> \param kac ... 17726!> \param pbd ... 17727!> \param pbc ... 17728!> \param pad ... 17729!> \param pac ... 17730!> \param prim ... 17731!> \param scale ... 17732! ************************************************************************************************** 17733 SUBROUTINE block_4_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17734 INTEGER :: md_max 17735 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*3), kad(4*md_max), kac(4*3), pbd(1*md_max), pbc(1*3), & 17736 pad(4*md_max), pac(4*3), prim(4*1*3*md_max), scale 17737 17738 INTEGER :: ma, mb, mc, md, p_index 17739 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17740 17741 kbd(1:1*md_max) = 0.0_dp 17742 kbc(1:1*3) = 0.0_dp 17743 kad(1:4*md_max) = 0.0_dp 17744 kac(1:4*3) = 0.0_dp 17745 p_index = 0 17746 DO md = 1, md_max 17747 DO mc = 1, 3 17748 DO mb = 1, 1 17749 ks_bd = 0.0_dp 17750 ks_bc = 0.0_dp 17751 p_bd = pbd((md - 1)*1 + mb) 17752 p_bc = pbc((mc - 1)*1 + mb) 17753 DO ma = 1, 4 17754 p_index = p_index + 1 17755 tmp = scale*prim(p_index) 17756 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17757 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17758 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17759 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17760 END DO 17761 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17762 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17763 END DO 17764 END DO 17765 END DO 17766 END SUBROUTINE block_4_1_3 17767! ************************************************************************************************** 17768!> \brief ... 17769!> \param kbd ... 17770!> \param kbc ... 17771!> \param kad ... 17772!> \param kac ... 17773!> \param pbd ... 17774!> \param pbc ... 17775!> \param pad ... 17776!> \param pac ... 17777!> \param prim ... 17778!> \param scale ... 17779! ************************************************************************************************** 17780 SUBROUTINE block_4_1_4_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17781 REAL(KIND=dp) :: kbd(1*1), kbc(1*4), kad(4*1), kac(4*4), & 17782 pbd(1*1), pbc(1*4), pad(4*1), & 17783 pac(4*4), prim(4*1*4*1), scale 17784 17785 INTEGER :: ma, mb, mc, md, p_index 17786 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17787 17788 kbd(1:1*1) = 0.0_dp 17789 kbc(1:1*4) = 0.0_dp 17790 kad(1:4*1) = 0.0_dp 17791 kac(1:4*4) = 0.0_dp 17792 p_index = 0 17793 DO md = 1, 1 17794 DO mc = 1, 4 17795 DO mb = 1, 1 17796 ks_bd = 0.0_dp 17797 ks_bc = 0.0_dp 17798 p_bd = pbd((md - 1)*1 + mb) 17799 p_bc = pbc((mc - 1)*1 + mb) 17800 DO ma = 1, 4 17801 p_index = p_index + 1 17802 tmp = scale*prim(p_index) 17803 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17804 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17805 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17806 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17807 END DO 17808 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17809 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17810 END DO 17811 END DO 17812 END DO 17813 END SUBROUTINE block_4_1_4_1 17814! ************************************************************************************************** 17815!> \brief ... 17816!> \param md_max ... 17817!> \param kbd ... 17818!> \param kbc ... 17819!> \param kad ... 17820!> \param kac ... 17821!> \param pbd ... 17822!> \param pbc ... 17823!> \param pad ... 17824!> \param pac ... 17825!> \param prim ... 17826!> \param scale ... 17827! ************************************************************************************************** 17828 SUBROUTINE block_4_1_4(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17829 INTEGER :: md_max 17830 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*4), kad(4*md_max), kac(4*4), pbd(1*md_max), pbc(1*4), & 17831 pad(4*md_max), pac(4*4), prim(4*1*4*md_max), scale 17832 17833 INTEGER :: ma, mb, mc, md, p_index 17834 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17835 17836 kbd(1:1*md_max) = 0.0_dp 17837 kbc(1:1*4) = 0.0_dp 17838 kad(1:4*md_max) = 0.0_dp 17839 kac(1:4*4) = 0.0_dp 17840 p_index = 0 17841 DO md = 1, md_max 17842 DO mc = 1, 4 17843 DO mb = 1, 1 17844 ks_bd = 0.0_dp 17845 ks_bc = 0.0_dp 17846 p_bd = pbd((md - 1)*1 + mb) 17847 p_bc = pbc((mc - 1)*1 + mb) 17848 DO ma = 1, 4 17849 p_index = p_index + 1 17850 tmp = scale*prim(p_index) 17851 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17852 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17853 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17854 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17855 END DO 17856 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17857 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17858 END DO 17859 END DO 17860 END DO 17861 END SUBROUTINE block_4_1_4 17862! ************************************************************************************************** 17863!> \brief ... 17864!> \param mc_max ... 17865!> \param md_max ... 17866!> \param kbd ... 17867!> \param kbc ... 17868!> \param kad ... 17869!> \param kac ... 17870!> \param pbd ... 17871!> \param pbc ... 17872!> \param pad ... 17873!> \param pac ... 17874!> \param prim ... 17875!> \param scale ... 17876! ************************************************************************************************** 17877 SUBROUTINE block_4_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17878 INTEGER :: mc_max, md_max 17879 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(4*md_max), kac(4*mc_max), pbd(1*md_max), & 17880 pbc(1*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*1*mc_max*md_max), scale 17881 17882 INTEGER :: ma, mb, mc, md, p_index 17883 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17884 17885 kbd(1:1*md_max) = 0.0_dp 17886 kbc(1:1*mc_max) = 0.0_dp 17887 kad(1:4*md_max) = 0.0_dp 17888 kac(1:4*mc_max) = 0.0_dp 17889 p_index = 0 17890 DO md = 1, md_max 17891 DO mc = 1, mc_max 17892 DO mb = 1, 1 17893 ks_bd = 0.0_dp 17894 ks_bc = 0.0_dp 17895 p_bd = pbd((md - 1)*1 + mb) 17896 p_bc = pbc((mc - 1)*1 + mb) 17897 DO ma = 1, 4 17898 p_index = p_index + 1 17899 tmp = scale*prim(p_index) 17900 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17901 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17902 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17903 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17904 END DO 17905 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 17906 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 17907 END DO 17908 END DO 17909 END DO 17910 END SUBROUTINE block_4_1 17911! ************************************************************************************************** 17912!> \brief ... 17913!> \param kbd ... 17914!> \param kbc ... 17915!> \param kad ... 17916!> \param kac ... 17917!> \param pbd ... 17918!> \param pbc ... 17919!> \param pad ... 17920!> \param pac ... 17921!> \param prim ... 17922!> \param scale ... 17923! ************************************************************************************************** 17924 SUBROUTINE block_4_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17925 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(4*1), kac(4*1), & 17926 pbd(2*1), pbc(2*1), pad(4*1), & 17927 pac(4*1), prim(4*2*1*1), scale 17928 17929 INTEGER :: ma, mb, mc, md, p_index 17930 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17931 17932 kbd(1:2*1) = 0.0_dp 17933 kbc(1:2*1) = 0.0_dp 17934 kad(1:4*1) = 0.0_dp 17935 kac(1:4*1) = 0.0_dp 17936 p_index = 0 17937 DO md = 1, 1 17938 DO mc = 1, 1 17939 DO mb = 1, 2 17940 ks_bd = 0.0_dp 17941 ks_bc = 0.0_dp 17942 p_bd = pbd((md - 1)*2 + mb) 17943 p_bc = pbc((mc - 1)*2 + mb) 17944 DO ma = 1, 4 17945 p_index = p_index + 1 17946 tmp = scale*prim(p_index) 17947 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17948 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17949 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17950 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17951 END DO 17952 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 17953 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 17954 END DO 17955 END DO 17956 END DO 17957 END SUBROUTINE block_4_2_1_1 17958! ************************************************************************************************** 17959!> \brief ... 17960!> \param kbd ... 17961!> \param kbc ... 17962!> \param kad ... 17963!> \param kac ... 17964!> \param pbd ... 17965!> \param pbc ... 17966!> \param pad ... 17967!> \param pac ... 17968!> \param prim ... 17969!> \param scale ... 17970! ************************************************************************************************** 17971 SUBROUTINE block_4_2_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 17972 REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(4*2), kac(4*1), & 17973 pbd(2*2), pbc(2*1), pad(4*2), & 17974 pac(4*1), prim(4*2*1*2), scale 17975 17976 INTEGER :: ma, mb, mc, md, p_index 17977 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 17978 17979 kbd(1:2*2) = 0.0_dp 17980 kbc(1:2*1) = 0.0_dp 17981 kad(1:4*2) = 0.0_dp 17982 kac(1:4*1) = 0.0_dp 17983 p_index = 0 17984 DO md = 1, 2 17985 DO mc = 1, 1 17986 DO mb = 1, 2 17987 ks_bd = 0.0_dp 17988 ks_bc = 0.0_dp 17989 p_bd = pbd((md - 1)*2 + mb) 17990 p_bc = pbc((mc - 1)*2 + mb) 17991 DO ma = 1, 4 17992 p_index = p_index + 1 17993 tmp = scale*prim(p_index) 17994 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 17995 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 17996 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 17997 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 17998 END DO 17999 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 18000 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 18001 END DO 18002 END DO 18003 END DO 18004 END SUBROUTINE block_4_2_1_2 18005! ************************************************************************************************** 18006!> \brief ... 18007!> \param md_max ... 18008!> \param kbd ... 18009!> \param kbc ... 18010!> \param kad ... 18011!> \param kac ... 18012!> \param pbd ... 18013!> \param pbc ... 18014!> \param pad ... 18015!> \param pac ... 18016!> \param prim ... 18017!> \param scale ... 18018! ************************************************************************************************** 18019 SUBROUTINE block_4_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18020 INTEGER :: md_max 18021 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(4*md_max), kac(4*1), pbd(2*md_max), pbc(2*1), & 18022 pad(4*md_max), pac(4*1), prim(4*2*1*md_max), scale 18023 18024 INTEGER :: ma, mb, mc, md, p_index 18025 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18026 18027 kbd(1:2*md_max) = 0.0_dp 18028 kbc(1:2*1) = 0.0_dp 18029 kad(1:4*md_max) = 0.0_dp 18030 kac(1:4*1) = 0.0_dp 18031 p_index = 0 18032 DO md = 1, md_max 18033 DO mc = 1, 1 18034 DO mb = 1, 2 18035 ks_bd = 0.0_dp 18036 ks_bc = 0.0_dp 18037 p_bd = pbd((md - 1)*2 + mb) 18038 p_bc = pbc((mc - 1)*2 + mb) 18039 DO ma = 1, 4 18040 p_index = p_index + 1 18041 tmp = scale*prim(p_index) 18042 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18043 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18044 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18045 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18046 END DO 18047 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 18048 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 18049 END DO 18050 END DO 18051 END DO 18052 END SUBROUTINE block_4_2_1 18053! ************************************************************************************************** 18054!> \brief ... 18055!> \param kbd ... 18056!> \param kbc ... 18057!> \param kad ... 18058!> \param kac ... 18059!> \param pbd ... 18060!> \param pbc ... 18061!> \param pad ... 18062!> \param pac ... 18063!> \param prim ... 18064!> \param scale ... 18065! ************************************************************************************************** 18066 SUBROUTINE block_4_2_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18067 REAL(KIND=dp) :: kbd(2*1), kbc(2*2), kad(4*1), kac(4*2), & 18068 pbd(2*1), pbc(2*2), pad(4*1), & 18069 pac(4*2), prim(4*2*2*1), scale 18070 18071 INTEGER :: ma, mb, mc, md, p_index 18072 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18073 18074 kbd(1:2*1) = 0.0_dp 18075 kbc(1:2*2) = 0.0_dp 18076 kad(1:4*1) = 0.0_dp 18077 kac(1:4*2) = 0.0_dp 18078 p_index = 0 18079 DO md = 1, 1 18080 DO mc = 1, 2 18081 DO mb = 1, 2 18082 ks_bd = 0.0_dp 18083 ks_bc = 0.0_dp 18084 p_bd = pbd((md - 1)*2 + mb) 18085 p_bc = pbc((mc - 1)*2 + mb) 18086 DO ma = 1, 4 18087 p_index = p_index + 1 18088 tmp = scale*prim(p_index) 18089 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18090 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18091 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18092 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18093 END DO 18094 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 18095 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 18096 END DO 18097 END DO 18098 END DO 18099 END SUBROUTINE block_4_2_2_1 18100! ************************************************************************************************** 18101!> \brief ... 18102!> \param md_max ... 18103!> \param kbd ... 18104!> \param kbc ... 18105!> \param kad ... 18106!> \param kac ... 18107!> \param pbd ... 18108!> \param pbc ... 18109!> \param pad ... 18110!> \param pac ... 18111!> \param prim ... 18112!> \param scale ... 18113! ************************************************************************************************** 18114 SUBROUTINE block_4_2_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18115 INTEGER :: md_max 18116 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*2), kad(4*md_max), kac(4*2), pbd(2*md_max), pbc(2*2), & 18117 pad(4*md_max), pac(4*2), prim(4*2*2*md_max), scale 18118 18119 INTEGER :: ma, mb, mc, md, p_index 18120 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18121 18122 kbd(1:2*md_max) = 0.0_dp 18123 kbc(1:2*2) = 0.0_dp 18124 kad(1:4*md_max) = 0.0_dp 18125 kac(1:4*2) = 0.0_dp 18126 p_index = 0 18127 DO md = 1, md_max 18128 DO mc = 1, 2 18129 DO mb = 1, 2 18130 ks_bd = 0.0_dp 18131 ks_bc = 0.0_dp 18132 p_bd = pbd((md - 1)*2 + mb) 18133 p_bc = pbc((mc - 1)*2 + mb) 18134 DO ma = 1, 4 18135 p_index = p_index + 1 18136 tmp = scale*prim(p_index) 18137 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18138 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18139 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18140 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18141 END DO 18142 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 18143 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 18144 END DO 18145 END DO 18146 END DO 18147 END SUBROUTINE block_4_2_2 18148! ************************************************************************************************** 18149!> \brief ... 18150!> \param mc_max ... 18151!> \param md_max ... 18152!> \param kbd ... 18153!> \param kbc ... 18154!> \param kad ... 18155!> \param kac ... 18156!> \param pbd ... 18157!> \param pbc ... 18158!> \param pad ... 18159!> \param pac ... 18160!> \param prim ... 18161!> \param scale ... 18162! ************************************************************************************************** 18163 SUBROUTINE block_4_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18164 INTEGER :: mc_max, md_max 18165 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(4*md_max), kac(4*mc_max), pbd(2*md_max), & 18166 pbc(2*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*2*mc_max*md_max), scale 18167 18168 INTEGER :: ma, mb, mc, md, p_index 18169 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18170 18171 kbd(1:2*md_max) = 0.0_dp 18172 kbc(1:2*mc_max) = 0.0_dp 18173 kad(1:4*md_max) = 0.0_dp 18174 kac(1:4*mc_max) = 0.0_dp 18175 p_index = 0 18176 DO md = 1, md_max 18177 DO mc = 1, mc_max 18178 DO mb = 1, 2 18179 ks_bd = 0.0_dp 18180 ks_bc = 0.0_dp 18181 p_bd = pbd((md - 1)*2 + mb) 18182 p_bc = pbc((mc - 1)*2 + mb) 18183 DO ma = 1, 4 18184 p_index = p_index + 1 18185 tmp = scale*prim(p_index) 18186 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18187 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18188 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18189 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18190 END DO 18191 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 18192 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 18193 END DO 18194 END DO 18195 END DO 18196 END SUBROUTINE block_4_2 18197! ************************************************************************************************** 18198!> \brief ... 18199!> \param kbd ... 18200!> \param kbc ... 18201!> \param kad ... 18202!> \param kac ... 18203!> \param pbd ... 18204!> \param pbc ... 18205!> \param pad ... 18206!> \param pac ... 18207!> \param prim ... 18208!> \param scale ... 18209! ************************************************************************************************** 18210 SUBROUTINE block_4_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18211 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(4*1), kac(4*1), & 18212 pbd(3*1), pbc(3*1), pad(4*1), & 18213 pac(4*1), prim(4*3*1*1), scale 18214 18215 INTEGER :: ma, mb, mc, md, p_index 18216 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18217 18218 kbd(1:3*1) = 0.0_dp 18219 kbc(1:3*1) = 0.0_dp 18220 kad(1:4*1) = 0.0_dp 18221 kac(1:4*1) = 0.0_dp 18222 p_index = 0 18223 DO md = 1, 1 18224 DO mc = 1, 1 18225 DO mb = 1, 3 18226 ks_bd = 0.0_dp 18227 ks_bc = 0.0_dp 18228 p_bd = pbd((md - 1)*3 + mb) 18229 p_bc = pbc((mc - 1)*3 + mb) 18230 DO ma = 1, 4 18231 p_index = p_index + 1 18232 tmp = scale*prim(p_index) 18233 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18234 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18235 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18236 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18237 END DO 18238 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 18239 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 18240 END DO 18241 END DO 18242 END DO 18243 END SUBROUTINE block_4_3_1_1 18244! ************************************************************************************************** 18245!> \brief ... 18246!> \param md_max ... 18247!> \param kbd ... 18248!> \param kbc ... 18249!> \param kad ... 18250!> \param kac ... 18251!> \param pbd ... 18252!> \param pbc ... 18253!> \param pad ... 18254!> \param pac ... 18255!> \param prim ... 18256!> \param scale ... 18257! ************************************************************************************************** 18258 SUBROUTINE block_4_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18259 INTEGER :: md_max 18260 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(4*md_max), kac(4*1), pbd(3*md_max), pbc(3*1), & 18261 pad(4*md_max), pac(4*1), prim(4*3*1*md_max), scale 18262 18263 INTEGER :: ma, mb, mc, md, p_index 18264 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18265 18266 kbd(1:3*md_max) = 0.0_dp 18267 kbc(1:3*1) = 0.0_dp 18268 kad(1:4*md_max) = 0.0_dp 18269 kac(1:4*1) = 0.0_dp 18270 p_index = 0 18271 DO md = 1, md_max 18272 DO mc = 1, 1 18273 DO mb = 1, 3 18274 ks_bd = 0.0_dp 18275 ks_bc = 0.0_dp 18276 p_bd = pbd((md - 1)*3 + mb) 18277 p_bc = pbc((mc - 1)*3 + mb) 18278 DO ma = 1, 4 18279 p_index = p_index + 1 18280 tmp = scale*prim(p_index) 18281 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18282 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18283 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18284 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18285 END DO 18286 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 18287 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 18288 END DO 18289 END DO 18290 END DO 18291 END SUBROUTINE block_4_3_1 18292! ************************************************************************************************** 18293!> \brief ... 18294!> \param mc_max ... 18295!> \param md_max ... 18296!> \param kbd ... 18297!> \param kbc ... 18298!> \param kad ... 18299!> \param kac ... 18300!> \param pbd ... 18301!> \param pbc ... 18302!> \param pad ... 18303!> \param pac ... 18304!> \param prim ... 18305!> \param scale ... 18306! ************************************************************************************************** 18307 SUBROUTINE block_4_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18308 INTEGER :: mc_max, md_max 18309 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(4*md_max), kac(4*mc_max), pbd(3*md_max), & 18310 pbc(3*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*3*mc_max*md_max), scale 18311 18312 INTEGER :: ma, mb, mc, md, p_index 18313 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18314 18315 kbd(1:3*md_max) = 0.0_dp 18316 kbc(1:3*mc_max) = 0.0_dp 18317 kad(1:4*md_max) = 0.0_dp 18318 kac(1:4*mc_max) = 0.0_dp 18319 p_index = 0 18320 DO md = 1, md_max 18321 DO mc = 1, mc_max 18322 DO mb = 1, 3 18323 ks_bd = 0.0_dp 18324 ks_bc = 0.0_dp 18325 p_bd = pbd((md - 1)*3 + mb) 18326 p_bc = pbc((mc - 1)*3 + mb) 18327 DO ma = 1, 4 18328 p_index = p_index + 1 18329 tmp = scale*prim(p_index) 18330 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18331 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18332 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18333 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18334 END DO 18335 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 18336 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 18337 END DO 18338 END DO 18339 END DO 18340 END SUBROUTINE block_4_3 18341! ************************************************************************************************** 18342!> \brief ... 18343!> \param kbd ... 18344!> \param kbc ... 18345!> \param kad ... 18346!> \param kac ... 18347!> \param pbd ... 18348!> \param pbc ... 18349!> \param pad ... 18350!> \param pac ... 18351!> \param prim ... 18352!> \param scale ... 18353! ************************************************************************************************** 18354 SUBROUTINE block_4_4_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18355 REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(4*1), kac(4*1), & 18356 pbd(4*1), pbc(4*1), pad(4*1), & 18357 pac(4*1), prim(4*4*1*1), scale 18358 18359 INTEGER :: ma, mb, mc, md, p_index 18360 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18361 18362 kbd(1:4*1) = 0.0_dp 18363 kbc(1:4*1) = 0.0_dp 18364 kad(1:4*1) = 0.0_dp 18365 kac(1:4*1) = 0.0_dp 18366 p_index = 0 18367 DO md = 1, 1 18368 DO mc = 1, 1 18369 DO mb = 1, 4 18370 ks_bd = 0.0_dp 18371 ks_bc = 0.0_dp 18372 p_bd = pbd((md - 1)*4 + mb) 18373 p_bc = pbc((mc - 1)*4 + mb) 18374 DO ma = 1, 4 18375 p_index = p_index + 1 18376 tmp = scale*prim(p_index) 18377 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18378 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18379 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18380 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18381 END DO 18382 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 18383 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 18384 END DO 18385 END DO 18386 END DO 18387 END SUBROUTINE block_4_4_1_1 18388! ************************************************************************************************** 18389!> \brief ... 18390!> \param md_max ... 18391!> \param kbd ... 18392!> \param kbc ... 18393!> \param kad ... 18394!> \param kac ... 18395!> \param pbd ... 18396!> \param pbc ... 18397!> \param pad ... 18398!> \param pac ... 18399!> \param prim ... 18400!> \param scale ... 18401! ************************************************************************************************** 18402 SUBROUTINE block_4_4_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18403 INTEGER :: md_max 18404 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*1), kad(4*md_max), kac(4*1), pbd(4*md_max), pbc(4*1), & 18405 pad(4*md_max), pac(4*1), prim(4*4*1*md_max), scale 18406 18407 INTEGER :: ma, mb, mc, md, p_index 18408 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18409 18410 kbd(1:4*md_max) = 0.0_dp 18411 kbc(1:4*1) = 0.0_dp 18412 kad(1:4*md_max) = 0.0_dp 18413 kac(1:4*1) = 0.0_dp 18414 p_index = 0 18415 DO md = 1, md_max 18416 DO mc = 1, 1 18417 DO mb = 1, 4 18418 ks_bd = 0.0_dp 18419 ks_bc = 0.0_dp 18420 p_bd = pbd((md - 1)*4 + mb) 18421 p_bc = pbc((mc - 1)*4 + mb) 18422 DO ma = 1, 4 18423 p_index = p_index + 1 18424 tmp = scale*prim(p_index) 18425 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18426 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18427 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18428 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18429 END DO 18430 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 18431 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 18432 END DO 18433 END DO 18434 END DO 18435 END SUBROUTINE block_4_4_1 18436! ************************************************************************************************** 18437!> \brief ... 18438!> \param mc_max ... 18439!> \param md_max ... 18440!> \param kbd ... 18441!> \param kbc ... 18442!> \param kad ... 18443!> \param kac ... 18444!> \param pbd ... 18445!> \param pbc ... 18446!> \param pad ... 18447!> \param pac ... 18448!> \param prim ... 18449!> \param scale ... 18450! ************************************************************************************************** 18451 SUBROUTINE block_4_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18452 INTEGER :: mc_max, md_max 18453 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(4*md_max), kac(4*mc_max), pbd(4*md_max), & 18454 pbc(4*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*4*mc_max*md_max), scale 18455 18456 INTEGER :: ma, mb, mc, md, p_index 18457 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18458 18459 kbd(1:4*md_max) = 0.0_dp 18460 kbc(1:4*mc_max) = 0.0_dp 18461 kad(1:4*md_max) = 0.0_dp 18462 kac(1:4*mc_max) = 0.0_dp 18463 p_index = 0 18464 DO md = 1, md_max 18465 DO mc = 1, mc_max 18466 DO mb = 1, 4 18467 ks_bd = 0.0_dp 18468 ks_bc = 0.0_dp 18469 p_bd = pbd((md - 1)*4 + mb) 18470 p_bc = pbc((mc - 1)*4 + mb) 18471 DO ma = 1, 4 18472 p_index = p_index + 1 18473 tmp = scale*prim(p_index) 18474 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18475 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18476 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18477 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18478 END DO 18479 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 18480 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 18481 END DO 18482 END DO 18483 END DO 18484 END SUBROUTINE block_4_4 18485! ************************************************************************************************** 18486!> \brief ... 18487!> \param mc_max ... 18488!> \param md_max ... 18489!> \param kbd ... 18490!> \param kbc ... 18491!> \param kad ... 18492!> \param kac ... 18493!> \param pbd ... 18494!> \param pbc ... 18495!> \param pad ... 18496!> \param pac ... 18497!> \param prim ... 18498!> \param scale ... 18499! ************************************************************************************************** 18500 SUBROUTINE block_4_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18501 INTEGER :: mc_max, md_max 18502 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(4*md_max), kac(4*mc_max), pbd(5*md_max), & 18503 pbc(5*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*5*mc_max*md_max), scale 18504 18505 INTEGER :: ma, mb, mc, md, p_index 18506 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18507 18508 kbd(1:5*md_max) = 0.0_dp 18509 kbc(1:5*mc_max) = 0.0_dp 18510 kad(1:4*md_max) = 0.0_dp 18511 kac(1:4*mc_max) = 0.0_dp 18512 p_index = 0 18513 DO md = 1, md_max 18514 DO mc = 1, mc_max 18515 DO mb = 1, 5 18516 ks_bd = 0.0_dp 18517 ks_bc = 0.0_dp 18518 p_bd = pbd((md - 1)*5 + mb) 18519 p_bc = pbc((mc - 1)*5 + mb) 18520 DO ma = 1, 4 18521 p_index = p_index + 1 18522 tmp = scale*prim(p_index) 18523 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18524 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18525 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18526 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18527 END DO 18528 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 18529 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 18530 END DO 18531 END DO 18532 END DO 18533 END SUBROUTINE block_4_5 18534! ************************************************************************************************** 18535!> \brief ... 18536!> \param mc_max ... 18537!> \param md_max ... 18538!> \param kbd ... 18539!> \param kbc ... 18540!> \param kad ... 18541!> \param kac ... 18542!> \param pbd ... 18543!> \param pbc ... 18544!> \param pad ... 18545!> \param pac ... 18546!> \param prim ... 18547!> \param scale ... 18548! ************************************************************************************************** 18549 SUBROUTINE block_4_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18550 INTEGER :: mc_max, md_max 18551 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(4*md_max), kac(4*mc_max), pbd(6*md_max), & 18552 pbc(6*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*6*mc_max*md_max), scale 18553 18554 INTEGER :: ma, mb, mc, md, p_index 18555 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18556 18557 kbd(1:6*md_max) = 0.0_dp 18558 kbc(1:6*mc_max) = 0.0_dp 18559 kad(1:4*md_max) = 0.0_dp 18560 kac(1:4*mc_max) = 0.0_dp 18561 p_index = 0 18562 DO md = 1, md_max 18563 DO mc = 1, mc_max 18564 DO mb = 1, 6 18565 ks_bd = 0.0_dp 18566 ks_bc = 0.0_dp 18567 p_bd = pbd((md - 1)*6 + mb) 18568 p_bc = pbc((mc - 1)*6 + mb) 18569 DO ma = 1, 4 18570 p_index = p_index + 1 18571 tmp = scale*prim(p_index) 18572 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18573 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18574 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18575 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18576 END DO 18577 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 18578 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 18579 END DO 18580 END DO 18581 END DO 18582 END SUBROUTINE block_4_6 18583! ************************************************************************************************** 18584!> \brief ... 18585!> \param mc_max ... 18586!> \param md_max ... 18587!> \param kbd ... 18588!> \param kbc ... 18589!> \param kad ... 18590!> \param kac ... 18591!> \param pbd ... 18592!> \param pbc ... 18593!> \param pad ... 18594!> \param pac ... 18595!> \param prim ... 18596!> \param scale ... 18597! ************************************************************************************************** 18598 SUBROUTINE block_4_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18599 INTEGER :: mc_max, md_max 18600 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(4*md_max), kac(4*mc_max), pbd(7*md_max), & 18601 pbc(7*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*7*mc_max*md_max), scale 18602 18603 INTEGER :: ma, mb, mc, md, p_index 18604 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18605 18606 kbd(1:7*md_max) = 0.0_dp 18607 kbc(1:7*mc_max) = 0.0_dp 18608 kad(1:4*md_max) = 0.0_dp 18609 kac(1:4*mc_max) = 0.0_dp 18610 p_index = 0 18611 DO md = 1, md_max 18612 DO mc = 1, mc_max 18613 DO mb = 1, 7 18614 ks_bd = 0.0_dp 18615 ks_bc = 0.0_dp 18616 p_bd = pbd((md - 1)*7 + mb) 18617 p_bc = pbc((mc - 1)*7 + mb) 18618 DO ma = 1, 4 18619 p_index = p_index + 1 18620 tmp = scale*prim(p_index) 18621 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18622 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18623 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18624 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18625 END DO 18626 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 18627 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 18628 END DO 18629 END DO 18630 END DO 18631 END SUBROUTINE block_4_7 18632! ************************************************************************************************** 18633!> \brief ... 18634!> \param mc_max ... 18635!> \param md_max ... 18636!> \param kbd ... 18637!> \param kbc ... 18638!> \param kad ... 18639!> \param kac ... 18640!> \param pbd ... 18641!> \param pbc ... 18642!> \param pad ... 18643!> \param pac ... 18644!> \param prim ... 18645!> \param scale ... 18646! ************************************************************************************************** 18647 SUBROUTINE block_4_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18648 INTEGER :: mc_max, md_max 18649 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(4*md_max), kac(4*mc_max), pbd(9*md_max), & 18650 pbc(9*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*9*mc_max*md_max), scale 18651 18652 INTEGER :: ma, mb, mc, md, p_index 18653 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18654 18655 kbd(1:9*md_max) = 0.0_dp 18656 kbc(1:9*mc_max) = 0.0_dp 18657 kad(1:4*md_max) = 0.0_dp 18658 kac(1:4*mc_max) = 0.0_dp 18659 p_index = 0 18660 DO md = 1, md_max 18661 DO mc = 1, mc_max 18662 DO mb = 1, 9 18663 ks_bd = 0.0_dp 18664 ks_bc = 0.0_dp 18665 p_bd = pbd((md - 1)*9 + mb) 18666 p_bc = pbc((mc - 1)*9 + mb) 18667 DO ma = 1, 4 18668 p_index = p_index + 1 18669 tmp = scale*prim(p_index) 18670 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18671 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18672 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18673 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18674 END DO 18675 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 18676 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 18677 END DO 18678 END DO 18679 END DO 18680 END SUBROUTINE block_4_9 18681! ************************************************************************************************** 18682!> \brief ... 18683!> \param mc_max ... 18684!> \param md_max ... 18685!> \param kbd ... 18686!> \param kbc ... 18687!> \param kad ... 18688!> \param kac ... 18689!> \param pbd ... 18690!> \param pbc ... 18691!> \param pad ... 18692!> \param pac ... 18693!> \param prim ... 18694!> \param scale ... 18695! ************************************************************************************************** 18696 SUBROUTINE block_4_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18697 INTEGER :: mc_max, md_max 18698 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(4*md_max), kac(4*mc_max), & 18699 pbd(10*md_max), pbc(10*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*10*mc_max*md_max), & 18700 scale 18701 18702 INTEGER :: ma, mb, mc, md, p_index 18703 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18704 18705 kbd(1:10*md_max) = 0.0_dp 18706 kbc(1:10*mc_max) = 0.0_dp 18707 kad(1:4*md_max) = 0.0_dp 18708 kac(1:4*mc_max) = 0.0_dp 18709 p_index = 0 18710 DO md = 1, md_max 18711 DO mc = 1, mc_max 18712 DO mb = 1, 10 18713 ks_bd = 0.0_dp 18714 ks_bc = 0.0_dp 18715 p_bd = pbd((md - 1)*10 + mb) 18716 p_bc = pbc((mc - 1)*10 + mb) 18717 DO ma = 1, 4 18718 p_index = p_index + 1 18719 tmp = scale*prim(p_index) 18720 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18721 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18722 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18723 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18724 END DO 18725 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 18726 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 18727 END DO 18728 END DO 18729 END DO 18730 END SUBROUTINE block_4_10 18731! ************************************************************************************************** 18732!> \brief ... 18733!> \param mc_max ... 18734!> \param md_max ... 18735!> \param kbd ... 18736!> \param kbc ... 18737!> \param kad ... 18738!> \param kac ... 18739!> \param pbd ... 18740!> \param pbc ... 18741!> \param pad ... 18742!> \param pac ... 18743!> \param prim ... 18744!> \param scale ... 18745! ************************************************************************************************** 18746 SUBROUTINE block_4_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18747 INTEGER :: mc_max, md_max 18748 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(4*md_max), kac(4*mc_max), & 18749 pbd(11*md_max), pbc(11*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*11*mc_max*md_max), & 18750 scale 18751 18752 INTEGER :: ma, mb, mc, md, p_index 18753 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18754 18755 kbd(1:11*md_max) = 0.0_dp 18756 kbc(1:11*mc_max) = 0.0_dp 18757 kad(1:4*md_max) = 0.0_dp 18758 kac(1:4*mc_max) = 0.0_dp 18759 p_index = 0 18760 DO md = 1, md_max 18761 DO mc = 1, mc_max 18762 DO mb = 1, 11 18763 ks_bd = 0.0_dp 18764 ks_bc = 0.0_dp 18765 p_bd = pbd((md - 1)*11 + mb) 18766 p_bc = pbc((mc - 1)*11 + mb) 18767 DO ma = 1, 4 18768 p_index = p_index + 1 18769 tmp = scale*prim(p_index) 18770 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18771 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18772 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18773 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18774 END DO 18775 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 18776 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 18777 END DO 18778 END DO 18779 END DO 18780 END SUBROUTINE block_4_11 18781! ************************************************************************************************** 18782!> \brief ... 18783!> \param mc_max ... 18784!> \param md_max ... 18785!> \param kbd ... 18786!> \param kbc ... 18787!> \param kad ... 18788!> \param kac ... 18789!> \param pbd ... 18790!> \param pbc ... 18791!> \param pad ... 18792!> \param pac ... 18793!> \param prim ... 18794!> \param scale ... 18795! ************************************************************************************************** 18796 SUBROUTINE block_4_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18797 INTEGER :: mc_max, md_max 18798 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(4*md_max), kac(4*mc_max), & 18799 pbd(15*md_max), pbc(15*mc_max), pad(4*md_max), pac(4*mc_max), prim(4*15*mc_max*md_max), & 18800 scale 18801 18802 INTEGER :: ma, mb, mc, md, p_index 18803 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18804 18805 kbd(1:15*md_max) = 0.0_dp 18806 kbc(1:15*mc_max) = 0.0_dp 18807 kad(1:4*md_max) = 0.0_dp 18808 kac(1:4*mc_max) = 0.0_dp 18809 p_index = 0 18810 DO md = 1, md_max 18811 DO mc = 1, mc_max 18812 DO mb = 1, 15 18813 ks_bd = 0.0_dp 18814 ks_bc = 0.0_dp 18815 p_bd = pbd((md - 1)*15 + mb) 18816 p_bc = pbc((mc - 1)*15 + mb) 18817 DO ma = 1, 4 18818 p_index = p_index + 1 18819 tmp = scale*prim(p_index) 18820 ks_bc = ks_bc + tmp*pad((md - 1)*4 + ma) 18821 ks_bd = ks_bd + tmp*pac((mc - 1)*4 + ma) 18822 kad((md - 1)*4 + ma) = kad((md - 1)*4 + ma) - tmp*p_bc 18823 kac((mc - 1)*4 + ma) = kac((mc - 1)*4 + ma) - tmp*p_bd 18824 END DO 18825 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 18826 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 18827 END DO 18828 END DO 18829 END DO 18830 END SUBROUTINE block_4_15 18831! ************************************************************************************************** 18832!> \brief ... 18833!> \param kbd ... 18834!> \param kbc ... 18835!> \param kad ... 18836!> \param kac ... 18837!> \param pbd ... 18838!> \param pbc ... 18839!> \param pad ... 18840!> \param pac ... 18841!> \param prim ... 18842!> \param scale ... 18843! ************************************************************************************************** 18844 SUBROUTINE block_5_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18845 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(5*1), kac(5*1), & 18846 pbd(1*1), pbc(1*1), pad(5*1), & 18847 pac(5*1), prim(5*1*1*1), scale 18848 18849 INTEGER :: ma, mb, mc, md, p_index 18850 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18851 18852 kbd(1:1*1) = 0.0_dp 18853 kbc(1:1*1) = 0.0_dp 18854 kad(1:5*1) = 0.0_dp 18855 kac(1:5*1) = 0.0_dp 18856 p_index = 0 18857 DO md = 1, 1 18858 DO mc = 1, 1 18859 DO mb = 1, 1 18860 ks_bd = 0.0_dp 18861 ks_bc = 0.0_dp 18862 p_bd = pbd((md - 1)*1 + mb) 18863 p_bc = pbc((mc - 1)*1 + mb) 18864 DO ma = 1, 5 18865 p_index = p_index + 1 18866 tmp = scale*prim(p_index) 18867 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 18868 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 18869 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 18870 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 18871 END DO 18872 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 18873 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 18874 END DO 18875 END DO 18876 END DO 18877 END SUBROUTINE block_5_1_1_1 18878! ************************************************************************************************** 18879!> \brief ... 18880!> \param kbd ... 18881!> \param kbc ... 18882!> \param kad ... 18883!> \param kac ... 18884!> \param pbd ... 18885!> \param pbc ... 18886!> \param pad ... 18887!> \param pac ... 18888!> \param prim ... 18889!> \param scale ... 18890! ************************************************************************************************** 18891 SUBROUTINE block_5_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18892 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(5*2), kac(5*1), & 18893 pbd(1*2), pbc(1*1), pad(5*2), & 18894 pac(5*1), prim(5*1*1*2), scale 18895 18896 INTEGER :: ma, mb, mc, md, p_index 18897 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18898 18899 kbd(1:1*2) = 0.0_dp 18900 kbc(1:1*1) = 0.0_dp 18901 kad(1:5*2) = 0.0_dp 18902 kac(1:5*1) = 0.0_dp 18903 p_index = 0 18904 DO md = 1, 2 18905 DO mc = 1, 1 18906 DO mb = 1, 1 18907 ks_bd = 0.0_dp 18908 ks_bc = 0.0_dp 18909 p_bd = pbd((md - 1)*1 + mb) 18910 p_bc = pbc((mc - 1)*1 + mb) 18911 DO ma = 1, 5 18912 p_index = p_index + 1 18913 tmp = scale*prim(p_index) 18914 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 18915 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 18916 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 18917 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 18918 END DO 18919 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 18920 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 18921 END DO 18922 END DO 18923 END DO 18924 END SUBROUTINE block_5_1_1_2 18925! ************************************************************************************************** 18926!> \brief ... 18927!> \param kbd ... 18928!> \param kbc ... 18929!> \param kad ... 18930!> \param kac ... 18931!> \param pbd ... 18932!> \param pbc ... 18933!> \param pad ... 18934!> \param pac ... 18935!> \param prim ... 18936!> \param scale ... 18937! ************************************************************************************************** 18938 SUBROUTINE block_5_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18939 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(5*3), kac(5*1), & 18940 pbd(1*3), pbc(1*1), pad(5*3), & 18941 pac(5*1), prim(5*1*1*3), scale 18942 18943 INTEGER :: ma, mb, mc, md, p_index 18944 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18945 18946 kbd(1:1*3) = 0.0_dp 18947 kbc(1:1*1) = 0.0_dp 18948 kad(1:5*3) = 0.0_dp 18949 kac(1:5*1) = 0.0_dp 18950 p_index = 0 18951 DO md = 1, 3 18952 DO mc = 1, 1 18953 DO mb = 1, 1 18954 ks_bd = 0.0_dp 18955 ks_bc = 0.0_dp 18956 p_bd = pbd((md - 1)*1 + mb) 18957 p_bc = pbc((mc - 1)*1 + mb) 18958 DO ma = 1, 5 18959 p_index = p_index + 1 18960 tmp = scale*prim(p_index) 18961 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 18962 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 18963 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 18964 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 18965 END DO 18966 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 18967 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 18968 END DO 18969 END DO 18970 END DO 18971 END SUBROUTINE block_5_1_1_3 18972! ************************************************************************************************** 18973!> \brief ... 18974!> \param md_max ... 18975!> \param kbd ... 18976!> \param kbc ... 18977!> \param kad ... 18978!> \param kac ... 18979!> \param pbd ... 18980!> \param pbc ... 18981!> \param pad ... 18982!> \param pac ... 18983!> \param prim ... 18984!> \param scale ... 18985! ************************************************************************************************** 18986 SUBROUTINE block_5_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 18987 INTEGER :: md_max 18988 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(5*md_max), kac(5*1), pbd(1*md_max), pbc(1*1), & 18989 pad(5*md_max), pac(5*1), prim(5*1*1*md_max), scale 18990 18991 INTEGER :: ma, mb, mc, md, p_index 18992 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 18993 18994 kbd(1:1*md_max) = 0.0_dp 18995 kbc(1:1*1) = 0.0_dp 18996 kad(1:5*md_max) = 0.0_dp 18997 kac(1:5*1) = 0.0_dp 18998 p_index = 0 18999 DO md = 1, md_max 19000 DO mc = 1, 1 19001 DO mb = 1, 1 19002 ks_bd = 0.0_dp 19003 ks_bc = 0.0_dp 19004 p_bd = pbd((md - 1)*1 + mb) 19005 p_bc = pbc((mc - 1)*1 + mb) 19006 DO ma = 1, 5 19007 p_index = p_index + 1 19008 tmp = scale*prim(p_index) 19009 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19010 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19011 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19012 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19013 END DO 19014 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 19015 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 19016 END DO 19017 END DO 19018 END DO 19019 END SUBROUTINE block_5_1_1 19020! ************************************************************************************************** 19021!> \brief ... 19022!> \param kbd ... 19023!> \param kbc ... 19024!> \param kad ... 19025!> \param kac ... 19026!> \param pbd ... 19027!> \param pbc ... 19028!> \param pad ... 19029!> \param pac ... 19030!> \param prim ... 19031!> \param scale ... 19032! ************************************************************************************************** 19033 SUBROUTINE block_5_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19034 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(5*1), kac(5*2), & 19035 pbd(1*1), pbc(1*2), pad(5*1), & 19036 pac(5*2), prim(5*1*2*1), scale 19037 19038 INTEGER :: ma, mb, mc, md, p_index 19039 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19040 19041 kbd(1:1*1) = 0.0_dp 19042 kbc(1:1*2) = 0.0_dp 19043 kad(1:5*1) = 0.0_dp 19044 kac(1:5*2) = 0.0_dp 19045 p_index = 0 19046 DO md = 1, 1 19047 DO mc = 1, 2 19048 DO mb = 1, 1 19049 ks_bd = 0.0_dp 19050 ks_bc = 0.0_dp 19051 p_bd = pbd((md - 1)*1 + mb) 19052 p_bc = pbc((mc - 1)*1 + mb) 19053 DO ma = 1, 5 19054 p_index = p_index + 1 19055 tmp = scale*prim(p_index) 19056 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19057 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19058 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19059 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19060 END DO 19061 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 19062 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 19063 END DO 19064 END DO 19065 END DO 19066 END SUBROUTINE block_5_1_2_1 19067! ************************************************************************************************** 19068!> \brief ... 19069!> \param md_max ... 19070!> \param kbd ... 19071!> \param kbc ... 19072!> \param kad ... 19073!> \param kac ... 19074!> \param pbd ... 19075!> \param pbc ... 19076!> \param pad ... 19077!> \param pac ... 19078!> \param prim ... 19079!> \param scale ... 19080! ************************************************************************************************** 19081 SUBROUTINE block_5_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19082 INTEGER :: md_max 19083 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(5*md_max), kac(5*2), pbd(1*md_max), pbc(1*2), & 19084 pad(5*md_max), pac(5*2), prim(5*1*2*md_max), scale 19085 19086 INTEGER :: ma, mb, mc, md, p_index 19087 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19088 19089 kbd(1:1*md_max) = 0.0_dp 19090 kbc(1:1*2) = 0.0_dp 19091 kad(1:5*md_max) = 0.0_dp 19092 kac(1:5*2) = 0.0_dp 19093 p_index = 0 19094 DO md = 1, md_max 19095 DO mc = 1, 2 19096 DO mb = 1, 1 19097 ks_bd = 0.0_dp 19098 ks_bc = 0.0_dp 19099 p_bd = pbd((md - 1)*1 + mb) 19100 p_bc = pbc((mc - 1)*1 + mb) 19101 DO ma = 1, 5 19102 p_index = p_index + 1 19103 tmp = scale*prim(p_index) 19104 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19105 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19106 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19107 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19108 END DO 19109 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 19110 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 19111 END DO 19112 END DO 19113 END DO 19114 END SUBROUTINE block_5_1_2 19115! ************************************************************************************************** 19116!> \brief ... 19117!> \param kbd ... 19118!> \param kbc ... 19119!> \param kad ... 19120!> \param kac ... 19121!> \param pbd ... 19122!> \param pbc ... 19123!> \param pad ... 19124!> \param pac ... 19125!> \param prim ... 19126!> \param scale ... 19127! ************************************************************************************************** 19128 SUBROUTINE block_5_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19129 REAL(KIND=dp) :: kbd(1*1), kbc(1*3), kad(5*1), kac(5*3), & 19130 pbd(1*1), pbc(1*3), pad(5*1), & 19131 pac(5*3), prim(5*1*3*1), scale 19132 19133 INTEGER :: ma, mb, mc, md, p_index 19134 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19135 19136 kbd(1:1*1) = 0.0_dp 19137 kbc(1:1*3) = 0.0_dp 19138 kad(1:5*1) = 0.0_dp 19139 kac(1:5*3) = 0.0_dp 19140 p_index = 0 19141 DO md = 1, 1 19142 DO mc = 1, 3 19143 DO mb = 1, 1 19144 ks_bd = 0.0_dp 19145 ks_bc = 0.0_dp 19146 p_bd = pbd((md - 1)*1 + mb) 19147 p_bc = pbc((mc - 1)*1 + mb) 19148 DO ma = 1, 5 19149 p_index = p_index + 1 19150 tmp = scale*prim(p_index) 19151 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19152 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19153 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19154 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19155 END DO 19156 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 19157 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 19158 END DO 19159 END DO 19160 END DO 19161 END SUBROUTINE block_5_1_3_1 19162! ************************************************************************************************** 19163!> \brief ... 19164!> \param md_max ... 19165!> \param kbd ... 19166!> \param kbc ... 19167!> \param kad ... 19168!> \param kac ... 19169!> \param pbd ... 19170!> \param pbc ... 19171!> \param pad ... 19172!> \param pac ... 19173!> \param prim ... 19174!> \param scale ... 19175! ************************************************************************************************** 19176 SUBROUTINE block_5_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19177 INTEGER :: md_max 19178 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*3), kad(5*md_max), kac(5*3), pbd(1*md_max), pbc(1*3), & 19179 pad(5*md_max), pac(5*3), prim(5*1*3*md_max), scale 19180 19181 INTEGER :: ma, mb, mc, md, p_index 19182 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19183 19184 kbd(1:1*md_max) = 0.0_dp 19185 kbc(1:1*3) = 0.0_dp 19186 kad(1:5*md_max) = 0.0_dp 19187 kac(1:5*3) = 0.0_dp 19188 p_index = 0 19189 DO md = 1, md_max 19190 DO mc = 1, 3 19191 DO mb = 1, 1 19192 ks_bd = 0.0_dp 19193 ks_bc = 0.0_dp 19194 p_bd = pbd((md - 1)*1 + mb) 19195 p_bc = pbc((mc - 1)*1 + mb) 19196 DO ma = 1, 5 19197 p_index = p_index + 1 19198 tmp = scale*prim(p_index) 19199 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19200 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19201 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19202 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19203 END DO 19204 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 19205 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 19206 END DO 19207 END DO 19208 END DO 19209 END SUBROUTINE block_5_1_3 19210! ************************************************************************************************** 19211!> \brief ... 19212!> \param mc_max ... 19213!> \param md_max ... 19214!> \param kbd ... 19215!> \param kbc ... 19216!> \param kad ... 19217!> \param kac ... 19218!> \param pbd ... 19219!> \param pbc ... 19220!> \param pad ... 19221!> \param pac ... 19222!> \param prim ... 19223!> \param scale ... 19224! ************************************************************************************************** 19225 SUBROUTINE block_5_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19226 INTEGER :: mc_max, md_max 19227 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(5*md_max), kac(5*mc_max), pbd(1*md_max), & 19228 pbc(1*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*1*mc_max*md_max), scale 19229 19230 INTEGER :: ma, mb, mc, md, p_index 19231 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19232 19233 kbd(1:1*md_max) = 0.0_dp 19234 kbc(1:1*mc_max) = 0.0_dp 19235 kad(1:5*md_max) = 0.0_dp 19236 kac(1:5*mc_max) = 0.0_dp 19237 p_index = 0 19238 DO md = 1, md_max 19239 DO mc = 1, mc_max 19240 DO mb = 1, 1 19241 ks_bd = 0.0_dp 19242 ks_bc = 0.0_dp 19243 p_bd = pbd((md - 1)*1 + mb) 19244 p_bc = pbc((mc - 1)*1 + mb) 19245 DO ma = 1, 5 19246 p_index = p_index + 1 19247 tmp = scale*prim(p_index) 19248 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19249 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19250 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19251 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19252 END DO 19253 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 19254 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 19255 END DO 19256 END DO 19257 END DO 19258 END SUBROUTINE block_5_1 19259! ************************************************************************************************** 19260!> \brief ... 19261!> \param kbd ... 19262!> \param kbc ... 19263!> \param kad ... 19264!> \param kac ... 19265!> \param pbd ... 19266!> \param pbc ... 19267!> \param pad ... 19268!> \param pac ... 19269!> \param prim ... 19270!> \param scale ... 19271! ************************************************************************************************** 19272 SUBROUTINE block_5_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19273 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(5*1), kac(5*1), & 19274 pbd(2*1), pbc(2*1), pad(5*1), & 19275 pac(5*1), prim(5*2*1*1), scale 19276 19277 INTEGER :: ma, mb, mc, md, p_index 19278 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19279 19280 kbd(1:2*1) = 0.0_dp 19281 kbc(1:2*1) = 0.0_dp 19282 kad(1:5*1) = 0.0_dp 19283 kac(1:5*1) = 0.0_dp 19284 p_index = 0 19285 DO md = 1, 1 19286 DO mc = 1, 1 19287 DO mb = 1, 2 19288 ks_bd = 0.0_dp 19289 ks_bc = 0.0_dp 19290 p_bd = pbd((md - 1)*2 + mb) 19291 p_bc = pbc((mc - 1)*2 + mb) 19292 DO ma = 1, 5 19293 p_index = p_index + 1 19294 tmp = scale*prim(p_index) 19295 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19296 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19297 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19298 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19299 END DO 19300 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 19301 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 19302 END DO 19303 END DO 19304 END DO 19305 END SUBROUTINE block_5_2_1_1 19306! ************************************************************************************************** 19307!> \brief ... 19308!> \param md_max ... 19309!> \param kbd ... 19310!> \param kbc ... 19311!> \param kad ... 19312!> \param kac ... 19313!> \param pbd ... 19314!> \param pbc ... 19315!> \param pad ... 19316!> \param pac ... 19317!> \param prim ... 19318!> \param scale ... 19319! ************************************************************************************************** 19320 SUBROUTINE block_5_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19321 INTEGER :: md_max 19322 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(5*md_max), kac(5*1), pbd(2*md_max), pbc(2*1), & 19323 pad(5*md_max), pac(5*1), prim(5*2*1*md_max), scale 19324 19325 INTEGER :: ma, mb, mc, md, p_index 19326 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19327 19328 kbd(1:2*md_max) = 0.0_dp 19329 kbc(1:2*1) = 0.0_dp 19330 kad(1:5*md_max) = 0.0_dp 19331 kac(1:5*1) = 0.0_dp 19332 p_index = 0 19333 DO md = 1, md_max 19334 DO mc = 1, 1 19335 DO mb = 1, 2 19336 ks_bd = 0.0_dp 19337 ks_bc = 0.0_dp 19338 p_bd = pbd((md - 1)*2 + mb) 19339 p_bc = pbc((mc - 1)*2 + mb) 19340 DO ma = 1, 5 19341 p_index = p_index + 1 19342 tmp = scale*prim(p_index) 19343 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19344 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19345 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19346 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19347 END DO 19348 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 19349 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 19350 END DO 19351 END DO 19352 END DO 19353 END SUBROUTINE block_5_2_1 19354! ************************************************************************************************** 19355!> \brief ... 19356!> \param mc_max ... 19357!> \param md_max ... 19358!> \param kbd ... 19359!> \param kbc ... 19360!> \param kad ... 19361!> \param kac ... 19362!> \param pbd ... 19363!> \param pbc ... 19364!> \param pad ... 19365!> \param pac ... 19366!> \param prim ... 19367!> \param scale ... 19368! ************************************************************************************************** 19369 SUBROUTINE block_5_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19370 INTEGER :: mc_max, md_max 19371 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(5*md_max), kac(5*mc_max), pbd(2*md_max), & 19372 pbc(2*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*2*mc_max*md_max), scale 19373 19374 INTEGER :: ma, mb, mc, md, p_index 19375 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19376 19377 kbd(1:2*md_max) = 0.0_dp 19378 kbc(1:2*mc_max) = 0.0_dp 19379 kad(1:5*md_max) = 0.0_dp 19380 kac(1:5*mc_max) = 0.0_dp 19381 p_index = 0 19382 DO md = 1, md_max 19383 DO mc = 1, mc_max 19384 DO mb = 1, 2 19385 ks_bd = 0.0_dp 19386 ks_bc = 0.0_dp 19387 p_bd = pbd((md - 1)*2 + mb) 19388 p_bc = pbc((mc - 1)*2 + mb) 19389 DO ma = 1, 5 19390 p_index = p_index + 1 19391 tmp = scale*prim(p_index) 19392 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19393 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19394 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19395 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19396 END DO 19397 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 19398 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 19399 END DO 19400 END DO 19401 END DO 19402 END SUBROUTINE block_5_2 19403! ************************************************************************************************** 19404!> \brief ... 19405!> \param kbd ... 19406!> \param kbc ... 19407!> \param kad ... 19408!> \param kac ... 19409!> \param pbd ... 19410!> \param pbc ... 19411!> \param pad ... 19412!> \param pac ... 19413!> \param prim ... 19414!> \param scale ... 19415! ************************************************************************************************** 19416 SUBROUTINE block_5_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19417 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(5*1), kac(5*1), & 19418 pbd(3*1), pbc(3*1), pad(5*1), & 19419 pac(5*1), prim(5*3*1*1), scale 19420 19421 INTEGER :: ma, mb, mc, md, p_index 19422 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19423 19424 kbd(1:3*1) = 0.0_dp 19425 kbc(1:3*1) = 0.0_dp 19426 kad(1:5*1) = 0.0_dp 19427 kac(1:5*1) = 0.0_dp 19428 p_index = 0 19429 DO md = 1, 1 19430 DO mc = 1, 1 19431 DO mb = 1, 3 19432 ks_bd = 0.0_dp 19433 ks_bc = 0.0_dp 19434 p_bd = pbd((md - 1)*3 + mb) 19435 p_bc = pbc((mc - 1)*3 + mb) 19436 DO ma = 1, 5 19437 p_index = p_index + 1 19438 tmp = scale*prim(p_index) 19439 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19440 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19441 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19442 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19443 END DO 19444 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 19445 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 19446 END DO 19447 END DO 19448 END DO 19449 END SUBROUTINE block_5_3_1_1 19450! ************************************************************************************************** 19451!> \brief ... 19452!> \param md_max ... 19453!> \param kbd ... 19454!> \param kbc ... 19455!> \param kad ... 19456!> \param kac ... 19457!> \param pbd ... 19458!> \param pbc ... 19459!> \param pad ... 19460!> \param pac ... 19461!> \param prim ... 19462!> \param scale ... 19463! ************************************************************************************************** 19464 SUBROUTINE block_5_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19465 INTEGER :: md_max 19466 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(5*md_max), kac(5*1), pbd(3*md_max), pbc(3*1), & 19467 pad(5*md_max), pac(5*1), prim(5*3*1*md_max), scale 19468 19469 INTEGER :: ma, mb, mc, md, p_index 19470 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19471 19472 kbd(1:3*md_max) = 0.0_dp 19473 kbc(1:3*1) = 0.0_dp 19474 kad(1:5*md_max) = 0.0_dp 19475 kac(1:5*1) = 0.0_dp 19476 p_index = 0 19477 DO md = 1, md_max 19478 DO mc = 1, 1 19479 DO mb = 1, 3 19480 ks_bd = 0.0_dp 19481 ks_bc = 0.0_dp 19482 p_bd = pbd((md - 1)*3 + mb) 19483 p_bc = pbc((mc - 1)*3 + mb) 19484 DO ma = 1, 5 19485 p_index = p_index + 1 19486 tmp = scale*prim(p_index) 19487 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19488 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19489 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19490 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19491 END DO 19492 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 19493 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 19494 END DO 19495 END DO 19496 END DO 19497 END SUBROUTINE block_5_3_1 19498! ************************************************************************************************** 19499!> \brief ... 19500!> \param mc_max ... 19501!> \param md_max ... 19502!> \param kbd ... 19503!> \param kbc ... 19504!> \param kad ... 19505!> \param kac ... 19506!> \param pbd ... 19507!> \param pbc ... 19508!> \param pad ... 19509!> \param pac ... 19510!> \param prim ... 19511!> \param scale ... 19512! ************************************************************************************************** 19513 SUBROUTINE block_5_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19514 INTEGER :: mc_max, md_max 19515 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(5*md_max), kac(5*mc_max), pbd(3*md_max), & 19516 pbc(3*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*3*mc_max*md_max), scale 19517 19518 INTEGER :: ma, mb, mc, md, p_index 19519 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19520 19521 kbd(1:3*md_max) = 0.0_dp 19522 kbc(1:3*mc_max) = 0.0_dp 19523 kad(1:5*md_max) = 0.0_dp 19524 kac(1:5*mc_max) = 0.0_dp 19525 p_index = 0 19526 DO md = 1, md_max 19527 DO mc = 1, mc_max 19528 DO mb = 1, 3 19529 ks_bd = 0.0_dp 19530 ks_bc = 0.0_dp 19531 p_bd = pbd((md - 1)*3 + mb) 19532 p_bc = pbc((mc - 1)*3 + mb) 19533 DO ma = 1, 5 19534 p_index = p_index + 1 19535 tmp = scale*prim(p_index) 19536 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19537 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19538 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19539 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19540 END DO 19541 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 19542 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 19543 END DO 19544 END DO 19545 END DO 19546 END SUBROUTINE block_5_3 19547! ************************************************************************************************** 19548!> \brief ... 19549!> \param mc_max ... 19550!> \param md_max ... 19551!> \param kbd ... 19552!> \param kbc ... 19553!> \param kad ... 19554!> \param kac ... 19555!> \param pbd ... 19556!> \param pbc ... 19557!> \param pad ... 19558!> \param pac ... 19559!> \param prim ... 19560!> \param scale ... 19561! ************************************************************************************************** 19562 SUBROUTINE block_5_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19563 INTEGER :: mc_max, md_max 19564 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(5*md_max), kac(5*mc_max), pbd(4*md_max), & 19565 pbc(4*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*4*mc_max*md_max), scale 19566 19567 INTEGER :: ma, mb, mc, md, p_index 19568 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19569 19570 kbd(1:4*md_max) = 0.0_dp 19571 kbc(1:4*mc_max) = 0.0_dp 19572 kad(1:5*md_max) = 0.0_dp 19573 kac(1:5*mc_max) = 0.0_dp 19574 p_index = 0 19575 DO md = 1, md_max 19576 DO mc = 1, mc_max 19577 DO mb = 1, 4 19578 ks_bd = 0.0_dp 19579 ks_bc = 0.0_dp 19580 p_bd = pbd((md - 1)*4 + mb) 19581 p_bc = pbc((mc - 1)*4 + mb) 19582 DO ma = 1, 5 19583 p_index = p_index + 1 19584 tmp = scale*prim(p_index) 19585 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19586 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19587 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19588 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19589 END DO 19590 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 19591 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 19592 END DO 19593 END DO 19594 END DO 19595 END SUBROUTINE block_5_4 19596! ************************************************************************************************** 19597!> \brief ... 19598!> \param mc_max ... 19599!> \param md_max ... 19600!> \param kbd ... 19601!> \param kbc ... 19602!> \param kad ... 19603!> \param kac ... 19604!> \param pbd ... 19605!> \param pbc ... 19606!> \param pad ... 19607!> \param pac ... 19608!> \param prim ... 19609!> \param scale ... 19610! ************************************************************************************************** 19611 SUBROUTINE block_5_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19612 INTEGER :: mc_max, md_max 19613 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(5*md_max), kac(5*mc_max), pbd(5*md_max), & 19614 pbc(5*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*5*mc_max*md_max), scale 19615 19616 INTEGER :: ma, mb, mc, md, p_index 19617 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19618 19619 kbd(1:5*md_max) = 0.0_dp 19620 kbc(1:5*mc_max) = 0.0_dp 19621 kad(1:5*md_max) = 0.0_dp 19622 kac(1:5*mc_max) = 0.0_dp 19623 p_index = 0 19624 DO md = 1, md_max 19625 DO mc = 1, mc_max 19626 DO mb = 1, 5 19627 ks_bd = 0.0_dp 19628 ks_bc = 0.0_dp 19629 p_bd = pbd((md - 1)*5 + mb) 19630 p_bc = pbc((mc - 1)*5 + mb) 19631 DO ma = 1, 5 19632 p_index = p_index + 1 19633 tmp = scale*prim(p_index) 19634 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19635 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19636 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19637 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19638 END DO 19639 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 19640 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 19641 END DO 19642 END DO 19643 END DO 19644 END SUBROUTINE block_5_5 19645! ************************************************************************************************** 19646!> \brief ... 19647!> \param mc_max ... 19648!> \param md_max ... 19649!> \param kbd ... 19650!> \param kbc ... 19651!> \param kad ... 19652!> \param kac ... 19653!> \param pbd ... 19654!> \param pbc ... 19655!> \param pad ... 19656!> \param pac ... 19657!> \param prim ... 19658!> \param scale ... 19659! ************************************************************************************************** 19660 SUBROUTINE block_5_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19661 INTEGER :: mc_max, md_max 19662 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(5*md_max), kac(5*mc_max), pbd(6*md_max), & 19663 pbc(6*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*6*mc_max*md_max), scale 19664 19665 INTEGER :: ma, mb, mc, md, p_index 19666 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19667 19668 kbd(1:6*md_max) = 0.0_dp 19669 kbc(1:6*mc_max) = 0.0_dp 19670 kad(1:5*md_max) = 0.0_dp 19671 kac(1:5*mc_max) = 0.0_dp 19672 p_index = 0 19673 DO md = 1, md_max 19674 DO mc = 1, mc_max 19675 DO mb = 1, 6 19676 ks_bd = 0.0_dp 19677 ks_bc = 0.0_dp 19678 p_bd = pbd((md - 1)*6 + mb) 19679 p_bc = pbc((mc - 1)*6 + mb) 19680 DO ma = 1, 5 19681 p_index = p_index + 1 19682 tmp = scale*prim(p_index) 19683 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19684 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19685 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19686 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19687 END DO 19688 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 19689 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 19690 END DO 19691 END DO 19692 END DO 19693 END SUBROUTINE block_5_6 19694! ************************************************************************************************** 19695!> \brief ... 19696!> \param mc_max ... 19697!> \param md_max ... 19698!> \param kbd ... 19699!> \param kbc ... 19700!> \param kad ... 19701!> \param kac ... 19702!> \param pbd ... 19703!> \param pbc ... 19704!> \param pad ... 19705!> \param pac ... 19706!> \param prim ... 19707!> \param scale ... 19708! ************************************************************************************************** 19709 SUBROUTINE block_5_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19710 INTEGER :: mc_max, md_max 19711 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(5*md_max), kac(5*mc_max), pbd(7*md_max), & 19712 pbc(7*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*7*mc_max*md_max), scale 19713 19714 INTEGER :: ma, mb, mc, md, p_index 19715 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19716 19717 kbd(1:7*md_max) = 0.0_dp 19718 kbc(1:7*mc_max) = 0.0_dp 19719 kad(1:5*md_max) = 0.0_dp 19720 kac(1:5*mc_max) = 0.0_dp 19721 p_index = 0 19722 DO md = 1, md_max 19723 DO mc = 1, mc_max 19724 DO mb = 1, 7 19725 ks_bd = 0.0_dp 19726 ks_bc = 0.0_dp 19727 p_bd = pbd((md - 1)*7 + mb) 19728 p_bc = pbc((mc - 1)*7 + mb) 19729 DO ma = 1, 5 19730 p_index = p_index + 1 19731 tmp = scale*prim(p_index) 19732 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19733 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19734 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19735 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19736 END DO 19737 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 19738 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 19739 END DO 19740 END DO 19741 END DO 19742 END SUBROUTINE block_5_7 19743! ************************************************************************************************** 19744!> \brief ... 19745!> \param mc_max ... 19746!> \param md_max ... 19747!> \param kbd ... 19748!> \param kbc ... 19749!> \param kad ... 19750!> \param kac ... 19751!> \param pbd ... 19752!> \param pbc ... 19753!> \param pad ... 19754!> \param pac ... 19755!> \param prim ... 19756!> \param scale ... 19757! ************************************************************************************************** 19758 SUBROUTINE block_5_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19759 INTEGER :: mc_max, md_max 19760 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(5*md_max), kac(5*mc_max), pbd(9*md_max), & 19761 pbc(9*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*9*mc_max*md_max), scale 19762 19763 INTEGER :: ma, mb, mc, md, p_index 19764 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19765 19766 kbd(1:9*md_max) = 0.0_dp 19767 kbc(1:9*mc_max) = 0.0_dp 19768 kad(1:5*md_max) = 0.0_dp 19769 kac(1:5*mc_max) = 0.0_dp 19770 p_index = 0 19771 DO md = 1, md_max 19772 DO mc = 1, mc_max 19773 DO mb = 1, 9 19774 ks_bd = 0.0_dp 19775 ks_bc = 0.0_dp 19776 p_bd = pbd((md - 1)*9 + mb) 19777 p_bc = pbc((mc - 1)*9 + mb) 19778 DO ma = 1, 5 19779 p_index = p_index + 1 19780 tmp = scale*prim(p_index) 19781 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19782 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19783 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19784 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19785 END DO 19786 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 19787 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 19788 END DO 19789 END DO 19790 END DO 19791 END SUBROUTINE block_5_9 19792! ************************************************************************************************** 19793!> \brief ... 19794!> \param mc_max ... 19795!> \param md_max ... 19796!> \param kbd ... 19797!> \param kbc ... 19798!> \param kad ... 19799!> \param kac ... 19800!> \param pbd ... 19801!> \param pbc ... 19802!> \param pad ... 19803!> \param pac ... 19804!> \param prim ... 19805!> \param scale ... 19806! ************************************************************************************************** 19807 SUBROUTINE block_5_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19808 INTEGER :: mc_max, md_max 19809 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(5*md_max), kac(5*mc_max), & 19810 pbd(10*md_max), pbc(10*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*10*mc_max*md_max), & 19811 scale 19812 19813 INTEGER :: ma, mb, mc, md, p_index 19814 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19815 19816 kbd(1:10*md_max) = 0.0_dp 19817 kbc(1:10*mc_max) = 0.0_dp 19818 kad(1:5*md_max) = 0.0_dp 19819 kac(1:5*mc_max) = 0.0_dp 19820 p_index = 0 19821 DO md = 1, md_max 19822 DO mc = 1, mc_max 19823 DO mb = 1, 10 19824 ks_bd = 0.0_dp 19825 ks_bc = 0.0_dp 19826 p_bd = pbd((md - 1)*10 + mb) 19827 p_bc = pbc((mc - 1)*10 + mb) 19828 DO ma = 1, 5 19829 p_index = p_index + 1 19830 tmp = scale*prim(p_index) 19831 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19832 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19833 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19834 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19835 END DO 19836 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 19837 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 19838 END DO 19839 END DO 19840 END DO 19841 END SUBROUTINE block_5_10 19842! ************************************************************************************************** 19843!> \brief ... 19844!> \param mc_max ... 19845!> \param md_max ... 19846!> \param kbd ... 19847!> \param kbc ... 19848!> \param kad ... 19849!> \param kac ... 19850!> \param pbd ... 19851!> \param pbc ... 19852!> \param pad ... 19853!> \param pac ... 19854!> \param prim ... 19855!> \param scale ... 19856! ************************************************************************************************** 19857 SUBROUTINE block_5_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19858 INTEGER :: mc_max, md_max 19859 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(5*md_max), kac(5*mc_max), & 19860 pbd(11*md_max), pbc(11*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*11*mc_max*md_max), & 19861 scale 19862 19863 INTEGER :: ma, mb, mc, md, p_index 19864 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19865 19866 kbd(1:11*md_max) = 0.0_dp 19867 kbc(1:11*mc_max) = 0.0_dp 19868 kad(1:5*md_max) = 0.0_dp 19869 kac(1:5*mc_max) = 0.0_dp 19870 p_index = 0 19871 DO md = 1, md_max 19872 DO mc = 1, mc_max 19873 DO mb = 1, 11 19874 ks_bd = 0.0_dp 19875 ks_bc = 0.0_dp 19876 p_bd = pbd((md - 1)*11 + mb) 19877 p_bc = pbc((mc - 1)*11 + mb) 19878 DO ma = 1, 5 19879 p_index = p_index + 1 19880 tmp = scale*prim(p_index) 19881 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19882 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19883 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19884 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19885 END DO 19886 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 19887 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 19888 END DO 19889 END DO 19890 END DO 19891 END SUBROUTINE block_5_11 19892! ************************************************************************************************** 19893!> \brief ... 19894!> \param mc_max ... 19895!> \param md_max ... 19896!> \param kbd ... 19897!> \param kbc ... 19898!> \param kad ... 19899!> \param kac ... 19900!> \param pbd ... 19901!> \param pbc ... 19902!> \param pad ... 19903!> \param pac ... 19904!> \param prim ... 19905!> \param scale ... 19906! ************************************************************************************************** 19907 SUBROUTINE block_5_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19908 INTEGER :: mc_max, md_max 19909 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(5*md_max), kac(5*mc_max), & 19910 pbd(15*md_max), pbc(15*mc_max), pad(5*md_max), pac(5*mc_max), prim(5*15*mc_max*md_max), & 19911 scale 19912 19913 INTEGER :: ma, mb, mc, md, p_index 19914 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19915 19916 kbd(1:15*md_max) = 0.0_dp 19917 kbc(1:15*mc_max) = 0.0_dp 19918 kad(1:5*md_max) = 0.0_dp 19919 kac(1:5*mc_max) = 0.0_dp 19920 p_index = 0 19921 DO md = 1, md_max 19922 DO mc = 1, mc_max 19923 DO mb = 1, 15 19924 ks_bd = 0.0_dp 19925 ks_bc = 0.0_dp 19926 p_bd = pbd((md - 1)*15 + mb) 19927 p_bc = pbc((mc - 1)*15 + mb) 19928 DO ma = 1, 5 19929 p_index = p_index + 1 19930 tmp = scale*prim(p_index) 19931 ks_bc = ks_bc + tmp*pad((md - 1)*5 + ma) 19932 ks_bd = ks_bd + tmp*pac((mc - 1)*5 + ma) 19933 kad((md - 1)*5 + ma) = kad((md - 1)*5 + ma) - tmp*p_bc 19934 kac((mc - 1)*5 + ma) = kac((mc - 1)*5 + ma) - tmp*p_bd 19935 END DO 19936 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 19937 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 19938 END DO 19939 END DO 19940 END DO 19941 END SUBROUTINE block_5_15 19942! ************************************************************************************************** 19943!> \brief ... 19944!> \param kbd ... 19945!> \param kbc ... 19946!> \param kad ... 19947!> \param kac ... 19948!> \param pbd ... 19949!> \param pbc ... 19950!> \param pad ... 19951!> \param pac ... 19952!> \param prim ... 19953!> \param scale ... 19954! ************************************************************************************************** 19955 SUBROUTINE block_6_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 19956 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(6*1), kac(6*1), & 19957 pbd(1*1), pbc(1*1), pad(6*1), & 19958 pac(6*1), prim(6*1*1*1), scale 19959 19960 INTEGER :: ma, mb, mc, md, p_index 19961 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 19962 19963 kbd(1:1*1) = 0.0_dp 19964 kbc(1:1*1) = 0.0_dp 19965 kad(1:6*1) = 0.0_dp 19966 kac(1:6*1) = 0.0_dp 19967 p_index = 0 19968 DO md = 1, 1 19969 DO mc = 1, 1 19970 DO mb = 1, 1 19971 ks_bd = 0.0_dp 19972 ks_bc = 0.0_dp 19973 p_bd = pbd((md - 1)*1 + mb) 19974 p_bc = pbc((mc - 1)*1 + mb) 19975 DO ma = 1, 6 19976 p_index = p_index + 1 19977 tmp = scale*prim(p_index) 19978 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 19979 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 19980 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 19981 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 19982 END DO 19983 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 19984 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 19985 END DO 19986 END DO 19987 END DO 19988 END SUBROUTINE block_6_1_1_1 19989! ************************************************************************************************** 19990!> \brief ... 19991!> \param kbd ... 19992!> \param kbc ... 19993!> \param kad ... 19994!> \param kac ... 19995!> \param pbd ... 19996!> \param pbc ... 19997!> \param pad ... 19998!> \param pac ... 19999!> \param prim ... 20000!> \param scale ... 20001! ************************************************************************************************** 20002 SUBROUTINE block_6_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20003 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(6*2), kac(6*1), & 20004 pbd(1*2), pbc(1*1), pad(6*2), & 20005 pac(6*1), prim(6*1*1*2), scale 20006 20007 INTEGER :: ma, mb, mc, md, p_index 20008 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20009 20010 kbd(1:1*2) = 0.0_dp 20011 kbc(1:1*1) = 0.0_dp 20012 kad(1:6*2) = 0.0_dp 20013 kac(1:6*1) = 0.0_dp 20014 p_index = 0 20015 DO md = 1, 2 20016 DO mc = 1, 1 20017 DO mb = 1, 1 20018 ks_bd = 0.0_dp 20019 ks_bc = 0.0_dp 20020 p_bd = pbd((md - 1)*1 + mb) 20021 p_bc = pbc((mc - 1)*1 + mb) 20022 DO ma = 1, 6 20023 p_index = p_index + 1 20024 tmp = scale*prim(p_index) 20025 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20026 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20027 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20028 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20029 END DO 20030 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20031 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20032 END DO 20033 END DO 20034 END DO 20035 END SUBROUTINE block_6_1_1_2 20036! ************************************************************************************************** 20037!> \brief ... 20038!> \param kbd ... 20039!> \param kbc ... 20040!> \param kad ... 20041!> \param kac ... 20042!> \param pbd ... 20043!> \param pbc ... 20044!> \param pad ... 20045!> \param pac ... 20046!> \param prim ... 20047!> \param scale ... 20048! ************************************************************************************************** 20049 SUBROUTINE block_6_1_1_3(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20050 REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(6*3), kac(6*1), & 20051 pbd(1*3), pbc(1*1), pad(6*3), & 20052 pac(6*1), prim(6*1*1*3), scale 20053 20054 INTEGER :: ma, mb, mc, md, p_index 20055 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20056 20057 kbd(1:1*3) = 0.0_dp 20058 kbc(1:1*1) = 0.0_dp 20059 kad(1:6*3) = 0.0_dp 20060 kac(1:6*1) = 0.0_dp 20061 p_index = 0 20062 DO md = 1, 3 20063 DO mc = 1, 1 20064 DO mb = 1, 1 20065 ks_bd = 0.0_dp 20066 ks_bc = 0.0_dp 20067 p_bd = pbd((md - 1)*1 + mb) 20068 p_bc = pbc((mc - 1)*1 + mb) 20069 DO ma = 1, 6 20070 p_index = p_index + 1 20071 tmp = scale*prim(p_index) 20072 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20073 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20074 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20075 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20076 END DO 20077 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20078 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20079 END DO 20080 END DO 20081 END DO 20082 END SUBROUTINE block_6_1_1_3 20083! ************************************************************************************************** 20084!> \brief ... 20085!> \param md_max ... 20086!> \param kbd ... 20087!> \param kbc ... 20088!> \param kad ... 20089!> \param kac ... 20090!> \param pbd ... 20091!> \param pbc ... 20092!> \param pad ... 20093!> \param pac ... 20094!> \param prim ... 20095!> \param scale ... 20096! ************************************************************************************************** 20097 SUBROUTINE block_6_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20098 INTEGER :: md_max 20099 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(6*md_max), kac(6*1), pbd(1*md_max), pbc(1*1), & 20100 pad(6*md_max), pac(6*1), prim(6*1*1*md_max), scale 20101 20102 INTEGER :: ma, mb, mc, md, p_index 20103 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20104 20105 kbd(1:1*md_max) = 0.0_dp 20106 kbc(1:1*1) = 0.0_dp 20107 kad(1:6*md_max) = 0.0_dp 20108 kac(1:6*1) = 0.0_dp 20109 p_index = 0 20110 DO md = 1, md_max 20111 DO mc = 1, 1 20112 DO mb = 1, 1 20113 ks_bd = 0.0_dp 20114 ks_bc = 0.0_dp 20115 p_bd = pbd((md - 1)*1 + mb) 20116 p_bc = pbc((mc - 1)*1 + mb) 20117 DO ma = 1, 6 20118 p_index = p_index + 1 20119 tmp = scale*prim(p_index) 20120 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20121 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20122 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20123 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20124 END DO 20125 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20126 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20127 END DO 20128 END DO 20129 END DO 20130 END SUBROUTINE block_6_1_1 20131! ************************************************************************************************** 20132!> \brief ... 20133!> \param kbd ... 20134!> \param kbc ... 20135!> \param kad ... 20136!> \param kac ... 20137!> \param pbd ... 20138!> \param pbc ... 20139!> \param pad ... 20140!> \param pac ... 20141!> \param prim ... 20142!> \param scale ... 20143! ************************************************************************************************** 20144 SUBROUTINE block_6_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20145 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(6*1), kac(6*2), & 20146 pbd(1*1), pbc(1*2), pad(6*1), & 20147 pac(6*2), prim(6*1*2*1), scale 20148 20149 INTEGER :: ma, mb, mc, md, p_index 20150 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20151 20152 kbd(1:1*1) = 0.0_dp 20153 kbc(1:1*2) = 0.0_dp 20154 kad(1:6*1) = 0.0_dp 20155 kac(1:6*2) = 0.0_dp 20156 p_index = 0 20157 DO md = 1, 1 20158 DO mc = 1, 2 20159 DO mb = 1, 1 20160 ks_bd = 0.0_dp 20161 ks_bc = 0.0_dp 20162 p_bd = pbd((md - 1)*1 + mb) 20163 p_bc = pbc((mc - 1)*1 + mb) 20164 DO ma = 1, 6 20165 p_index = p_index + 1 20166 tmp = scale*prim(p_index) 20167 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20168 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20169 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20170 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20171 END DO 20172 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20173 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20174 END DO 20175 END DO 20176 END DO 20177 END SUBROUTINE block_6_1_2_1 20178! ************************************************************************************************** 20179!> \brief ... 20180!> \param md_max ... 20181!> \param kbd ... 20182!> \param kbc ... 20183!> \param kad ... 20184!> \param kac ... 20185!> \param pbd ... 20186!> \param pbc ... 20187!> \param pad ... 20188!> \param pac ... 20189!> \param prim ... 20190!> \param scale ... 20191! ************************************************************************************************** 20192 SUBROUTINE block_6_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20193 INTEGER :: md_max 20194 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(6*md_max), kac(6*2), pbd(1*md_max), pbc(1*2), & 20195 pad(6*md_max), pac(6*2), prim(6*1*2*md_max), scale 20196 20197 INTEGER :: ma, mb, mc, md, p_index 20198 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20199 20200 kbd(1:1*md_max) = 0.0_dp 20201 kbc(1:1*2) = 0.0_dp 20202 kad(1:6*md_max) = 0.0_dp 20203 kac(1:6*2) = 0.0_dp 20204 p_index = 0 20205 DO md = 1, md_max 20206 DO mc = 1, 2 20207 DO mb = 1, 1 20208 ks_bd = 0.0_dp 20209 ks_bc = 0.0_dp 20210 p_bd = pbd((md - 1)*1 + mb) 20211 p_bc = pbc((mc - 1)*1 + mb) 20212 DO ma = 1, 6 20213 p_index = p_index + 1 20214 tmp = scale*prim(p_index) 20215 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20216 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20217 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20218 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20219 END DO 20220 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20221 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20222 END DO 20223 END DO 20224 END DO 20225 END SUBROUTINE block_6_1_2 20226! ************************************************************************************************** 20227!> \brief ... 20228!> \param kbd ... 20229!> \param kbc ... 20230!> \param kad ... 20231!> \param kac ... 20232!> \param pbd ... 20233!> \param pbc ... 20234!> \param pad ... 20235!> \param pac ... 20236!> \param prim ... 20237!> \param scale ... 20238! ************************************************************************************************** 20239 SUBROUTINE block_6_1_3_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20240 REAL(KIND=dp) :: kbd(1*1), kbc(1*3), kad(6*1), kac(6*3), & 20241 pbd(1*1), pbc(1*3), pad(6*1), & 20242 pac(6*3), prim(6*1*3*1), scale 20243 20244 INTEGER :: ma, mb, mc, md, p_index 20245 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20246 20247 kbd(1:1*1) = 0.0_dp 20248 kbc(1:1*3) = 0.0_dp 20249 kad(1:6*1) = 0.0_dp 20250 kac(1:6*3) = 0.0_dp 20251 p_index = 0 20252 DO md = 1, 1 20253 DO mc = 1, 3 20254 DO mb = 1, 1 20255 ks_bd = 0.0_dp 20256 ks_bc = 0.0_dp 20257 p_bd = pbd((md - 1)*1 + mb) 20258 p_bc = pbc((mc - 1)*1 + mb) 20259 DO ma = 1, 6 20260 p_index = p_index + 1 20261 tmp = scale*prim(p_index) 20262 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20263 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20264 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20265 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20266 END DO 20267 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20268 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20269 END DO 20270 END DO 20271 END DO 20272 END SUBROUTINE block_6_1_3_1 20273! ************************************************************************************************** 20274!> \brief ... 20275!> \param md_max ... 20276!> \param kbd ... 20277!> \param kbc ... 20278!> \param kad ... 20279!> \param kac ... 20280!> \param pbd ... 20281!> \param pbc ... 20282!> \param pad ... 20283!> \param pac ... 20284!> \param prim ... 20285!> \param scale ... 20286! ************************************************************************************************** 20287 SUBROUTINE block_6_1_3(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20288 INTEGER :: md_max 20289 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*3), kad(6*md_max), kac(6*3), pbd(1*md_max), pbc(1*3), & 20290 pad(6*md_max), pac(6*3), prim(6*1*3*md_max), scale 20291 20292 INTEGER :: ma, mb, mc, md, p_index 20293 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20294 20295 kbd(1:1*md_max) = 0.0_dp 20296 kbc(1:1*3) = 0.0_dp 20297 kad(1:6*md_max) = 0.0_dp 20298 kac(1:6*3) = 0.0_dp 20299 p_index = 0 20300 DO md = 1, md_max 20301 DO mc = 1, 3 20302 DO mb = 1, 1 20303 ks_bd = 0.0_dp 20304 ks_bc = 0.0_dp 20305 p_bd = pbd((md - 1)*1 + mb) 20306 p_bc = pbc((mc - 1)*1 + mb) 20307 DO ma = 1, 6 20308 p_index = p_index + 1 20309 tmp = scale*prim(p_index) 20310 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20311 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20312 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20313 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20314 END DO 20315 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20316 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20317 END DO 20318 END DO 20319 END DO 20320 END SUBROUTINE block_6_1_3 20321! ************************************************************************************************** 20322!> \brief ... 20323!> \param mc_max ... 20324!> \param md_max ... 20325!> \param kbd ... 20326!> \param kbc ... 20327!> \param kad ... 20328!> \param kac ... 20329!> \param pbd ... 20330!> \param pbc ... 20331!> \param pad ... 20332!> \param pac ... 20333!> \param prim ... 20334!> \param scale ... 20335! ************************************************************************************************** 20336 SUBROUTINE block_6_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20337 INTEGER :: mc_max, md_max 20338 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(6*md_max), kac(6*mc_max), pbd(1*md_max), & 20339 pbc(1*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*1*mc_max*md_max), scale 20340 20341 INTEGER :: ma, mb, mc, md, p_index 20342 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20343 20344 kbd(1:1*md_max) = 0.0_dp 20345 kbc(1:1*mc_max) = 0.0_dp 20346 kad(1:6*md_max) = 0.0_dp 20347 kac(1:6*mc_max) = 0.0_dp 20348 p_index = 0 20349 DO md = 1, md_max 20350 DO mc = 1, mc_max 20351 DO mb = 1, 1 20352 ks_bd = 0.0_dp 20353 ks_bc = 0.0_dp 20354 p_bd = pbd((md - 1)*1 + mb) 20355 p_bc = pbc((mc - 1)*1 + mb) 20356 DO ma = 1, 6 20357 p_index = p_index + 1 20358 tmp = scale*prim(p_index) 20359 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20360 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20361 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20362 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20363 END DO 20364 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 20365 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 20366 END DO 20367 END DO 20368 END DO 20369 END SUBROUTINE block_6_1 20370! ************************************************************************************************** 20371!> \brief ... 20372!> \param kbd ... 20373!> \param kbc ... 20374!> \param kad ... 20375!> \param kac ... 20376!> \param pbd ... 20377!> \param pbc ... 20378!> \param pad ... 20379!> \param pac ... 20380!> \param prim ... 20381!> \param scale ... 20382! ************************************************************************************************** 20383 SUBROUTINE block_6_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20384 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(6*1), kac(6*1), & 20385 pbd(2*1), pbc(2*1), pad(6*1), & 20386 pac(6*1), prim(6*2*1*1), scale 20387 20388 INTEGER :: ma, mb, mc, md, p_index 20389 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20390 20391 kbd(1:2*1) = 0.0_dp 20392 kbc(1:2*1) = 0.0_dp 20393 kad(1:6*1) = 0.0_dp 20394 kac(1:6*1) = 0.0_dp 20395 p_index = 0 20396 DO md = 1, 1 20397 DO mc = 1, 1 20398 DO mb = 1, 2 20399 ks_bd = 0.0_dp 20400 ks_bc = 0.0_dp 20401 p_bd = pbd((md - 1)*2 + mb) 20402 p_bc = pbc((mc - 1)*2 + mb) 20403 DO ma = 1, 6 20404 p_index = p_index + 1 20405 tmp = scale*prim(p_index) 20406 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20407 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20408 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20409 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20410 END DO 20411 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 20412 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 20413 END DO 20414 END DO 20415 END DO 20416 END SUBROUTINE block_6_2_1_1 20417! ************************************************************************************************** 20418!> \brief ... 20419!> \param md_max ... 20420!> \param kbd ... 20421!> \param kbc ... 20422!> \param kad ... 20423!> \param kac ... 20424!> \param pbd ... 20425!> \param pbc ... 20426!> \param pad ... 20427!> \param pac ... 20428!> \param prim ... 20429!> \param scale ... 20430! ************************************************************************************************** 20431 SUBROUTINE block_6_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20432 INTEGER :: md_max 20433 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(6*md_max), kac(6*1), pbd(2*md_max), pbc(2*1), & 20434 pad(6*md_max), pac(6*1), prim(6*2*1*md_max), scale 20435 20436 INTEGER :: ma, mb, mc, md, p_index 20437 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20438 20439 kbd(1:2*md_max) = 0.0_dp 20440 kbc(1:2*1) = 0.0_dp 20441 kad(1:6*md_max) = 0.0_dp 20442 kac(1:6*1) = 0.0_dp 20443 p_index = 0 20444 DO md = 1, md_max 20445 DO mc = 1, 1 20446 DO mb = 1, 2 20447 ks_bd = 0.0_dp 20448 ks_bc = 0.0_dp 20449 p_bd = pbd((md - 1)*2 + mb) 20450 p_bc = pbc((mc - 1)*2 + mb) 20451 DO ma = 1, 6 20452 p_index = p_index + 1 20453 tmp = scale*prim(p_index) 20454 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20455 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20456 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20457 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20458 END DO 20459 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 20460 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 20461 END DO 20462 END DO 20463 END DO 20464 END SUBROUTINE block_6_2_1 20465! ************************************************************************************************** 20466!> \brief ... 20467!> \param mc_max ... 20468!> \param md_max ... 20469!> \param kbd ... 20470!> \param kbc ... 20471!> \param kad ... 20472!> \param kac ... 20473!> \param pbd ... 20474!> \param pbc ... 20475!> \param pad ... 20476!> \param pac ... 20477!> \param prim ... 20478!> \param scale ... 20479! ************************************************************************************************** 20480 SUBROUTINE block_6_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20481 INTEGER :: mc_max, md_max 20482 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(6*md_max), kac(6*mc_max), pbd(2*md_max), & 20483 pbc(2*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*2*mc_max*md_max), scale 20484 20485 INTEGER :: ma, mb, mc, md, p_index 20486 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20487 20488 kbd(1:2*md_max) = 0.0_dp 20489 kbc(1:2*mc_max) = 0.0_dp 20490 kad(1:6*md_max) = 0.0_dp 20491 kac(1:6*mc_max) = 0.0_dp 20492 p_index = 0 20493 DO md = 1, md_max 20494 DO mc = 1, mc_max 20495 DO mb = 1, 2 20496 ks_bd = 0.0_dp 20497 ks_bc = 0.0_dp 20498 p_bd = pbd((md - 1)*2 + mb) 20499 p_bc = pbc((mc - 1)*2 + mb) 20500 DO ma = 1, 6 20501 p_index = p_index + 1 20502 tmp = scale*prim(p_index) 20503 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20504 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20505 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20506 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20507 END DO 20508 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 20509 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 20510 END DO 20511 END DO 20512 END DO 20513 END SUBROUTINE block_6_2 20514! ************************************************************************************************** 20515!> \brief ... 20516!> \param kbd ... 20517!> \param kbc ... 20518!> \param kad ... 20519!> \param kac ... 20520!> \param pbd ... 20521!> \param pbc ... 20522!> \param pad ... 20523!> \param pac ... 20524!> \param prim ... 20525!> \param scale ... 20526! ************************************************************************************************** 20527 SUBROUTINE block_6_3_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20528 REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(6*1), kac(6*1), & 20529 pbd(3*1), pbc(3*1), pad(6*1), & 20530 pac(6*1), prim(6*3*1*1), scale 20531 20532 INTEGER :: ma, mb, mc, md, p_index 20533 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20534 20535 kbd(1:3*1) = 0.0_dp 20536 kbc(1:3*1) = 0.0_dp 20537 kad(1:6*1) = 0.0_dp 20538 kac(1:6*1) = 0.0_dp 20539 p_index = 0 20540 DO md = 1, 1 20541 DO mc = 1, 1 20542 DO mb = 1, 3 20543 ks_bd = 0.0_dp 20544 ks_bc = 0.0_dp 20545 p_bd = pbd((md - 1)*3 + mb) 20546 p_bc = pbc((mc - 1)*3 + mb) 20547 DO ma = 1, 6 20548 p_index = p_index + 1 20549 tmp = scale*prim(p_index) 20550 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20551 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20552 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20553 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20554 END DO 20555 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 20556 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 20557 END DO 20558 END DO 20559 END DO 20560 END SUBROUTINE block_6_3_1_1 20561! ************************************************************************************************** 20562!> \brief ... 20563!> \param md_max ... 20564!> \param kbd ... 20565!> \param kbc ... 20566!> \param kad ... 20567!> \param kac ... 20568!> \param pbd ... 20569!> \param pbc ... 20570!> \param pad ... 20571!> \param pac ... 20572!> \param prim ... 20573!> \param scale ... 20574! ************************************************************************************************** 20575 SUBROUTINE block_6_3_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20576 INTEGER :: md_max 20577 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(6*md_max), kac(6*1), pbd(3*md_max), pbc(3*1), & 20578 pad(6*md_max), pac(6*1), prim(6*3*1*md_max), scale 20579 20580 INTEGER :: ma, mb, mc, md, p_index 20581 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20582 20583 kbd(1:3*md_max) = 0.0_dp 20584 kbc(1:3*1) = 0.0_dp 20585 kad(1:6*md_max) = 0.0_dp 20586 kac(1:6*1) = 0.0_dp 20587 p_index = 0 20588 DO md = 1, md_max 20589 DO mc = 1, 1 20590 DO mb = 1, 3 20591 ks_bd = 0.0_dp 20592 ks_bc = 0.0_dp 20593 p_bd = pbd((md - 1)*3 + mb) 20594 p_bc = pbc((mc - 1)*3 + mb) 20595 DO ma = 1, 6 20596 p_index = p_index + 1 20597 tmp = scale*prim(p_index) 20598 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20599 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20600 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20601 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20602 END DO 20603 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 20604 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 20605 END DO 20606 END DO 20607 END DO 20608 END SUBROUTINE block_6_3_1 20609! ************************************************************************************************** 20610!> \brief ... 20611!> \param mc_max ... 20612!> \param md_max ... 20613!> \param kbd ... 20614!> \param kbc ... 20615!> \param kad ... 20616!> \param kac ... 20617!> \param pbd ... 20618!> \param pbc ... 20619!> \param pad ... 20620!> \param pac ... 20621!> \param prim ... 20622!> \param scale ... 20623! ************************************************************************************************** 20624 SUBROUTINE block_6_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20625 INTEGER :: mc_max, md_max 20626 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(6*md_max), kac(6*mc_max), pbd(3*md_max), & 20627 pbc(3*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*3*mc_max*md_max), scale 20628 20629 INTEGER :: ma, mb, mc, md, p_index 20630 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20631 20632 kbd(1:3*md_max) = 0.0_dp 20633 kbc(1:3*mc_max) = 0.0_dp 20634 kad(1:6*md_max) = 0.0_dp 20635 kac(1:6*mc_max) = 0.0_dp 20636 p_index = 0 20637 DO md = 1, md_max 20638 DO mc = 1, mc_max 20639 DO mb = 1, 3 20640 ks_bd = 0.0_dp 20641 ks_bc = 0.0_dp 20642 p_bd = pbd((md - 1)*3 + mb) 20643 p_bc = pbc((mc - 1)*3 + mb) 20644 DO ma = 1, 6 20645 p_index = p_index + 1 20646 tmp = scale*prim(p_index) 20647 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20648 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20649 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20650 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20651 END DO 20652 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 20653 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 20654 END DO 20655 END DO 20656 END DO 20657 END SUBROUTINE block_6_3 20658! ************************************************************************************************** 20659!> \brief ... 20660!> \param mc_max ... 20661!> \param md_max ... 20662!> \param kbd ... 20663!> \param kbc ... 20664!> \param kad ... 20665!> \param kac ... 20666!> \param pbd ... 20667!> \param pbc ... 20668!> \param pad ... 20669!> \param pac ... 20670!> \param prim ... 20671!> \param scale ... 20672! ************************************************************************************************** 20673 SUBROUTINE block_6_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20674 INTEGER :: mc_max, md_max 20675 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(6*md_max), kac(6*mc_max), pbd(4*md_max), & 20676 pbc(4*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*4*mc_max*md_max), scale 20677 20678 INTEGER :: ma, mb, mc, md, p_index 20679 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20680 20681 kbd(1:4*md_max) = 0.0_dp 20682 kbc(1:4*mc_max) = 0.0_dp 20683 kad(1:6*md_max) = 0.0_dp 20684 kac(1:6*mc_max) = 0.0_dp 20685 p_index = 0 20686 DO md = 1, md_max 20687 DO mc = 1, mc_max 20688 DO mb = 1, 4 20689 ks_bd = 0.0_dp 20690 ks_bc = 0.0_dp 20691 p_bd = pbd((md - 1)*4 + mb) 20692 p_bc = pbc((mc - 1)*4 + mb) 20693 DO ma = 1, 6 20694 p_index = p_index + 1 20695 tmp = scale*prim(p_index) 20696 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20697 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20698 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20699 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20700 END DO 20701 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 20702 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 20703 END DO 20704 END DO 20705 END DO 20706 END SUBROUTINE block_6_4 20707! ************************************************************************************************** 20708!> \brief ... 20709!> \param mc_max ... 20710!> \param md_max ... 20711!> \param kbd ... 20712!> \param kbc ... 20713!> \param kad ... 20714!> \param kac ... 20715!> \param pbd ... 20716!> \param pbc ... 20717!> \param pad ... 20718!> \param pac ... 20719!> \param prim ... 20720!> \param scale ... 20721! ************************************************************************************************** 20722 SUBROUTINE block_6_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20723 INTEGER :: mc_max, md_max 20724 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(6*md_max), kac(6*mc_max), pbd(5*md_max), & 20725 pbc(5*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*5*mc_max*md_max), scale 20726 20727 INTEGER :: ma, mb, mc, md, p_index 20728 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20729 20730 kbd(1:5*md_max) = 0.0_dp 20731 kbc(1:5*mc_max) = 0.0_dp 20732 kad(1:6*md_max) = 0.0_dp 20733 kac(1:6*mc_max) = 0.0_dp 20734 p_index = 0 20735 DO md = 1, md_max 20736 DO mc = 1, mc_max 20737 DO mb = 1, 5 20738 ks_bd = 0.0_dp 20739 ks_bc = 0.0_dp 20740 p_bd = pbd((md - 1)*5 + mb) 20741 p_bc = pbc((mc - 1)*5 + mb) 20742 DO ma = 1, 6 20743 p_index = p_index + 1 20744 tmp = scale*prim(p_index) 20745 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20746 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20747 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20748 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20749 END DO 20750 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 20751 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 20752 END DO 20753 END DO 20754 END DO 20755 END SUBROUTINE block_6_5 20756! ************************************************************************************************** 20757!> \brief ... 20758!> \param mc_max ... 20759!> \param md_max ... 20760!> \param kbd ... 20761!> \param kbc ... 20762!> \param kad ... 20763!> \param kac ... 20764!> \param pbd ... 20765!> \param pbc ... 20766!> \param pad ... 20767!> \param pac ... 20768!> \param prim ... 20769!> \param scale ... 20770! ************************************************************************************************** 20771 SUBROUTINE block_6_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20772 INTEGER :: mc_max, md_max 20773 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(6*md_max), kac(6*mc_max), pbd(6*md_max), & 20774 pbc(6*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*6*mc_max*md_max), scale 20775 20776 INTEGER :: ma, mb, mc, md, p_index 20777 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20778 20779 kbd(1:6*md_max) = 0.0_dp 20780 kbc(1:6*mc_max) = 0.0_dp 20781 kad(1:6*md_max) = 0.0_dp 20782 kac(1:6*mc_max) = 0.0_dp 20783 p_index = 0 20784 DO md = 1, md_max 20785 DO mc = 1, mc_max 20786 DO mb = 1, 6 20787 ks_bd = 0.0_dp 20788 ks_bc = 0.0_dp 20789 p_bd = pbd((md - 1)*6 + mb) 20790 p_bc = pbc((mc - 1)*6 + mb) 20791 DO ma = 1, 6 20792 p_index = p_index + 1 20793 tmp = scale*prim(p_index) 20794 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20795 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20796 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20797 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20798 END DO 20799 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 20800 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 20801 END DO 20802 END DO 20803 END DO 20804 END SUBROUTINE block_6_6 20805! ************************************************************************************************** 20806!> \brief ... 20807!> \param mc_max ... 20808!> \param md_max ... 20809!> \param kbd ... 20810!> \param kbc ... 20811!> \param kad ... 20812!> \param kac ... 20813!> \param pbd ... 20814!> \param pbc ... 20815!> \param pad ... 20816!> \param pac ... 20817!> \param prim ... 20818!> \param scale ... 20819! ************************************************************************************************** 20820 SUBROUTINE block_6_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20821 INTEGER :: mc_max, md_max 20822 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(6*md_max), kac(6*mc_max), pbd(7*md_max), & 20823 pbc(7*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*7*mc_max*md_max), scale 20824 20825 INTEGER :: ma, mb, mc, md, p_index 20826 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20827 20828 kbd(1:7*md_max) = 0.0_dp 20829 kbc(1:7*mc_max) = 0.0_dp 20830 kad(1:6*md_max) = 0.0_dp 20831 kac(1:6*mc_max) = 0.0_dp 20832 p_index = 0 20833 DO md = 1, md_max 20834 DO mc = 1, mc_max 20835 DO mb = 1, 7 20836 ks_bd = 0.0_dp 20837 ks_bc = 0.0_dp 20838 p_bd = pbd((md - 1)*7 + mb) 20839 p_bc = pbc((mc - 1)*7 + mb) 20840 DO ma = 1, 6 20841 p_index = p_index + 1 20842 tmp = scale*prim(p_index) 20843 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20844 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20845 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20846 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20847 END DO 20848 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 20849 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 20850 END DO 20851 END DO 20852 END DO 20853 END SUBROUTINE block_6_7 20854! ************************************************************************************************** 20855!> \brief ... 20856!> \param mc_max ... 20857!> \param md_max ... 20858!> \param kbd ... 20859!> \param kbc ... 20860!> \param kad ... 20861!> \param kac ... 20862!> \param pbd ... 20863!> \param pbc ... 20864!> \param pad ... 20865!> \param pac ... 20866!> \param prim ... 20867!> \param scale ... 20868! ************************************************************************************************** 20869 SUBROUTINE block_6_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20870 INTEGER :: mc_max, md_max 20871 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(6*md_max), kac(6*mc_max), pbd(9*md_max), & 20872 pbc(9*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*9*mc_max*md_max), scale 20873 20874 INTEGER :: ma, mb, mc, md, p_index 20875 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20876 20877 kbd(1:9*md_max) = 0.0_dp 20878 kbc(1:9*mc_max) = 0.0_dp 20879 kad(1:6*md_max) = 0.0_dp 20880 kac(1:6*mc_max) = 0.0_dp 20881 p_index = 0 20882 DO md = 1, md_max 20883 DO mc = 1, mc_max 20884 DO mb = 1, 9 20885 ks_bd = 0.0_dp 20886 ks_bc = 0.0_dp 20887 p_bd = pbd((md - 1)*9 + mb) 20888 p_bc = pbc((mc - 1)*9 + mb) 20889 DO ma = 1, 6 20890 p_index = p_index + 1 20891 tmp = scale*prim(p_index) 20892 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20893 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20894 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20895 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20896 END DO 20897 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 20898 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 20899 END DO 20900 END DO 20901 END DO 20902 END SUBROUTINE block_6_9 20903! ************************************************************************************************** 20904!> \brief ... 20905!> \param mc_max ... 20906!> \param md_max ... 20907!> \param kbd ... 20908!> \param kbc ... 20909!> \param kad ... 20910!> \param kac ... 20911!> \param pbd ... 20912!> \param pbc ... 20913!> \param pad ... 20914!> \param pac ... 20915!> \param prim ... 20916!> \param scale ... 20917! ************************************************************************************************** 20918 SUBROUTINE block_6_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20919 INTEGER :: mc_max, md_max 20920 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(6*md_max), kac(6*mc_max), & 20921 pbd(10*md_max), pbc(10*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*10*mc_max*md_max), & 20922 scale 20923 20924 INTEGER :: ma, mb, mc, md, p_index 20925 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20926 20927 kbd(1:10*md_max) = 0.0_dp 20928 kbc(1:10*mc_max) = 0.0_dp 20929 kad(1:6*md_max) = 0.0_dp 20930 kac(1:6*mc_max) = 0.0_dp 20931 p_index = 0 20932 DO md = 1, md_max 20933 DO mc = 1, mc_max 20934 DO mb = 1, 10 20935 ks_bd = 0.0_dp 20936 ks_bc = 0.0_dp 20937 p_bd = pbd((md - 1)*10 + mb) 20938 p_bc = pbc((mc - 1)*10 + mb) 20939 DO ma = 1, 6 20940 p_index = p_index + 1 20941 tmp = scale*prim(p_index) 20942 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20943 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20944 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20945 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20946 END DO 20947 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 20948 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 20949 END DO 20950 END DO 20951 END DO 20952 END SUBROUTINE block_6_10 20953! ************************************************************************************************** 20954!> \brief ... 20955!> \param mc_max ... 20956!> \param md_max ... 20957!> \param kbd ... 20958!> \param kbc ... 20959!> \param kad ... 20960!> \param kac ... 20961!> \param pbd ... 20962!> \param pbc ... 20963!> \param pad ... 20964!> \param pac ... 20965!> \param prim ... 20966!> \param scale ... 20967! ************************************************************************************************** 20968 SUBROUTINE block_6_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 20969 INTEGER :: mc_max, md_max 20970 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(6*md_max), kac(6*mc_max), & 20971 pbd(11*md_max), pbc(11*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*11*mc_max*md_max), & 20972 scale 20973 20974 INTEGER :: ma, mb, mc, md, p_index 20975 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 20976 20977 kbd(1:11*md_max) = 0.0_dp 20978 kbc(1:11*mc_max) = 0.0_dp 20979 kad(1:6*md_max) = 0.0_dp 20980 kac(1:6*mc_max) = 0.0_dp 20981 p_index = 0 20982 DO md = 1, md_max 20983 DO mc = 1, mc_max 20984 DO mb = 1, 11 20985 ks_bd = 0.0_dp 20986 ks_bc = 0.0_dp 20987 p_bd = pbd((md - 1)*11 + mb) 20988 p_bc = pbc((mc - 1)*11 + mb) 20989 DO ma = 1, 6 20990 p_index = p_index + 1 20991 tmp = scale*prim(p_index) 20992 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 20993 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 20994 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 20995 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 20996 END DO 20997 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 20998 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 20999 END DO 21000 END DO 21001 END DO 21002 END SUBROUTINE block_6_11 21003! ************************************************************************************************** 21004!> \brief ... 21005!> \param mc_max ... 21006!> \param md_max ... 21007!> \param kbd ... 21008!> \param kbc ... 21009!> \param kad ... 21010!> \param kac ... 21011!> \param pbd ... 21012!> \param pbc ... 21013!> \param pad ... 21014!> \param pac ... 21015!> \param prim ... 21016!> \param scale ... 21017! ************************************************************************************************** 21018 SUBROUTINE block_6_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21019 INTEGER :: mc_max, md_max 21020 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(6*md_max), kac(6*mc_max), & 21021 pbd(15*md_max), pbc(15*mc_max), pad(6*md_max), pac(6*mc_max), prim(6*15*mc_max*md_max), & 21022 scale 21023 21024 INTEGER :: ma, mb, mc, md, p_index 21025 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21026 21027 kbd(1:15*md_max) = 0.0_dp 21028 kbc(1:15*mc_max) = 0.0_dp 21029 kad(1:6*md_max) = 0.0_dp 21030 kac(1:6*mc_max) = 0.0_dp 21031 p_index = 0 21032 DO md = 1, md_max 21033 DO mc = 1, mc_max 21034 DO mb = 1, 15 21035 ks_bd = 0.0_dp 21036 ks_bc = 0.0_dp 21037 p_bd = pbd((md - 1)*15 + mb) 21038 p_bc = pbc((mc - 1)*15 + mb) 21039 DO ma = 1, 6 21040 p_index = p_index + 1 21041 tmp = scale*prim(p_index) 21042 ks_bc = ks_bc + tmp*pad((md - 1)*6 + ma) 21043 ks_bd = ks_bd + tmp*pac((mc - 1)*6 + ma) 21044 kad((md - 1)*6 + ma) = kad((md - 1)*6 + ma) - tmp*p_bc 21045 kac((mc - 1)*6 + ma) = kac((mc - 1)*6 + ma) - tmp*p_bd 21046 END DO 21047 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 21048 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 21049 END DO 21050 END DO 21051 END DO 21052 END SUBROUTINE block_6_15 21053! ************************************************************************************************** 21054!> \brief ... 21055!> \param kbd ... 21056!> \param kbc ... 21057!> \param kad ... 21058!> \param kac ... 21059!> \param pbd ... 21060!> \param pbc ... 21061!> \param pad ... 21062!> \param pac ... 21063!> \param prim ... 21064!> \param scale ... 21065! ************************************************************************************************** 21066 SUBROUTINE block_7_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21067 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(7*1), kac(7*1), & 21068 pbd(1*1), pbc(1*1), pad(7*1), & 21069 pac(7*1), prim(7*1*1*1), scale 21070 21071 INTEGER :: ma, mb, mc, md, p_index 21072 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21073 21074 kbd(1:1*1) = 0.0_dp 21075 kbc(1:1*1) = 0.0_dp 21076 kad(1:7*1) = 0.0_dp 21077 kac(1:7*1) = 0.0_dp 21078 p_index = 0 21079 DO md = 1, 1 21080 DO mc = 1, 1 21081 DO mb = 1, 1 21082 ks_bd = 0.0_dp 21083 ks_bc = 0.0_dp 21084 p_bd = pbd((md - 1)*1 + mb) 21085 p_bc = pbc((mc - 1)*1 + mb) 21086 DO ma = 1, 7 21087 p_index = p_index + 1 21088 tmp = scale*prim(p_index) 21089 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21090 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21091 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21092 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21093 END DO 21094 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 21095 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 21096 END DO 21097 END DO 21098 END DO 21099 END SUBROUTINE block_7_1_1_1 21100! ************************************************************************************************** 21101!> \brief ... 21102!> \param kbd ... 21103!> \param kbc ... 21104!> \param kad ... 21105!> \param kac ... 21106!> \param pbd ... 21107!> \param pbc ... 21108!> \param pad ... 21109!> \param pac ... 21110!> \param prim ... 21111!> \param scale ... 21112! ************************************************************************************************** 21113 SUBROUTINE block_7_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21114 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(7*2), kac(7*1), & 21115 pbd(1*2), pbc(1*1), pad(7*2), & 21116 pac(7*1), prim(7*1*1*2), scale 21117 21118 INTEGER :: ma, mb, mc, md, p_index 21119 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21120 21121 kbd(1:1*2) = 0.0_dp 21122 kbc(1:1*1) = 0.0_dp 21123 kad(1:7*2) = 0.0_dp 21124 kac(1:7*1) = 0.0_dp 21125 p_index = 0 21126 DO md = 1, 2 21127 DO mc = 1, 1 21128 DO mb = 1, 1 21129 ks_bd = 0.0_dp 21130 ks_bc = 0.0_dp 21131 p_bd = pbd((md - 1)*1 + mb) 21132 p_bc = pbc((mc - 1)*1 + mb) 21133 DO ma = 1, 7 21134 p_index = p_index + 1 21135 tmp = scale*prim(p_index) 21136 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21137 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21138 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21139 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21140 END DO 21141 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 21142 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 21143 END DO 21144 END DO 21145 END DO 21146 END SUBROUTINE block_7_1_1_2 21147! ************************************************************************************************** 21148!> \brief ... 21149!> \param md_max ... 21150!> \param kbd ... 21151!> \param kbc ... 21152!> \param kad ... 21153!> \param kac ... 21154!> \param pbd ... 21155!> \param pbc ... 21156!> \param pad ... 21157!> \param pac ... 21158!> \param prim ... 21159!> \param scale ... 21160! ************************************************************************************************** 21161 SUBROUTINE block_7_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21162 INTEGER :: md_max 21163 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(7*md_max), kac(7*1), pbd(1*md_max), pbc(1*1), & 21164 pad(7*md_max), pac(7*1), prim(7*1*1*md_max), scale 21165 21166 INTEGER :: ma, mb, mc, md, p_index 21167 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21168 21169 kbd(1:1*md_max) = 0.0_dp 21170 kbc(1:1*1) = 0.0_dp 21171 kad(1:7*md_max) = 0.0_dp 21172 kac(1:7*1) = 0.0_dp 21173 p_index = 0 21174 DO md = 1, md_max 21175 DO mc = 1, 1 21176 DO mb = 1, 1 21177 ks_bd = 0.0_dp 21178 ks_bc = 0.0_dp 21179 p_bd = pbd((md - 1)*1 + mb) 21180 p_bc = pbc((mc - 1)*1 + mb) 21181 DO ma = 1, 7 21182 p_index = p_index + 1 21183 tmp = scale*prim(p_index) 21184 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21185 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21186 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21187 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21188 END DO 21189 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 21190 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 21191 END DO 21192 END DO 21193 END DO 21194 END SUBROUTINE block_7_1_1 21195! ************************************************************************************************** 21196!> \brief ... 21197!> \param kbd ... 21198!> \param kbc ... 21199!> \param kad ... 21200!> \param kac ... 21201!> \param pbd ... 21202!> \param pbc ... 21203!> \param pad ... 21204!> \param pac ... 21205!> \param prim ... 21206!> \param scale ... 21207! ************************************************************************************************** 21208 SUBROUTINE block_7_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21209 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(7*1), kac(7*2), & 21210 pbd(1*1), pbc(1*2), pad(7*1), & 21211 pac(7*2), prim(7*1*2*1), scale 21212 21213 INTEGER :: ma, mb, mc, md, p_index 21214 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21215 21216 kbd(1:1*1) = 0.0_dp 21217 kbc(1:1*2) = 0.0_dp 21218 kad(1:7*1) = 0.0_dp 21219 kac(1:7*2) = 0.0_dp 21220 p_index = 0 21221 DO md = 1, 1 21222 DO mc = 1, 2 21223 DO mb = 1, 1 21224 ks_bd = 0.0_dp 21225 ks_bc = 0.0_dp 21226 p_bd = pbd((md - 1)*1 + mb) 21227 p_bc = pbc((mc - 1)*1 + mb) 21228 DO ma = 1, 7 21229 p_index = p_index + 1 21230 tmp = scale*prim(p_index) 21231 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21232 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21233 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21234 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21235 END DO 21236 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 21237 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 21238 END DO 21239 END DO 21240 END DO 21241 END SUBROUTINE block_7_1_2_1 21242! ************************************************************************************************** 21243!> \brief ... 21244!> \param md_max ... 21245!> \param kbd ... 21246!> \param kbc ... 21247!> \param kad ... 21248!> \param kac ... 21249!> \param pbd ... 21250!> \param pbc ... 21251!> \param pad ... 21252!> \param pac ... 21253!> \param prim ... 21254!> \param scale ... 21255! ************************************************************************************************** 21256 SUBROUTINE block_7_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21257 INTEGER :: md_max 21258 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(7*md_max), kac(7*2), pbd(1*md_max), pbc(1*2), & 21259 pad(7*md_max), pac(7*2), prim(7*1*2*md_max), scale 21260 21261 INTEGER :: ma, mb, mc, md, p_index 21262 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21263 21264 kbd(1:1*md_max) = 0.0_dp 21265 kbc(1:1*2) = 0.0_dp 21266 kad(1:7*md_max) = 0.0_dp 21267 kac(1:7*2) = 0.0_dp 21268 p_index = 0 21269 DO md = 1, md_max 21270 DO mc = 1, 2 21271 DO mb = 1, 1 21272 ks_bd = 0.0_dp 21273 ks_bc = 0.0_dp 21274 p_bd = pbd((md - 1)*1 + mb) 21275 p_bc = pbc((mc - 1)*1 + mb) 21276 DO ma = 1, 7 21277 p_index = p_index + 1 21278 tmp = scale*prim(p_index) 21279 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21280 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21281 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21282 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21283 END DO 21284 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 21285 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 21286 END DO 21287 END DO 21288 END DO 21289 END SUBROUTINE block_7_1_2 21290! ************************************************************************************************** 21291!> \brief ... 21292!> \param mc_max ... 21293!> \param md_max ... 21294!> \param kbd ... 21295!> \param kbc ... 21296!> \param kad ... 21297!> \param kac ... 21298!> \param pbd ... 21299!> \param pbc ... 21300!> \param pad ... 21301!> \param pac ... 21302!> \param prim ... 21303!> \param scale ... 21304! ************************************************************************************************** 21305 SUBROUTINE block_7_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21306 INTEGER :: mc_max, md_max 21307 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(7*md_max), kac(7*mc_max), pbd(1*md_max), & 21308 pbc(1*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*1*mc_max*md_max), scale 21309 21310 INTEGER :: ma, mb, mc, md, p_index 21311 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21312 21313 kbd(1:1*md_max) = 0.0_dp 21314 kbc(1:1*mc_max) = 0.0_dp 21315 kad(1:7*md_max) = 0.0_dp 21316 kac(1:7*mc_max) = 0.0_dp 21317 p_index = 0 21318 DO md = 1, md_max 21319 DO mc = 1, mc_max 21320 DO mb = 1, 1 21321 ks_bd = 0.0_dp 21322 ks_bc = 0.0_dp 21323 p_bd = pbd((md - 1)*1 + mb) 21324 p_bc = pbc((mc - 1)*1 + mb) 21325 DO ma = 1, 7 21326 p_index = p_index + 1 21327 tmp = scale*prim(p_index) 21328 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21329 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21330 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21331 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21332 END DO 21333 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 21334 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 21335 END DO 21336 END DO 21337 END DO 21338 END SUBROUTINE block_7_1 21339! ************************************************************************************************** 21340!> \brief ... 21341!> \param kbd ... 21342!> \param kbc ... 21343!> \param kad ... 21344!> \param kac ... 21345!> \param pbd ... 21346!> \param pbc ... 21347!> \param pad ... 21348!> \param pac ... 21349!> \param prim ... 21350!> \param scale ... 21351! ************************************************************************************************** 21352 SUBROUTINE block_7_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21353 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(7*1), kac(7*1), & 21354 pbd(2*1), pbc(2*1), pad(7*1), & 21355 pac(7*1), prim(7*2*1*1), scale 21356 21357 INTEGER :: ma, mb, mc, md, p_index 21358 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21359 21360 kbd(1:2*1) = 0.0_dp 21361 kbc(1:2*1) = 0.0_dp 21362 kad(1:7*1) = 0.0_dp 21363 kac(1:7*1) = 0.0_dp 21364 p_index = 0 21365 DO md = 1, 1 21366 DO mc = 1, 1 21367 DO mb = 1, 2 21368 ks_bd = 0.0_dp 21369 ks_bc = 0.0_dp 21370 p_bd = pbd((md - 1)*2 + mb) 21371 p_bc = pbc((mc - 1)*2 + mb) 21372 DO ma = 1, 7 21373 p_index = p_index + 1 21374 tmp = scale*prim(p_index) 21375 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21376 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21377 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21378 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21379 END DO 21380 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 21381 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 21382 END DO 21383 END DO 21384 END DO 21385 END SUBROUTINE block_7_2_1_1 21386! ************************************************************************************************** 21387!> \brief ... 21388!> \param md_max ... 21389!> \param kbd ... 21390!> \param kbc ... 21391!> \param kad ... 21392!> \param kac ... 21393!> \param pbd ... 21394!> \param pbc ... 21395!> \param pad ... 21396!> \param pac ... 21397!> \param prim ... 21398!> \param scale ... 21399! ************************************************************************************************** 21400 SUBROUTINE block_7_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21401 INTEGER :: md_max 21402 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(7*md_max), kac(7*1), pbd(2*md_max), pbc(2*1), & 21403 pad(7*md_max), pac(7*1), prim(7*2*1*md_max), scale 21404 21405 INTEGER :: ma, mb, mc, md, p_index 21406 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21407 21408 kbd(1:2*md_max) = 0.0_dp 21409 kbc(1:2*1) = 0.0_dp 21410 kad(1:7*md_max) = 0.0_dp 21411 kac(1:7*1) = 0.0_dp 21412 p_index = 0 21413 DO md = 1, md_max 21414 DO mc = 1, 1 21415 DO mb = 1, 2 21416 ks_bd = 0.0_dp 21417 ks_bc = 0.0_dp 21418 p_bd = pbd((md - 1)*2 + mb) 21419 p_bc = pbc((mc - 1)*2 + mb) 21420 DO ma = 1, 7 21421 p_index = p_index + 1 21422 tmp = scale*prim(p_index) 21423 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21424 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21425 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21426 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21427 END DO 21428 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 21429 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 21430 END DO 21431 END DO 21432 END DO 21433 END SUBROUTINE block_7_2_1 21434! ************************************************************************************************** 21435!> \brief ... 21436!> \param mc_max ... 21437!> \param md_max ... 21438!> \param kbd ... 21439!> \param kbc ... 21440!> \param kad ... 21441!> \param kac ... 21442!> \param pbd ... 21443!> \param pbc ... 21444!> \param pad ... 21445!> \param pac ... 21446!> \param prim ... 21447!> \param scale ... 21448! ************************************************************************************************** 21449 SUBROUTINE block_7_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21450 INTEGER :: mc_max, md_max 21451 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(7*md_max), kac(7*mc_max), pbd(2*md_max), & 21452 pbc(2*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*2*mc_max*md_max), scale 21453 21454 INTEGER :: ma, mb, mc, md, p_index 21455 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21456 21457 kbd(1:2*md_max) = 0.0_dp 21458 kbc(1:2*mc_max) = 0.0_dp 21459 kad(1:7*md_max) = 0.0_dp 21460 kac(1:7*mc_max) = 0.0_dp 21461 p_index = 0 21462 DO md = 1, md_max 21463 DO mc = 1, mc_max 21464 DO mb = 1, 2 21465 ks_bd = 0.0_dp 21466 ks_bc = 0.0_dp 21467 p_bd = pbd((md - 1)*2 + mb) 21468 p_bc = pbc((mc - 1)*2 + mb) 21469 DO ma = 1, 7 21470 p_index = p_index + 1 21471 tmp = scale*prim(p_index) 21472 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21473 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21474 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21475 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21476 END DO 21477 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 21478 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 21479 END DO 21480 END DO 21481 END DO 21482 END SUBROUTINE block_7_2 21483! ************************************************************************************************** 21484!> \brief ... 21485!> \param mc_max ... 21486!> \param md_max ... 21487!> \param kbd ... 21488!> \param kbc ... 21489!> \param kad ... 21490!> \param kac ... 21491!> \param pbd ... 21492!> \param pbc ... 21493!> \param pad ... 21494!> \param pac ... 21495!> \param prim ... 21496!> \param scale ... 21497! ************************************************************************************************** 21498 SUBROUTINE block_7_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21499 INTEGER :: mc_max, md_max 21500 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(7*md_max), kac(7*mc_max), pbd(3*md_max), & 21501 pbc(3*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*3*mc_max*md_max), scale 21502 21503 INTEGER :: ma, mb, mc, md, p_index 21504 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21505 21506 kbd(1:3*md_max) = 0.0_dp 21507 kbc(1:3*mc_max) = 0.0_dp 21508 kad(1:7*md_max) = 0.0_dp 21509 kac(1:7*mc_max) = 0.0_dp 21510 p_index = 0 21511 DO md = 1, md_max 21512 DO mc = 1, mc_max 21513 DO mb = 1, 3 21514 ks_bd = 0.0_dp 21515 ks_bc = 0.0_dp 21516 p_bd = pbd((md - 1)*3 + mb) 21517 p_bc = pbc((mc - 1)*3 + mb) 21518 DO ma = 1, 7 21519 p_index = p_index + 1 21520 tmp = scale*prim(p_index) 21521 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21522 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21523 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21524 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21525 END DO 21526 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 21527 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 21528 END DO 21529 END DO 21530 END DO 21531 END SUBROUTINE block_7_3 21532! ************************************************************************************************** 21533!> \brief ... 21534!> \param mc_max ... 21535!> \param md_max ... 21536!> \param kbd ... 21537!> \param kbc ... 21538!> \param kad ... 21539!> \param kac ... 21540!> \param pbd ... 21541!> \param pbc ... 21542!> \param pad ... 21543!> \param pac ... 21544!> \param prim ... 21545!> \param scale ... 21546! ************************************************************************************************** 21547 SUBROUTINE block_7_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21548 INTEGER :: mc_max, md_max 21549 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(7*md_max), kac(7*mc_max), pbd(4*md_max), & 21550 pbc(4*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*4*mc_max*md_max), scale 21551 21552 INTEGER :: ma, mb, mc, md, p_index 21553 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21554 21555 kbd(1:4*md_max) = 0.0_dp 21556 kbc(1:4*mc_max) = 0.0_dp 21557 kad(1:7*md_max) = 0.0_dp 21558 kac(1:7*mc_max) = 0.0_dp 21559 p_index = 0 21560 DO md = 1, md_max 21561 DO mc = 1, mc_max 21562 DO mb = 1, 4 21563 ks_bd = 0.0_dp 21564 ks_bc = 0.0_dp 21565 p_bd = pbd((md - 1)*4 + mb) 21566 p_bc = pbc((mc - 1)*4 + mb) 21567 DO ma = 1, 7 21568 p_index = p_index + 1 21569 tmp = scale*prim(p_index) 21570 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21571 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21572 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21573 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21574 END DO 21575 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 21576 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 21577 END DO 21578 END DO 21579 END DO 21580 END SUBROUTINE block_7_4 21581! ************************************************************************************************** 21582!> \brief ... 21583!> \param mc_max ... 21584!> \param md_max ... 21585!> \param kbd ... 21586!> \param kbc ... 21587!> \param kad ... 21588!> \param kac ... 21589!> \param pbd ... 21590!> \param pbc ... 21591!> \param pad ... 21592!> \param pac ... 21593!> \param prim ... 21594!> \param scale ... 21595! ************************************************************************************************** 21596 SUBROUTINE block_7_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21597 INTEGER :: mc_max, md_max 21598 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(7*md_max), kac(7*mc_max), pbd(5*md_max), & 21599 pbc(5*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*5*mc_max*md_max), scale 21600 21601 INTEGER :: ma, mb, mc, md, p_index 21602 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21603 21604 kbd(1:5*md_max) = 0.0_dp 21605 kbc(1:5*mc_max) = 0.0_dp 21606 kad(1:7*md_max) = 0.0_dp 21607 kac(1:7*mc_max) = 0.0_dp 21608 p_index = 0 21609 DO md = 1, md_max 21610 DO mc = 1, mc_max 21611 DO mb = 1, 5 21612 ks_bd = 0.0_dp 21613 ks_bc = 0.0_dp 21614 p_bd = pbd((md - 1)*5 + mb) 21615 p_bc = pbc((mc - 1)*5 + mb) 21616 DO ma = 1, 7 21617 p_index = p_index + 1 21618 tmp = scale*prim(p_index) 21619 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21620 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21621 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21622 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21623 END DO 21624 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 21625 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 21626 END DO 21627 END DO 21628 END DO 21629 END SUBROUTINE block_7_5 21630! ************************************************************************************************** 21631!> \brief ... 21632!> \param mc_max ... 21633!> \param md_max ... 21634!> \param kbd ... 21635!> \param kbc ... 21636!> \param kad ... 21637!> \param kac ... 21638!> \param pbd ... 21639!> \param pbc ... 21640!> \param pad ... 21641!> \param pac ... 21642!> \param prim ... 21643!> \param scale ... 21644! ************************************************************************************************** 21645 SUBROUTINE block_7_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21646 INTEGER :: mc_max, md_max 21647 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(7*md_max), kac(7*mc_max), pbd(6*md_max), & 21648 pbc(6*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*6*mc_max*md_max), scale 21649 21650 INTEGER :: ma, mb, mc, md, p_index 21651 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21652 21653 kbd(1:6*md_max) = 0.0_dp 21654 kbc(1:6*mc_max) = 0.0_dp 21655 kad(1:7*md_max) = 0.0_dp 21656 kac(1:7*mc_max) = 0.0_dp 21657 p_index = 0 21658 DO md = 1, md_max 21659 DO mc = 1, mc_max 21660 DO mb = 1, 6 21661 ks_bd = 0.0_dp 21662 ks_bc = 0.0_dp 21663 p_bd = pbd((md - 1)*6 + mb) 21664 p_bc = pbc((mc - 1)*6 + mb) 21665 DO ma = 1, 7 21666 p_index = p_index + 1 21667 tmp = scale*prim(p_index) 21668 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21669 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21670 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21671 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21672 END DO 21673 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 21674 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 21675 END DO 21676 END DO 21677 END DO 21678 END SUBROUTINE block_7_6 21679! ************************************************************************************************** 21680!> \brief ... 21681!> \param mc_max ... 21682!> \param md_max ... 21683!> \param kbd ... 21684!> \param kbc ... 21685!> \param kad ... 21686!> \param kac ... 21687!> \param pbd ... 21688!> \param pbc ... 21689!> \param pad ... 21690!> \param pac ... 21691!> \param prim ... 21692!> \param scale ... 21693! ************************************************************************************************** 21694 SUBROUTINE block_7_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21695 INTEGER :: mc_max, md_max 21696 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(7*md_max), kac(7*mc_max), pbd(7*md_max), & 21697 pbc(7*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*7*mc_max*md_max), scale 21698 21699 INTEGER :: ma, mb, mc, md, p_index 21700 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21701 21702 kbd(1:7*md_max) = 0.0_dp 21703 kbc(1:7*mc_max) = 0.0_dp 21704 kad(1:7*md_max) = 0.0_dp 21705 kac(1:7*mc_max) = 0.0_dp 21706 p_index = 0 21707 DO md = 1, md_max 21708 DO mc = 1, mc_max 21709 DO mb = 1, 7 21710 ks_bd = 0.0_dp 21711 ks_bc = 0.0_dp 21712 p_bd = pbd((md - 1)*7 + mb) 21713 p_bc = pbc((mc - 1)*7 + mb) 21714 DO ma = 1, 7 21715 p_index = p_index + 1 21716 tmp = scale*prim(p_index) 21717 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21718 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21719 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21720 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21721 END DO 21722 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 21723 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 21724 END DO 21725 END DO 21726 END DO 21727 END SUBROUTINE block_7_7 21728! ************************************************************************************************** 21729!> \brief ... 21730!> \param mc_max ... 21731!> \param md_max ... 21732!> \param kbd ... 21733!> \param kbc ... 21734!> \param kad ... 21735!> \param kac ... 21736!> \param pbd ... 21737!> \param pbc ... 21738!> \param pad ... 21739!> \param pac ... 21740!> \param prim ... 21741!> \param scale ... 21742! ************************************************************************************************** 21743 SUBROUTINE block_7_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21744 INTEGER :: mc_max, md_max 21745 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(7*md_max), kac(7*mc_max), pbd(9*md_max), & 21746 pbc(9*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*9*mc_max*md_max), scale 21747 21748 INTEGER :: ma, mb, mc, md, p_index 21749 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21750 21751 kbd(1:9*md_max) = 0.0_dp 21752 kbc(1:9*mc_max) = 0.0_dp 21753 kad(1:7*md_max) = 0.0_dp 21754 kac(1:7*mc_max) = 0.0_dp 21755 p_index = 0 21756 DO md = 1, md_max 21757 DO mc = 1, mc_max 21758 DO mb = 1, 9 21759 ks_bd = 0.0_dp 21760 ks_bc = 0.0_dp 21761 p_bd = pbd((md - 1)*9 + mb) 21762 p_bc = pbc((mc - 1)*9 + mb) 21763 DO ma = 1, 7 21764 p_index = p_index + 1 21765 tmp = scale*prim(p_index) 21766 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21767 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21768 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21769 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21770 END DO 21771 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 21772 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 21773 END DO 21774 END DO 21775 END DO 21776 END SUBROUTINE block_7_9 21777! ************************************************************************************************** 21778!> \brief ... 21779!> \param mc_max ... 21780!> \param md_max ... 21781!> \param kbd ... 21782!> \param kbc ... 21783!> \param kad ... 21784!> \param kac ... 21785!> \param pbd ... 21786!> \param pbc ... 21787!> \param pad ... 21788!> \param pac ... 21789!> \param prim ... 21790!> \param scale ... 21791! ************************************************************************************************** 21792 SUBROUTINE block_7_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21793 INTEGER :: mc_max, md_max 21794 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(7*md_max), kac(7*mc_max), & 21795 pbd(10*md_max), pbc(10*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*10*mc_max*md_max), & 21796 scale 21797 21798 INTEGER :: ma, mb, mc, md, p_index 21799 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21800 21801 kbd(1:10*md_max) = 0.0_dp 21802 kbc(1:10*mc_max) = 0.0_dp 21803 kad(1:7*md_max) = 0.0_dp 21804 kac(1:7*mc_max) = 0.0_dp 21805 p_index = 0 21806 DO md = 1, md_max 21807 DO mc = 1, mc_max 21808 DO mb = 1, 10 21809 ks_bd = 0.0_dp 21810 ks_bc = 0.0_dp 21811 p_bd = pbd((md - 1)*10 + mb) 21812 p_bc = pbc((mc - 1)*10 + mb) 21813 DO ma = 1, 7 21814 p_index = p_index + 1 21815 tmp = scale*prim(p_index) 21816 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21817 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21818 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21819 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21820 END DO 21821 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 21822 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 21823 END DO 21824 END DO 21825 END DO 21826 END SUBROUTINE block_7_10 21827! ************************************************************************************************** 21828!> \brief ... 21829!> \param mc_max ... 21830!> \param md_max ... 21831!> \param kbd ... 21832!> \param kbc ... 21833!> \param kad ... 21834!> \param kac ... 21835!> \param pbd ... 21836!> \param pbc ... 21837!> \param pad ... 21838!> \param pac ... 21839!> \param prim ... 21840!> \param scale ... 21841! ************************************************************************************************** 21842 SUBROUTINE block_7_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21843 INTEGER :: mc_max, md_max 21844 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(7*md_max), kac(7*mc_max), & 21845 pbd(11*md_max), pbc(11*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*11*mc_max*md_max), & 21846 scale 21847 21848 INTEGER :: ma, mb, mc, md, p_index 21849 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21850 21851 kbd(1:11*md_max) = 0.0_dp 21852 kbc(1:11*mc_max) = 0.0_dp 21853 kad(1:7*md_max) = 0.0_dp 21854 kac(1:7*mc_max) = 0.0_dp 21855 p_index = 0 21856 DO md = 1, md_max 21857 DO mc = 1, mc_max 21858 DO mb = 1, 11 21859 ks_bd = 0.0_dp 21860 ks_bc = 0.0_dp 21861 p_bd = pbd((md - 1)*11 + mb) 21862 p_bc = pbc((mc - 1)*11 + mb) 21863 DO ma = 1, 7 21864 p_index = p_index + 1 21865 tmp = scale*prim(p_index) 21866 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21867 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21868 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21869 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21870 END DO 21871 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 21872 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 21873 END DO 21874 END DO 21875 END DO 21876 END SUBROUTINE block_7_11 21877! ************************************************************************************************** 21878!> \brief ... 21879!> \param mc_max ... 21880!> \param md_max ... 21881!> \param kbd ... 21882!> \param kbc ... 21883!> \param kad ... 21884!> \param kac ... 21885!> \param pbd ... 21886!> \param pbc ... 21887!> \param pad ... 21888!> \param pac ... 21889!> \param prim ... 21890!> \param scale ... 21891! ************************************************************************************************** 21892 SUBROUTINE block_7_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21893 INTEGER :: mc_max, md_max 21894 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(7*md_max), kac(7*mc_max), & 21895 pbd(15*md_max), pbc(15*mc_max), pad(7*md_max), pac(7*mc_max), prim(7*15*mc_max*md_max), & 21896 scale 21897 21898 INTEGER :: ma, mb, mc, md, p_index 21899 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21900 21901 kbd(1:15*md_max) = 0.0_dp 21902 kbc(1:15*mc_max) = 0.0_dp 21903 kad(1:7*md_max) = 0.0_dp 21904 kac(1:7*mc_max) = 0.0_dp 21905 p_index = 0 21906 DO md = 1, md_max 21907 DO mc = 1, mc_max 21908 DO mb = 1, 15 21909 ks_bd = 0.0_dp 21910 ks_bc = 0.0_dp 21911 p_bd = pbd((md - 1)*15 + mb) 21912 p_bc = pbc((mc - 1)*15 + mb) 21913 DO ma = 1, 7 21914 p_index = p_index + 1 21915 tmp = scale*prim(p_index) 21916 ks_bc = ks_bc + tmp*pad((md - 1)*7 + ma) 21917 ks_bd = ks_bd + tmp*pac((mc - 1)*7 + ma) 21918 kad((md - 1)*7 + ma) = kad((md - 1)*7 + ma) - tmp*p_bc 21919 kac((mc - 1)*7 + ma) = kac((mc - 1)*7 + ma) - tmp*p_bd 21920 END DO 21921 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 21922 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 21923 END DO 21924 END DO 21925 END DO 21926 END SUBROUTINE block_7_15 21927! ************************************************************************************************** 21928!> \brief ... 21929!> \param kbd ... 21930!> \param kbc ... 21931!> \param kad ... 21932!> \param kac ... 21933!> \param pbd ... 21934!> \param pbc ... 21935!> \param pad ... 21936!> \param pac ... 21937!> \param prim ... 21938!> \param scale ... 21939! ************************************************************************************************** 21940 SUBROUTINE block_9_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21941 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(9*1), kac(9*1), & 21942 pbd(1*1), pbc(1*1), pad(9*1), & 21943 pac(9*1), prim(9*1*1*1), scale 21944 21945 INTEGER :: ma, mb, mc, md, p_index 21946 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21947 21948 kbd(1:1*1) = 0.0_dp 21949 kbc(1:1*1) = 0.0_dp 21950 kad(1:9*1) = 0.0_dp 21951 kac(1:9*1) = 0.0_dp 21952 p_index = 0 21953 DO md = 1, 1 21954 DO mc = 1, 1 21955 DO mb = 1, 1 21956 ks_bd = 0.0_dp 21957 ks_bc = 0.0_dp 21958 p_bd = pbd((md - 1)*1 + mb) 21959 p_bc = pbc((mc - 1)*1 + mb) 21960 DO ma = 1, 9 21961 p_index = p_index + 1 21962 tmp = scale*prim(p_index) 21963 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 21964 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 21965 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 21966 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 21967 END DO 21968 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 21969 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 21970 END DO 21971 END DO 21972 END DO 21973 END SUBROUTINE block_9_1_1_1 21974! ************************************************************************************************** 21975!> \brief ... 21976!> \param kbd ... 21977!> \param kbc ... 21978!> \param kad ... 21979!> \param kac ... 21980!> \param pbd ... 21981!> \param pbc ... 21982!> \param pad ... 21983!> \param pac ... 21984!> \param prim ... 21985!> \param scale ... 21986! ************************************************************************************************** 21987 SUBROUTINE block_9_1_1_2(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 21988 REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(9*2), kac(9*1), & 21989 pbd(1*2), pbc(1*1), pad(9*2), & 21990 pac(9*1), prim(9*1*1*2), scale 21991 21992 INTEGER :: ma, mb, mc, md, p_index 21993 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 21994 21995 kbd(1:1*2) = 0.0_dp 21996 kbc(1:1*1) = 0.0_dp 21997 kad(1:9*2) = 0.0_dp 21998 kac(1:9*1) = 0.0_dp 21999 p_index = 0 22000 DO md = 1, 2 22001 DO mc = 1, 1 22002 DO mb = 1, 1 22003 ks_bd = 0.0_dp 22004 ks_bc = 0.0_dp 22005 p_bd = pbd((md - 1)*1 + mb) 22006 p_bc = pbc((mc - 1)*1 + mb) 22007 DO ma = 1, 9 22008 p_index = p_index + 1 22009 tmp = scale*prim(p_index) 22010 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22011 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22012 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22013 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22014 END DO 22015 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22016 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22017 END DO 22018 END DO 22019 END DO 22020 END SUBROUTINE block_9_1_1_2 22021! ************************************************************************************************** 22022!> \brief ... 22023!> \param md_max ... 22024!> \param kbd ... 22025!> \param kbc ... 22026!> \param kad ... 22027!> \param kac ... 22028!> \param pbd ... 22029!> \param pbc ... 22030!> \param pad ... 22031!> \param pac ... 22032!> \param prim ... 22033!> \param scale ... 22034! ************************************************************************************************** 22035 SUBROUTINE block_9_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22036 INTEGER :: md_max 22037 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(9*md_max), kac(9*1), pbd(1*md_max), pbc(1*1), & 22038 pad(9*md_max), pac(9*1), prim(9*1*1*md_max), scale 22039 22040 INTEGER :: ma, mb, mc, md, p_index 22041 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22042 22043 kbd(1:1*md_max) = 0.0_dp 22044 kbc(1:1*1) = 0.0_dp 22045 kad(1:9*md_max) = 0.0_dp 22046 kac(1:9*1) = 0.0_dp 22047 p_index = 0 22048 DO md = 1, md_max 22049 DO mc = 1, 1 22050 DO mb = 1, 1 22051 ks_bd = 0.0_dp 22052 ks_bc = 0.0_dp 22053 p_bd = pbd((md - 1)*1 + mb) 22054 p_bc = pbc((mc - 1)*1 + mb) 22055 DO ma = 1, 9 22056 p_index = p_index + 1 22057 tmp = scale*prim(p_index) 22058 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22059 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22060 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22061 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22062 END DO 22063 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22064 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22065 END DO 22066 END DO 22067 END DO 22068 END SUBROUTINE block_9_1_1 22069! ************************************************************************************************** 22070!> \brief ... 22071!> \param kbd ... 22072!> \param kbc ... 22073!> \param kad ... 22074!> \param kac ... 22075!> \param pbd ... 22076!> \param pbc ... 22077!> \param pad ... 22078!> \param pac ... 22079!> \param prim ... 22080!> \param scale ... 22081! ************************************************************************************************** 22082 SUBROUTINE block_9_1_2_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22083 REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(9*1), kac(9*2), & 22084 pbd(1*1), pbc(1*2), pad(9*1), & 22085 pac(9*2), prim(9*1*2*1), scale 22086 22087 INTEGER :: ma, mb, mc, md, p_index 22088 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22089 22090 kbd(1:1*1) = 0.0_dp 22091 kbc(1:1*2) = 0.0_dp 22092 kad(1:9*1) = 0.0_dp 22093 kac(1:9*2) = 0.0_dp 22094 p_index = 0 22095 DO md = 1, 1 22096 DO mc = 1, 2 22097 DO mb = 1, 1 22098 ks_bd = 0.0_dp 22099 ks_bc = 0.0_dp 22100 p_bd = pbd((md - 1)*1 + mb) 22101 p_bc = pbc((mc - 1)*1 + mb) 22102 DO ma = 1, 9 22103 p_index = p_index + 1 22104 tmp = scale*prim(p_index) 22105 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22106 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22107 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22108 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22109 END DO 22110 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22111 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22112 END DO 22113 END DO 22114 END DO 22115 END SUBROUTINE block_9_1_2_1 22116! ************************************************************************************************** 22117!> \brief ... 22118!> \param md_max ... 22119!> \param kbd ... 22120!> \param kbc ... 22121!> \param kad ... 22122!> \param kac ... 22123!> \param pbd ... 22124!> \param pbc ... 22125!> \param pad ... 22126!> \param pac ... 22127!> \param prim ... 22128!> \param scale ... 22129! ************************************************************************************************** 22130 SUBROUTINE block_9_1_2(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22131 INTEGER :: md_max 22132 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*2), kad(9*md_max), kac(9*2), pbd(1*md_max), pbc(1*2), & 22133 pad(9*md_max), pac(9*2), prim(9*1*2*md_max), scale 22134 22135 INTEGER :: ma, mb, mc, md, p_index 22136 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22137 22138 kbd(1:1*md_max) = 0.0_dp 22139 kbc(1:1*2) = 0.0_dp 22140 kad(1:9*md_max) = 0.0_dp 22141 kac(1:9*2) = 0.0_dp 22142 p_index = 0 22143 DO md = 1, md_max 22144 DO mc = 1, 2 22145 DO mb = 1, 1 22146 ks_bd = 0.0_dp 22147 ks_bc = 0.0_dp 22148 p_bd = pbd((md - 1)*1 + mb) 22149 p_bc = pbc((mc - 1)*1 + mb) 22150 DO ma = 1, 9 22151 p_index = p_index + 1 22152 tmp = scale*prim(p_index) 22153 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22154 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22155 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22156 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22157 END DO 22158 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22159 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22160 END DO 22161 END DO 22162 END DO 22163 END SUBROUTINE block_9_1_2 22164! ************************************************************************************************** 22165!> \brief ... 22166!> \param mc_max ... 22167!> \param md_max ... 22168!> \param kbd ... 22169!> \param kbc ... 22170!> \param kad ... 22171!> \param kac ... 22172!> \param pbd ... 22173!> \param pbc ... 22174!> \param pad ... 22175!> \param pac ... 22176!> \param prim ... 22177!> \param scale ... 22178! ************************************************************************************************** 22179 SUBROUTINE block_9_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22180 INTEGER :: mc_max, md_max 22181 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(9*md_max), kac(9*mc_max), pbd(1*md_max), & 22182 pbc(1*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*1*mc_max*md_max), scale 22183 22184 INTEGER :: ma, mb, mc, md, p_index 22185 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22186 22187 kbd(1:1*md_max) = 0.0_dp 22188 kbc(1:1*mc_max) = 0.0_dp 22189 kad(1:9*md_max) = 0.0_dp 22190 kac(1:9*mc_max) = 0.0_dp 22191 p_index = 0 22192 DO md = 1, md_max 22193 DO mc = 1, mc_max 22194 DO mb = 1, 1 22195 ks_bd = 0.0_dp 22196 ks_bc = 0.0_dp 22197 p_bd = pbd((md - 1)*1 + mb) 22198 p_bc = pbc((mc - 1)*1 + mb) 22199 DO ma = 1, 9 22200 p_index = p_index + 1 22201 tmp = scale*prim(p_index) 22202 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22203 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22204 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22205 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22206 END DO 22207 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22208 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22209 END DO 22210 END DO 22211 END DO 22212 END SUBROUTINE block_9_1 22213! ************************************************************************************************** 22214!> \brief ... 22215!> \param kbd ... 22216!> \param kbc ... 22217!> \param kad ... 22218!> \param kac ... 22219!> \param pbd ... 22220!> \param pbc ... 22221!> \param pad ... 22222!> \param pac ... 22223!> \param prim ... 22224!> \param scale ... 22225! ************************************************************************************************** 22226 SUBROUTINE block_9_2_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22227 REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(9*1), kac(9*1), & 22228 pbd(2*1), pbc(2*1), pad(9*1), & 22229 pac(9*1), prim(9*2*1*1), scale 22230 22231 INTEGER :: ma, mb, mc, md, p_index 22232 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22233 22234 kbd(1:2*1) = 0.0_dp 22235 kbc(1:2*1) = 0.0_dp 22236 kad(1:9*1) = 0.0_dp 22237 kac(1:9*1) = 0.0_dp 22238 p_index = 0 22239 DO md = 1, 1 22240 DO mc = 1, 1 22241 DO mb = 1, 2 22242 ks_bd = 0.0_dp 22243 ks_bc = 0.0_dp 22244 p_bd = pbd((md - 1)*2 + mb) 22245 p_bc = pbc((mc - 1)*2 + mb) 22246 DO ma = 1, 9 22247 p_index = p_index + 1 22248 tmp = scale*prim(p_index) 22249 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22250 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22251 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22252 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22253 END DO 22254 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 22255 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 22256 END DO 22257 END DO 22258 END DO 22259 END SUBROUTINE block_9_2_1_1 22260! ************************************************************************************************** 22261!> \brief ... 22262!> \param md_max ... 22263!> \param kbd ... 22264!> \param kbc ... 22265!> \param kad ... 22266!> \param kac ... 22267!> \param pbd ... 22268!> \param pbc ... 22269!> \param pad ... 22270!> \param pac ... 22271!> \param prim ... 22272!> \param scale ... 22273! ************************************************************************************************** 22274 SUBROUTINE block_9_2_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22275 INTEGER :: md_max 22276 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(9*md_max), kac(9*1), pbd(2*md_max), pbc(2*1), & 22277 pad(9*md_max), pac(9*1), prim(9*2*1*md_max), scale 22278 22279 INTEGER :: ma, mb, mc, md, p_index 22280 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22281 22282 kbd(1:2*md_max) = 0.0_dp 22283 kbc(1:2*1) = 0.0_dp 22284 kad(1:9*md_max) = 0.0_dp 22285 kac(1:9*1) = 0.0_dp 22286 p_index = 0 22287 DO md = 1, md_max 22288 DO mc = 1, 1 22289 DO mb = 1, 2 22290 ks_bd = 0.0_dp 22291 ks_bc = 0.0_dp 22292 p_bd = pbd((md - 1)*2 + mb) 22293 p_bc = pbc((mc - 1)*2 + mb) 22294 DO ma = 1, 9 22295 p_index = p_index + 1 22296 tmp = scale*prim(p_index) 22297 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22298 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22299 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22300 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22301 END DO 22302 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 22303 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 22304 END DO 22305 END DO 22306 END DO 22307 END SUBROUTINE block_9_2_1 22308! ************************************************************************************************** 22309!> \brief ... 22310!> \param mc_max ... 22311!> \param md_max ... 22312!> \param kbd ... 22313!> \param kbc ... 22314!> \param kad ... 22315!> \param kac ... 22316!> \param pbd ... 22317!> \param pbc ... 22318!> \param pad ... 22319!> \param pac ... 22320!> \param prim ... 22321!> \param scale ... 22322! ************************************************************************************************** 22323 SUBROUTINE block_9_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22324 INTEGER :: mc_max, md_max 22325 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(9*md_max), kac(9*mc_max), pbd(2*md_max), & 22326 pbc(2*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*2*mc_max*md_max), scale 22327 22328 INTEGER :: ma, mb, mc, md, p_index 22329 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22330 22331 kbd(1:2*md_max) = 0.0_dp 22332 kbc(1:2*mc_max) = 0.0_dp 22333 kad(1:9*md_max) = 0.0_dp 22334 kac(1:9*mc_max) = 0.0_dp 22335 p_index = 0 22336 DO md = 1, md_max 22337 DO mc = 1, mc_max 22338 DO mb = 1, 2 22339 ks_bd = 0.0_dp 22340 ks_bc = 0.0_dp 22341 p_bd = pbd((md - 1)*2 + mb) 22342 p_bc = pbc((mc - 1)*2 + mb) 22343 DO ma = 1, 9 22344 p_index = p_index + 1 22345 tmp = scale*prim(p_index) 22346 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22347 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22348 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22349 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22350 END DO 22351 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 22352 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 22353 END DO 22354 END DO 22355 END DO 22356 END SUBROUTINE block_9_2 22357! ************************************************************************************************** 22358!> \brief ... 22359!> \param mc_max ... 22360!> \param md_max ... 22361!> \param kbd ... 22362!> \param kbc ... 22363!> \param kad ... 22364!> \param kac ... 22365!> \param pbd ... 22366!> \param pbc ... 22367!> \param pad ... 22368!> \param pac ... 22369!> \param prim ... 22370!> \param scale ... 22371! ************************************************************************************************** 22372 SUBROUTINE block_9_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22373 INTEGER :: mc_max, md_max 22374 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(9*md_max), kac(9*mc_max), pbd(3*md_max), & 22375 pbc(3*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*3*mc_max*md_max), scale 22376 22377 INTEGER :: ma, mb, mc, md, p_index 22378 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22379 22380 kbd(1:3*md_max) = 0.0_dp 22381 kbc(1:3*mc_max) = 0.0_dp 22382 kad(1:9*md_max) = 0.0_dp 22383 kac(1:9*mc_max) = 0.0_dp 22384 p_index = 0 22385 DO md = 1, md_max 22386 DO mc = 1, mc_max 22387 DO mb = 1, 3 22388 ks_bd = 0.0_dp 22389 ks_bc = 0.0_dp 22390 p_bd = pbd((md - 1)*3 + mb) 22391 p_bc = pbc((mc - 1)*3 + mb) 22392 DO ma = 1, 9 22393 p_index = p_index + 1 22394 tmp = scale*prim(p_index) 22395 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22396 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22397 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22398 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22399 END DO 22400 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 22401 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 22402 END DO 22403 END DO 22404 END DO 22405 END SUBROUTINE block_9_3 22406! ************************************************************************************************** 22407!> \brief ... 22408!> \param mc_max ... 22409!> \param md_max ... 22410!> \param kbd ... 22411!> \param kbc ... 22412!> \param kad ... 22413!> \param kac ... 22414!> \param pbd ... 22415!> \param pbc ... 22416!> \param pad ... 22417!> \param pac ... 22418!> \param prim ... 22419!> \param scale ... 22420! ************************************************************************************************** 22421 SUBROUTINE block_9_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22422 INTEGER :: mc_max, md_max 22423 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(9*md_max), kac(9*mc_max), pbd(4*md_max), & 22424 pbc(4*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*4*mc_max*md_max), scale 22425 22426 INTEGER :: ma, mb, mc, md, p_index 22427 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22428 22429 kbd(1:4*md_max) = 0.0_dp 22430 kbc(1:4*mc_max) = 0.0_dp 22431 kad(1:9*md_max) = 0.0_dp 22432 kac(1:9*mc_max) = 0.0_dp 22433 p_index = 0 22434 DO md = 1, md_max 22435 DO mc = 1, mc_max 22436 DO mb = 1, 4 22437 ks_bd = 0.0_dp 22438 ks_bc = 0.0_dp 22439 p_bd = pbd((md - 1)*4 + mb) 22440 p_bc = pbc((mc - 1)*4 + mb) 22441 DO ma = 1, 9 22442 p_index = p_index + 1 22443 tmp = scale*prim(p_index) 22444 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22445 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22446 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22447 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22448 END DO 22449 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 22450 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 22451 END DO 22452 END DO 22453 END DO 22454 END SUBROUTINE block_9_4 22455! ************************************************************************************************** 22456!> \brief ... 22457!> \param mc_max ... 22458!> \param md_max ... 22459!> \param kbd ... 22460!> \param kbc ... 22461!> \param kad ... 22462!> \param kac ... 22463!> \param pbd ... 22464!> \param pbc ... 22465!> \param pad ... 22466!> \param pac ... 22467!> \param prim ... 22468!> \param scale ... 22469! ************************************************************************************************** 22470 SUBROUTINE block_9_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22471 INTEGER :: mc_max, md_max 22472 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(9*md_max), kac(9*mc_max), pbd(5*md_max), & 22473 pbc(5*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*5*mc_max*md_max), scale 22474 22475 INTEGER :: ma, mb, mc, md, p_index 22476 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22477 22478 kbd(1:5*md_max) = 0.0_dp 22479 kbc(1:5*mc_max) = 0.0_dp 22480 kad(1:9*md_max) = 0.0_dp 22481 kac(1:9*mc_max) = 0.0_dp 22482 p_index = 0 22483 DO md = 1, md_max 22484 DO mc = 1, mc_max 22485 DO mb = 1, 5 22486 ks_bd = 0.0_dp 22487 ks_bc = 0.0_dp 22488 p_bd = pbd((md - 1)*5 + mb) 22489 p_bc = pbc((mc - 1)*5 + mb) 22490 DO ma = 1, 9 22491 p_index = p_index + 1 22492 tmp = scale*prim(p_index) 22493 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22494 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22495 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22496 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22497 END DO 22498 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 22499 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 22500 END DO 22501 END DO 22502 END DO 22503 END SUBROUTINE block_9_5 22504! ************************************************************************************************** 22505!> \brief ... 22506!> \param mc_max ... 22507!> \param md_max ... 22508!> \param kbd ... 22509!> \param kbc ... 22510!> \param kad ... 22511!> \param kac ... 22512!> \param pbd ... 22513!> \param pbc ... 22514!> \param pad ... 22515!> \param pac ... 22516!> \param prim ... 22517!> \param scale ... 22518! ************************************************************************************************** 22519 SUBROUTINE block_9_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22520 INTEGER :: mc_max, md_max 22521 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(9*md_max), kac(9*mc_max), pbd(6*md_max), & 22522 pbc(6*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*6*mc_max*md_max), scale 22523 22524 INTEGER :: ma, mb, mc, md, p_index 22525 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22526 22527 kbd(1:6*md_max) = 0.0_dp 22528 kbc(1:6*mc_max) = 0.0_dp 22529 kad(1:9*md_max) = 0.0_dp 22530 kac(1:9*mc_max) = 0.0_dp 22531 p_index = 0 22532 DO md = 1, md_max 22533 DO mc = 1, mc_max 22534 DO mb = 1, 6 22535 ks_bd = 0.0_dp 22536 ks_bc = 0.0_dp 22537 p_bd = pbd((md - 1)*6 + mb) 22538 p_bc = pbc((mc - 1)*6 + mb) 22539 DO ma = 1, 9 22540 p_index = p_index + 1 22541 tmp = scale*prim(p_index) 22542 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22543 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22544 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22545 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22546 END DO 22547 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 22548 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 22549 END DO 22550 END DO 22551 END DO 22552 END SUBROUTINE block_9_6 22553! ************************************************************************************************** 22554!> \brief ... 22555!> \param mc_max ... 22556!> \param md_max ... 22557!> \param kbd ... 22558!> \param kbc ... 22559!> \param kad ... 22560!> \param kac ... 22561!> \param pbd ... 22562!> \param pbc ... 22563!> \param pad ... 22564!> \param pac ... 22565!> \param prim ... 22566!> \param scale ... 22567! ************************************************************************************************** 22568 SUBROUTINE block_9_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22569 INTEGER :: mc_max, md_max 22570 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(9*md_max), kac(9*mc_max), pbd(7*md_max), & 22571 pbc(7*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*7*mc_max*md_max), scale 22572 22573 INTEGER :: ma, mb, mc, md, p_index 22574 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22575 22576 kbd(1:7*md_max) = 0.0_dp 22577 kbc(1:7*mc_max) = 0.0_dp 22578 kad(1:9*md_max) = 0.0_dp 22579 kac(1:9*mc_max) = 0.0_dp 22580 p_index = 0 22581 DO md = 1, md_max 22582 DO mc = 1, mc_max 22583 DO mb = 1, 7 22584 ks_bd = 0.0_dp 22585 ks_bc = 0.0_dp 22586 p_bd = pbd((md - 1)*7 + mb) 22587 p_bc = pbc((mc - 1)*7 + mb) 22588 DO ma = 1, 9 22589 p_index = p_index + 1 22590 tmp = scale*prim(p_index) 22591 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22592 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22593 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22594 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22595 END DO 22596 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 22597 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 22598 END DO 22599 END DO 22600 END DO 22601 END SUBROUTINE block_9_7 22602! ************************************************************************************************** 22603!> \brief ... 22604!> \param mc_max ... 22605!> \param md_max ... 22606!> \param kbd ... 22607!> \param kbc ... 22608!> \param kad ... 22609!> \param kac ... 22610!> \param pbd ... 22611!> \param pbc ... 22612!> \param pad ... 22613!> \param pac ... 22614!> \param prim ... 22615!> \param scale ... 22616! ************************************************************************************************** 22617 SUBROUTINE block_9_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22618 INTEGER :: mc_max, md_max 22619 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(9*md_max), kac(9*mc_max), pbd(9*md_max), & 22620 pbc(9*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*9*mc_max*md_max), scale 22621 22622 INTEGER :: ma, mb, mc, md, p_index 22623 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22624 22625 kbd(1:9*md_max) = 0.0_dp 22626 kbc(1:9*mc_max) = 0.0_dp 22627 kad(1:9*md_max) = 0.0_dp 22628 kac(1:9*mc_max) = 0.0_dp 22629 p_index = 0 22630 DO md = 1, md_max 22631 DO mc = 1, mc_max 22632 DO mb = 1, 9 22633 ks_bd = 0.0_dp 22634 ks_bc = 0.0_dp 22635 p_bd = pbd((md - 1)*9 + mb) 22636 p_bc = pbc((mc - 1)*9 + mb) 22637 DO ma = 1, 9 22638 p_index = p_index + 1 22639 tmp = scale*prim(p_index) 22640 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22641 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22642 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22643 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22644 END DO 22645 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 22646 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 22647 END DO 22648 END DO 22649 END DO 22650 END SUBROUTINE block_9_9 22651! ************************************************************************************************** 22652!> \brief ... 22653!> \param mc_max ... 22654!> \param md_max ... 22655!> \param kbd ... 22656!> \param kbc ... 22657!> \param kad ... 22658!> \param kac ... 22659!> \param pbd ... 22660!> \param pbc ... 22661!> \param pad ... 22662!> \param pac ... 22663!> \param prim ... 22664!> \param scale ... 22665! ************************************************************************************************** 22666 SUBROUTINE block_9_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22667 INTEGER :: mc_max, md_max 22668 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(9*md_max), kac(9*mc_max), & 22669 pbd(10*md_max), pbc(10*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*10*mc_max*md_max), & 22670 scale 22671 22672 INTEGER :: ma, mb, mc, md, p_index 22673 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22674 22675 kbd(1:10*md_max) = 0.0_dp 22676 kbc(1:10*mc_max) = 0.0_dp 22677 kad(1:9*md_max) = 0.0_dp 22678 kac(1:9*mc_max) = 0.0_dp 22679 p_index = 0 22680 DO md = 1, md_max 22681 DO mc = 1, mc_max 22682 DO mb = 1, 10 22683 ks_bd = 0.0_dp 22684 ks_bc = 0.0_dp 22685 p_bd = pbd((md - 1)*10 + mb) 22686 p_bc = pbc((mc - 1)*10 + mb) 22687 DO ma = 1, 9 22688 p_index = p_index + 1 22689 tmp = scale*prim(p_index) 22690 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22691 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22692 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22693 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22694 END DO 22695 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 22696 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 22697 END DO 22698 END DO 22699 END DO 22700 END SUBROUTINE block_9_10 22701! ************************************************************************************************** 22702!> \brief ... 22703!> \param mc_max ... 22704!> \param md_max ... 22705!> \param kbd ... 22706!> \param kbc ... 22707!> \param kad ... 22708!> \param kac ... 22709!> \param pbd ... 22710!> \param pbc ... 22711!> \param pad ... 22712!> \param pac ... 22713!> \param prim ... 22714!> \param scale ... 22715! ************************************************************************************************** 22716 SUBROUTINE block_9_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22717 INTEGER :: mc_max, md_max 22718 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(9*md_max), kac(9*mc_max), & 22719 pbd(11*md_max), pbc(11*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*11*mc_max*md_max), & 22720 scale 22721 22722 INTEGER :: ma, mb, mc, md, p_index 22723 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22724 22725 kbd(1:11*md_max) = 0.0_dp 22726 kbc(1:11*mc_max) = 0.0_dp 22727 kad(1:9*md_max) = 0.0_dp 22728 kac(1:9*mc_max) = 0.0_dp 22729 p_index = 0 22730 DO md = 1, md_max 22731 DO mc = 1, mc_max 22732 DO mb = 1, 11 22733 ks_bd = 0.0_dp 22734 ks_bc = 0.0_dp 22735 p_bd = pbd((md - 1)*11 + mb) 22736 p_bc = pbc((mc - 1)*11 + mb) 22737 DO ma = 1, 9 22738 p_index = p_index + 1 22739 tmp = scale*prim(p_index) 22740 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22741 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22742 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22743 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22744 END DO 22745 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 22746 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 22747 END DO 22748 END DO 22749 END DO 22750 END SUBROUTINE block_9_11 22751! ************************************************************************************************** 22752!> \brief ... 22753!> \param mc_max ... 22754!> \param md_max ... 22755!> \param kbd ... 22756!> \param kbc ... 22757!> \param kad ... 22758!> \param kac ... 22759!> \param pbd ... 22760!> \param pbc ... 22761!> \param pad ... 22762!> \param pac ... 22763!> \param prim ... 22764!> \param scale ... 22765! ************************************************************************************************** 22766 SUBROUTINE block_9_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22767 INTEGER :: mc_max, md_max 22768 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(9*md_max), kac(9*mc_max), & 22769 pbd(15*md_max), pbc(15*mc_max), pad(9*md_max), pac(9*mc_max), prim(9*15*mc_max*md_max), & 22770 scale 22771 22772 INTEGER :: ma, mb, mc, md, p_index 22773 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22774 22775 kbd(1:15*md_max) = 0.0_dp 22776 kbc(1:15*mc_max) = 0.0_dp 22777 kad(1:9*md_max) = 0.0_dp 22778 kac(1:9*mc_max) = 0.0_dp 22779 p_index = 0 22780 DO md = 1, md_max 22781 DO mc = 1, mc_max 22782 DO mb = 1, 15 22783 ks_bd = 0.0_dp 22784 ks_bc = 0.0_dp 22785 p_bd = pbd((md - 1)*15 + mb) 22786 p_bc = pbc((mc - 1)*15 + mb) 22787 DO ma = 1, 9 22788 p_index = p_index + 1 22789 tmp = scale*prim(p_index) 22790 ks_bc = ks_bc + tmp*pad((md - 1)*9 + ma) 22791 ks_bd = ks_bd + tmp*pac((mc - 1)*9 + ma) 22792 kad((md - 1)*9 + ma) = kad((md - 1)*9 + ma) - tmp*p_bc 22793 kac((mc - 1)*9 + ma) = kac((mc - 1)*9 + ma) - tmp*p_bd 22794 END DO 22795 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 22796 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 22797 END DO 22798 END DO 22799 END DO 22800 END SUBROUTINE block_9_15 22801! ************************************************************************************************** 22802!> \brief ... 22803!> \param kbd ... 22804!> \param kbc ... 22805!> \param kad ... 22806!> \param kac ... 22807!> \param pbd ... 22808!> \param pbc ... 22809!> \param pad ... 22810!> \param pac ... 22811!> \param prim ... 22812!> \param scale ... 22813! ************************************************************************************************** 22814 SUBROUTINE block_10_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22815 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(10*1), & 22816 kac(10*1), pbd(1*1), pbc(1*1), & 22817 pad(10*1), pac(10*1), prim(10*1*1*1), & 22818 scale 22819 22820 INTEGER :: ma, mb, mc, md, p_index 22821 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22822 22823 kbd(1:1*1) = 0.0_dp 22824 kbc(1:1*1) = 0.0_dp 22825 kad(1:10*1) = 0.0_dp 22826 kac(1:10*1) = 0.0_dp 22827 p_index = 0 22828 DO md = 1, 1 22829 DO mc = 1, 1 22830 DO mb = 1, 1 22831 ks_bd = 0.0_dp 22832 ks_bc = 0.0_dp 22833 p_bd = pbd((md - 1)*1 + mb) 22834 p_bc = pbc((mc - 1)*1 + mb) 22835 DO ma = 1, 10 22836 p_index = p_index + 1 22837 tmp = scale*prim(p_index) 22838 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 22839 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 22840 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 22841 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 22842 END DO 22843 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22844 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22845 END DO 22846 END DO 22847 END DO 22848 END SUBROUTINE block_10_1_1_1 22849! ************************************************************************************************** 22850!> \brief ... 22851!> \param md_max ... 22852!> \param kbd ... 22853!> \param kbc ... 22854!> \param kad ... 22855!> \param kac ... 22856!> \param pbd ... 22857!> \param pbc ... 22858!> \param pad ... 22859!> \param pac ... 22860!> \param prim ... 22861!> \param scale ... 22862! ************************************************************************************************** 22863 SUBROUTINE block_10_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22864 INTEGER :: md_max 22865 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(10*md_max), kac(10*1), pbd(1*md_max), & 22866 pbc(1*1), pad(10*md_max), pac(10*1), prim(10*1*1*md_max), scale 22867 22868 INTEGER :: ma, mb, mc, md, p_index 22869 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22870 22871 kbd(1:1*md_max) = 0.0_dp 22872 kbc(1:1*1) = 0.0_dp 22873 kad(1:10*md_max) = 0.0_dp 22874 kac(1:10*1) = 0.0_dp 22875 p_index = 0 22876 DO md = 1, md_max 22877 DO mc = 1, 1 22878 DO mb = 1, 1 22879 ks_bd = 0.0_dp 22880 ks_bc = 0.0_dp 22881 p_bd = pbd((md - 1)*1 + mb) 22882 p_bc = pbc((mc - 1)*1 + mb) 22883 DO ma = 1, 10 22884 p_index = p_index + 1 22885 tmp = scale*prim(p_index) 22886 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 22887 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 22888 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 22889 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 22890 END DO 22891 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22892 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22893 END DO 22894 END DO 22895 END DO 22896 END SUBROUTINE block_10_1_1 22897! ************************************************************************************************** 22898!> \brief ... 22899!> \param mc_max ... 22900!> \param md_max ... 22901!> \param kbd ... 22902!> \param kbc ... 22903!> \param kad ... 22904!> \param kac ... 22905!> \param pbd ... 22906!> \param pbc ... 22907!> \param pad ... 22908!> \param pac ... 22909!> \param prim ... 22910!> \param scale ... 22911! ************************************************************************************************** 22912 SUBROUTINE block_10_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22913 INTEGER :: mc_max, md_max 22914 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(10*md_max), kac(10*mc_max), & 22915 pbd(1*md_max), pbc(1*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*1*mc_max*md_max), & 22916 scale 22917 22918 INTEGER :: ma, mb, mc, md, p_index 22919 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22920 22921 kbd(1:1*md_max) = 0.0_dp 22922 kbc(1:1*mc_max) = 0.0_dp 22923 kad(1:10*md_max) = 0.0_dp 22924 kac(1:10*mc_max) = 0.0_dp 22925 p_index = 0 22926 DO md = 1, md_max 22927 DO mc = 1, mc_max 22928 DO mb = 1, 1 22929 ks_bd = 0.0_dp 22930 ks_bc = 0.0_dp 22931 p_bd = pbd((md - 1)*1 + mb) 22932 p_bc = pbc((mc - 1)*1 + mb) 22933 DO ma = 1, 10 22934 p_index = p_index + 1 22935 tmp = scale*prim(p_index) 22936 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 22937 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 22938 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 22939 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 22940 END DO 22941 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 22942 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 22943 END DO 22944 END DO 22945 END DO 22946 END SUBROUTINE block_10_1 22947! ************************************************************************************************** 22948!> \brief ... 22949!> \param mc_max ... 22950!> \param md_max ... 22951!> \param kbd ... 22952!> \param kbc ... 22953!> \param kad ... 22954!> \param kac ... 22955!> \param pbd ... 22956!> \param pbc ... 22957!> \param pad ... 22958!> \param pac ... 22959!> \param prim ... 22960!> \param scale ... 22961! ************************************************************************************************** 22962 SUBROUTINE block_10_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 22963 INTEGER :: mc_max, md_max 22964 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(10*md_max), kac(10*mc_max), & 22965 pbd(2*md_max), pbc(2*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*2*mc_max*md_max), & 22966 scale 22967 22968 INTEGER :: ma, mb, mc, md, p_index 22969 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 22970 22971 kbd(1:2*md_max) = 0.0_dp 22972 kbc(1:2*mc_max) = 0.0_dp 22973 kad(1:10*md_max) = 0.0_dp 22974 kac(1:10*mc_max) = 0.0_dp 22975 p_index = 0 22976 DO md = 1, md_max 22977 DO mc = 1, mc_max 22978 DO mb = 1, 2 22979 ks_bd = 0.0_dp 22980 ks_bc = 0.0_dp 22981 p_bd = pbd((md - 1)*2 + mb) 22982 p_bc = pbc((mc - 1)*2 + mb) 22983 DO ma = 1, 10 22984 p_index = p_index + 1 22985 tmp = scale*prim(p_index) 22986 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 22987 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 22988 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 22989 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 22990 END DO 22991 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 22992 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 22993 END DO 22994 END DO 22995 END DO 22996 END SUBROUTINE block_10_2 22997! ************************************************************************************************** 22998!> \brief ... 22999!> \param mc_max ... 23000!> \param md_max ... 23001!> \param kbd ... 23002!> \param kbc ... 23003!> \param kad ... 23004!> \param kac ... 23005!> \param pbd ... 23006!> \param pbc ... 23007!> \param pad ... 23008!> \param pac ... 23009!> \param prim ... 23010!> \param scale ... 23011! ************************************************************************************************** 23012 SUBROUTINE block_10_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23013 INTEGER :: mc_max, md_max 23014 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(10*md_max), kac(10*mc_max), & 23015 pbd(3*md_max), pbc(3*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*3*mc_max*md_max), & 23016 scale 23017 23018 INTEGER :: ma, mb, mc, md, p_index 23019 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23020 23021 kbd(1:3*md_max) = 0.0_dp 23022 kbc(1:3*mc_max) = 0.0_dp 23023 kad(1:10*md_max) = 0.0_dp 23024 kac(1:10*mc_max) = 0.0_dp 23025 p_index = 0 23026 DO md = 1, md_max 23027 DO mc = 1, mc_max 23028 DO mb = 1, 3 23029 ks_bd = 0.0_dp 23030 ks_bc = 0.0_dp 23031 p_bd = pbd((md - 1)*3 + mb) 23032 p_bc = pbc((mc - 1)*3 + mb) 23033 DO ma = 1, 10 23034 p_index = p_index + 1 23035 tmp = scale*prim(p_index) 23036 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23037 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23038 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23039 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23040 END DO 23041 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 23042 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 23043 END DO 23044 END DO 23045 END DO 23046 END SUBROUTINE block_10_3 23047! ************************************************************************************************** 23048!> \brief ... 23049!> \param mc_max ... 23050!> \param md_max ... 23051!> \param kbd ... 23052!> \param kbc ... 23053!> \param kad ... 23054!> \param kac ... 23055!> \param pbd ... 23056!> \param pbc ... 23057!> \param pad ... 23058!> \param pac ... 23059!> \param prim ... 23060!> \param scale ... 23061! ************************************************************************************************** 23062 SUBROUTINE block_10_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23063 INTEGER :: mc_max, md_max 23064 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(10*md_max), kac(10*mc_max), & 23065 pbd(4*md_max), pbc(4*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*4*mc_max*md_max), & 23066 scale 23067 23068 INTEGER :: ma, mb, mc, md, p_index 23069 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23070 23071 kbd(1:4*md_max) = 0.0_dp 23072 kbc(1:4*mc_max) = 0.0_dp 23073 kad(1:10*md_max) = 0.0_dp 23074 kac(1:10*mc_max) = 0.0_dp 23075 p_index = 0 23076 DO md = 1, md_max 23077 DO mc = 1, mc_max 23078 DO mb = 1, 4 23079 ks_bd = 0.0_dp 23080 ks_bc = 0.0_dp 23081 p_bd = pbd((md - 1)*4 + mb) 23082 p_bc = pbc((mc - 1)*4 + mb) 23083 DO ma = 1, 10 23084 p_index = p_index + 1 23085 tmp = scale*prim(p_index) 23086 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23087 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23088 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23089 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23090 END DO 23091 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 23092 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 23093 END DO 23094 END DO 23095 END DO 23096 END SUBROUTINE block_10_4 23097! ************************************************************************************************** 23098!> \brief ... 23099!> \param mc_max ... 23100!> \param md_max ... 23101!> \param kbd ... 23102!> \param kbc ... 23103!> \param kad ... 23104!> \param kac ... 23105!> \param pbd ... 23106!> \param pbc ... 23107!> \param pad ... 23108!> \param pac ... 23109!> \param prim ... 23110!> \param scale ... 23111! ************************************************************************************************** 23112 SUBROUTINE block_10_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23113 INTEGER :: mc_max, md_max 23114 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(10*md_max), kac(10*mc_max), & 23115 pbd(5*md_max), pbc(5*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*5*mc_max*md_max), & 23116 scale 23117 23118 INTEGER :: ma, mb, mc, md, p_index 23119 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23120 23121 kbd(1:5*md_max) = 0.0_dp 23122 kbc(1:5*mc_max) = 0.0_dp 23123 kad(1:10*md_max) = 0.0_dp 23124 kac(1:10*mc_max) = 0.0_dp 23125 p_index = 0 23126 DO md = 1, md_max 23127 DO mc = 1, mc_max 23128 DO mb = 1, 5 23129 ks_bd = 0.0_dp 23130 ks_bc = 0.0_dp 23131 p_bd = pbd((md - 1)*5 + mb) 23132 p_bc = pbc((mc - 1)*5 + mb) 23133 DO ma = 1, 10 23134 p_index = p_index + 1 23135 tmp = scale*prim(p_index) 23136 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23137 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23138 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23139 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23140 END DO 23141 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 23142 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 23143 END DO 23144 END DO 23145 END DO 23146 END SUBROUTINE block_10_5 23147! ************************************************************************************************** 23148!> \brief ... 23149!> \param mc_max ... 23150!> \param md_max ... 23151!> \param kbd ... 23152!> \param kbc ... 23153!> \param kad ... 23154!> \param kac ... 23155!> \param pbd ... 23156!> \param pbc ... 23157!> \param pad ... 23158!> \param pac ... 23159!> \param prim ... 23160!> \param scale ... 23161! ************************************************************************************************** 23162 SUBROUTINE block_10_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23163 INTEGER :: mc_max, md_max 23164 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(10*md_max), kac(10*mc_max), & 23165 pbd(6*md_max), pbc(6*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*6*mc_max*md_max), & 23166 scale 23167 23168 INTEGER :: ma, mb, mc, md, p_index 23169 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23170 23171 kbd(1:6*md_max) = 0.0_dp 23172 kbc(1:6*mc_max) = 0.0_dp 23173 kad(1:10*md_max) = 0.0_dp 23174 kac(1:10*mc_max) = 0.0_dp 23175 p_index = 0 23176 DO md = 1, md_max 23177 DO mc = 1, mc_max 23178 DO mb = 1, 6 23179 ks_bd = 0.0_dp 23180 ks_bc = 0.0_dp 23181 p_bd = pbd((md - 1)*6 + mb) 23182 p_bc = pbc((mc - 1)*6 + mb) 23183 DO ma = 1, 10 23184 p_index = p_index + 1 23185 tmp = scale*prim(p_index) 23186 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23187 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23188 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23189 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23190 END DO 23191 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 23192 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 23193 END DO 23194 END DO 23195 END DO 23196 END SUBROUTINE block_10_6 23197! ************************************************************************************************** 23198!> \brief ... 23199!> \param mc_max ... 23200!> \param md_max ... 23201!> \param kbd ... 23202!> \param kbc ... 23203!> \param kad ... 23204!> \param kac ... 23205!> \param pbd ... 23206!> \param pbc ... 23207!> \param pad ... 23208!> \param pac ... 23209!> \param prim ... 23210!> \param scale ... 23211! ************************************************************************************************** 23212 SUBROUTINE block_10_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23213 INTEGER :: mc_max, md_max 23214 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(10*md_max), kac(10*mc_max), & 23215 pbd(7*md_max), pbc(7*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*7*mc_max*md_max), & 23216 scale 23217 23218 INTEGER :: ma, mb, mc, md, p_index 23219 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23220 23221 kbd(1:7*md_max) = 0.0_dp 23222 kbc(1:7*mc_max) = 0.0_dp 23223 kad(1:10*md_max) = 0.0_dp 23224 kac(1:10*mc_max) = 0.0_dp 23225 p_index = 0 23226 DO md = 1, md_max 23227 DO mc = 1, mc_max 23228 DO mb = 1, 7 23229 ks_bd = 0.0_dp 23230 ks_bc = 0.0_dp 23231 p_bd = pbd((md - 1)*7 + mb) 23232 p_bc = pbc((mc - 1)*7 + mb) 23233 DO ma = 1, 10 23234 p_index = p_index + 1 23235 tmp = scale*prim(p_index) 23236 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23237 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23238 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23239 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23240 END DO 23241 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 23242 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 23243 END DO 23244 END DO 23245 END DO 23246 END SUBROUTINE block_10_7 23247! ************************************************************************************************** 23248!> \brief ... 23249!> \param mc_max ... 23250!> \param md_max ... 23251!> \param kbd ... 23252!> \param kbc ... 23253!> \param kad ... 23254!> \param kac ... 23255!> \param pbd ... 23256!> \param pbc ... 23257!> \param pad ... 23258!> \param pac ... 23259!> \param prim ... 23260!> \param scale ... 23261! ************************************************************************************************** 23262 SUBROUTINE block_10_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23263 INTEGER :: mc_max, md_max 23264 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(10*md_max), kac(10*mc_max), & 23265 pbd(9*md_max), pbc(9*mc_max), pad(10*md_max), pac(10*mc_max), prim(10*9*mc_max*md_max), & 23266 scale 23267 23268 INTEGER :: ma, mb, mc, md, p_index 23269 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23270 23271 kbd(1:9*md_max) = 0.0_dp 23272 kbc(1:9*mc_max) = 0.0_dp 23273 kad(1:10*md_max) = 0.0_dp 23274 kac(1:10*mc_max) = 0.0_dp 23275 p_index = 0 23276 DO md = 1, md_max 23277 DO mc = 1, mc_max 23278 DO mb = 1, 9 23279 ks_bd = 0.0_dp 23280 ks_bc = 0.0_dp 23281 p_bd = pbd((md - 1)*9 + mb) 23282 p_bc = pbc((mc - 1)*9 + mb) 23283 DO ma = 1, 10 23284 p_index = p_index + 1 23285 tmp = scale*prim(p_index) 23286 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23287 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23288 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23289 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23290 END DO 23291 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 23292 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 23293 END DO 23294 END DO 23295 END DO 23296 END SUBROUTINE block_10_9 23297! ************************************************************************************************** 23298!> \brief ... 23299!> \param mc_max ... 23300!> \param md_max ... 23301!> \param kbd ... 23302!> \param kbc ... 23303!> \param kad ... 23304!> \param kac ... 23305!> \param pbd ... 23306!> \param pbc ... 23307!> \param pad ... 23308!> \param pac ... 23309!> \param prim ... 23310!> \param scale ... 23311! ************************************************************************************************** 23312 SUBROUTINE block_10_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23313 INTEGER :: mc_max, md_max 23314 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(10*md_max), kac(10*mc_max), & 23315 pbd(10*md_max), pbc(10*mc_max), pad(10*md_max), pac(10*mc_max), & 23316 prim(10*10*mc_max*md_max), scale 23317 23318 INTEGER :: ma, mb, mc, md, p_index 23319 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23320 23321 kbd(1:10*md_max) = 0.0_dp 23322 kbc(1:10*mc_max) = 0.0_dp 23323 kad(1:10*md_max) = 0.0_dp 23324 kac(1:10*mc_max) = 0.0_dp 23325 p_index = 0 23326 DO md = 1, md_max 23327 DO mc = 1, mc_max 23328 DO mb = 1, 10 23329 ks_bd = 0.0_dp 23330 ks_bc = 0.0_dp 23331 p_bd = pbd((md - 1)*10 + mb) 23332 p_bc = pbc((mc - 1)*10 + mb) 23333 DO ma = 1, 10 23334 p_index = p_index + 1 23335 tmp = scale*prim(p_index) 23336 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23337 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23338 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23339 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23340 END DO 23341 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 23342 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 23343 END DO 23344 END DO 23345 END DO 23346 END SUBROUTINE block_10_10 23347! ************************************************************************************************** 23348!> \brief ... 23349!> \param mc_max ... 23350!> \param md_max ... 23351!> \param kbd ... 23352!> \param kbc ... 23353!> \param kad ... 23354!> \param kac ... 23355!> \param pbd ... 23356!> \param pbc ... 23357!> \param pad ... 23358!> \param pac ... 23359!> \param prim ... 23360!> \param scale ... 23361! ************************************************************************************************** 23362 SUBROUTINE block_10_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23363 INTEGER :: mc_max, md_max 23364 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(10*md_max), kac(10*mc_max), & 23365 pbd(11*md_max), pbc(11*mc_max), pad(10*md_max), pac(10*mc_max), & 23366 prim(10*11*mc_max*md_max), scale 23367 23368 INTEGER :: ma, mb, mc, md, p_index 23369 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23370 23371 kbd(1:11*md_max) = 0.0_dp 23372 kbc(1:11*mc_max) = 0.0_dp 23373 kad(1:10*md_max) = 0.0_dp 23374 kac(1:10*mc_max) = 0.0_dp 23375 p_index = 0 23376 DO md = 1, md_max 23377 DO mc = 1, mc_max 23378 DO mb = 1, 11 23379 ks_bd = 0.0_dp 23380 ks_bc = 0.0_dp 23381 p_bd = pbd((md - 1)*11 + mb) 23382 p_bc = pbc((mc - 1)*11 + mb) 23383 DO ma = 1, 10 23384 p_index = p_index + 1 23385 tmp = scale*prim(p_index) 23386 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23387 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23388 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23389 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23390 END DO 23391 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 23392 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 23393 END DO 23394 END DO 23395 END DO 23396 END SUBROUTINE block_10_11 23397! ************************************************************************************************** 23398!> \brief ... 23399!> \param mc_max ... 23400!> \param md_max ... 23401!> \param kbd ... 23402!> \param kbc ... 23403!> \param kad ... 23404!> \param kac ... 23405!> \param pbd ... 23406!> \param pbc ... 23407!> \param pad ... 23408!> \param pac ... 23409!> \param prim ... 23410!> \param scale ... 23411! ************************************************************************************************** 23412 SUBROUTINE block_10_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23413 INTEGER :: mc_max, md_max 23414 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(10*md_max), kac(10*mc_max), & 23415 pbd(15*md_max), pbc(15*mc_max), pad(10*md_max), pac(10*mc_max), & 23416 prim(10*15*mc_max*md_max), scale 23417 23418 INTEGER :: ma, mb, mc, md, p_index 23419 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23420 23421 kbd(1:15*md_max) = 0.0_dp 23422 kbc(1:15*mc_max) = 0.0_dp 23423 kad(1:10*md_max) = 0.0_dp 23424 kac(1:10*mc_max) = 0.0_dp 23425 p_index = 0 23426 DO md = 1, md_max 23427 DO mc = 1, mc_max 23428 DO mb = 1, 15 23429 ks_bd = 0.0_dp 23430 ks_bc = 0.0_dp 23431 p_bd = pbd((md - 1)*15 + mb) 23432 p_bc = pbc((mc - 1)*15 + mb) 23433 DO ma = 1, 10 23434 p_index = p_index + 1 23435 tmp = scale*prim(p_index) 23436 ks_bc = ks_bc + tmp*pad((md - 1)*10 + ma) 23437 ks_bd = ks_bd + tmp*pac((mc - 1)*10 + ma) 23438 kad((md - 1)*10 + ma) = kad((md - 1)*10 + ma) - tmp*p_bc 23439 kac((mc - 1)*10 + ma) = kac((mc - 1)*10 + ma) - tmp*p_bd 23440 END DO 23441 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 23442 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 23443 END DO 23444 END DO 23445 END DO 23446 END SUBROUTINE block_10_15 23447! ************************************************************************************************** 23448!> \brief ... 23449!> \param kbd ... 23450!> \param kbc ... 23451!> \param kad ... 23452!> \param kac ... 23453!> \param pbd ... 23454!> \param pbc ... 23455!> \param pad ... 23456!> \param pac ... 23457!> \param prim ... 23458!> \param scale ... 23459! ************************************************************************************************** 23460 SUBROUTINE block_11_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23461 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(11*1), & 23462 kac(11*1), pbd(1*1), pbc(1*1), & 23463 pad(11*1), pac(11*1), prim(11*1*1*1), & 23464 scale 23465 23466 INTEGER :: ma, mb, mc, md, p_index 23467 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23468 23469 kbd(1:1*1) = 0.0_dp 23470 kbc(1:1*1) = 0.0_dp 23471 kad(1:11*1) = 0.0_dp 23472 kac(1:11*1) = 0.0_dp 23473 p_index = 0 23474 DO md = 1, 1 23475 DO mc = 1, 1 23476 DO mb = 1, 1 23477 ks_bd = 0.0_dp 23478 ks_bc = 0.0_dp 23479 p_bd = pbd((md - 1)*1 + mb) 23480 p_bc = pbc((mc - 1)*1 + mb) 23481 DO ma = 1, 11 23482 p_index = p_index + 1 23483 tmp = scale*prim(p_index) 23484 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23485 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23486 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23487 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23488 END DO 23489 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 23490 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 23491 END DO 23492 END DO 23493 END DO 23494 END SUBROUTINE block_11_1_1_1 23495! ************************************************************************************************** 23496!> \brief ... 23497!> \param md_max ... 23498!> \param kbd ... 23499!> \param kbc ... 23500!> \param kad ... 23501!> \param kac ... 23502!> \param pbd ... 23503!> \param pbc ... 23504!> \param pad ... 23505!> \param pac ... 23506!> \param prim ... 23507!> \param scale ... 23508! ************************************************************************************************** 23509 SUBROUTINE block_11_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23510 INTEGER :: md_max 23511 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(11*md_max), kac(11*1), pbd(1*md_max), & 23512 pbc(1*1), pad(11*md_max), pac(11*1), prim(11*1*1*md_max), scale 23513 23514 INTEGER :: ma, mb, mc, md, p_index 23515 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23516 23517 kbd(1:1*md_max) = 0.0_dp 23518 kbc(1:1*1) = 0.0_dp 23519 kad(1:11*md_max) = 0.0_dp 23520 kac(1:11*1) = 0.0_dp 23521 p_index = 0 23522 DO md = 1, md_max 23523 DO mc = 1, 1 23524 DO mb = 1, 1 23525 ks_bd = 0.0_dp 23526 ks_bc = 0.0_dp 23527 p_bd = pbd((md - 1)*1 + mb) 23528 p_bc = pbc((mc - 1)*1 + mb) 23529 DO ma = 1, 11 23530 p_index = p_index + 1 23531 tmp = scale*prim(p_index) 23532 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23533 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23534 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23535 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23536 END DO 23537 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 23538 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 23539 END DO 23540 END DO 23541 END DO 23542 END SUBROUTINE block_11_1_1 23543! ************************************************************************************************** 23544!> \brief ... 23545!> \param mc_max ... 23546!> \param md_max ... 23547!> \param kbd ... 23548!> \param kbc ... 23549!> \param kad ... 23550!> \param kac ... 23551!> \param pbd ... 23552!> \param pbc ... 23553!> \param pad ... 23554!> \param pac ... 23555!> \param prim ... 23556!> \param scale ... 23557! ************************************************************************************************** 23558 SUBROUTINE block_11_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23559 INTEGER :: mc_max, md_max 23560 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(11*md_max), kac(11*mc_max), & 23561 pbd(1*md_max), pbc(1*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*1*mc_max*md_max), & 23562 scale 23563 23564 INTEGER :: ma, mb, mc, md, p_index 23565 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23566 23567 kbd(1:1*md_max) = 0.0_dp 23568 kbc(1:1*mc_max) = 0.0_dp 23569 kad(1:11*md_max) = 0.0_dp 23570 kac(1:11*mc_max) = 0.0_dp 23571 p_index = 0 23572 DO md = 1, md_max 23573 DO mc = 1, mc_max 23574 DO mb = 1, 1 23575 ks_bd = 0.0_dp 23576 ks_bc = 0.0_dp 23577 p_bd = pbd((md - 1)*1 + mb) 23578 p_bc = pbc((mc - 1)*1 + mb) 23579 DO ma = 1, 11 23580 p_index = p_index + 1 23581 tmp = scale*prim(p_index) 23582 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23583 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23584 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23585 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23586 END DO 23587 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 23588 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 23589 END DO 23590 END DO 23591 END DO 23592 END SUBROUTINE block_11_1 23593! ************************************************************************************************** 23594!> \brief ... 23595!> \param mc_max ... 23596!> \param md_max ... 23597!> \param kbd ... 23598!> \param kbc ... 23599!> \param kad ... 23600!> \param kac ... 23601!> \param pbd ... 23602!> \param pbc ... 23603!> \param pad ... 23604!> \param pac ... 23605!> \param prim ... 23606!> \param scale ... 23607! ************************************************************************************************** 23608 SUBROUTINE block_11_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23609 INTEGER :: mc_max, md_max 23610 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(11*md_max), kac(11*mc_max), & 23611 pbd(2*md_max), pbc(2*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*2*mc_max*md_max), & 23612 scale 23613 23614 INTEGER :: ma, mb, mc, md, p_index 23615 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23616 23617 kbd(1:2*md_max) = 0.0_dp 23618 kbc(1:2*mc_max) = 0.0_dp 23619 kad(1:11*md_max) = 0.0_dp 23620 kac(1:11*mc_max) = 0.0_dp 23621 p_index = 0 23622 DO md = 1, md_max 23623 DO mc = 1, mc_max 23624 DO mb = 1, 2 23625 ks_bd = 0.0_dp 23626 ks_bc = 0.0_dp 23627 p_bd = pbd((md - 1)*2 + mb) 23628 p_bc = pbc((mc - 1)*2 + mb) 23629 DO ma = 1, 11 23630 p_index = p_index + 1 23631 tmp = scale*prim(p_index) 23632 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23633 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23634 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23635 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23636 END DO 23637 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 23638 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 23639 END DO 23640 END DO 23641 END DO 23642 END SUBROUTINE block_11_2 23643! ************************************************************************************************** 23644!> \brief ... 23645!> \param mc_max ... 23646!> \param md_max ... 23647!> \param kbd ... 23648!> \param kbc ... 23649!> \param kad ... 23650!> \param kac ... 23651!> \param pbd ... 23652!> \param pbc ... 23653!> \param pad ... 23654!> \param pac ... 23655!> \param prim ... 23656!> \param scale ... 23657! ************************************************************************************************** 23658 SUBROUTINE block_11_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23659 INTEGER :: mc_max, md_max 23660 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(11*md_max), kac(11*mc_max), & 23661 pbd(3*md_max), pbc(3*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*3*mc_max*md_max), & 23662 scale 23663 23664 INTEGER :: ma, mb, mc, md, p_index 23665 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23666 23667 kbd(1:3*md_max) = 0.0_dp 23668 kbc(1:3*mc_max) = 0.0_dp 23669 kad(1:11*md_max) = 0.0_dp 23670 kac(1:11*mc_max) = 0.0_dp 23671 p_index = 0 23672 DO md = 1, md_max 23673 DO mc = 1, mc_max 23674 DO mb = 1, 3 23675 ks_bd = 0.0_dp 23676 ks_bc = 0.0_dp 23677 p_bd = pbd((md - 1)*3 + mb) 23678 p_bc = pbc((mc - 1)*3 + mb) 23679 DO ma = 1, 11 23680 p_index = p_index + 1 23681 tmp = scale*prim(p_index) 23682 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23683 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23684 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23685 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23686 END DO 23687 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 23688 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 23689 END DO 23690 END DO 23691 END DO 23692 END SUBROUTINE block_11_3 23693! ************************************************************************************************** 23694!> \brief ... 23695!> \param mc_max ... 23696!> \param md_max ... 23697!> \param kbd ... 23698!> \param kbc ... 23699!> \param kad ... 23700!> \param kac ... 23701!> \param pbd ... 23702!> \param pbc ... 23703!> \param pad ... 23704!> \param pac ... 23705!> \param prim ... 23706!> \param scale ... 23707! ************************************************************************************************** 23708 SUBROUTINE block_11_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23709 INTEGER :: mc_max, md_max 23710 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(11*md_max), kac(11*mc_max), & 23711 pbd(4*md_max), pbc(4*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*4*mc_max*md_max), & 23712 scale 23713 23714 INTEGER :: ma, mb, mc, md, p_index 23715 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23716 23717 kbd(1:4*md_max) = 0.0_dp 23718 kbc(1:4*mc_max) = 0.0_dp 23719 kad(1:11*md_max) = 0.0_dp 23720 kac(1:11*mc_max) = 0.0_dp 23721 p_index = 0 23722 DO md = 1, md_max 23723 DO mc = 1, mc_max 23724 DO mb = 1, 4 23725 ks_bd = 0.0_dp 23726 ks_bc = 0.0_dp 23727 p_bd = pbd((md - 1)*4 + mb) 23728 p_bc = pbc((mc - 1)*4 + mb) 23729 DO ma = 1, 11 23730 p_index = p_index + 1 23731 tmp = scale*prim(p_index) 23732 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23733 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23734 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23735 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23736 END DO 23737 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 23738 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 23739 END DO 23740 END DO 23741 END DO 23742 END SUBROUTINE block_11_4 23743! ************************************************************************************************** 23744!> \brief ... 23745!> \param mc_max ... 23746!> \param md_max ... 23747!> \param kbd ... 23748!> \param kbc ... 23749!> \param kad ... 23750!> \param kac ... 23751!> \param pbd ... 23752!> \param pbc ... 23753!> \param pad ... 23754!> \param pac ... 23755!> \param prim ... 23756!> \param scale ... 23757! ************************************************************************************************** 23758 SUBROUTINE block_11_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23759 INTEGER :: mc_max, md_max 23760 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(11*md_max), kac(11*mc_max), & 23761 pbd(5*md_max), pbc(5*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*5*mc_max*md_max), & 23762 scale 23763 23764 INTEGER :: ma, mb, mc, md, p_index 23765 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23766 23767 kbd(1:5*md_max) = 0.0_dp 23768 kbc(1:5*mc_max) = 0.0_dp 23769 kad(1:11*md_max) = 0.0_dp 23770 kac(1:11*mc_max) = 0.0_dp 23771 p_index = 0 23772 DO md = 1, md_max 23773 DO mc = 1, mc_max 23774 DO mb = 1, 5 23775 ks_bd = 0.0_dp 23776 ks_bc = 0.0_dp 23777 p_bd = pbd((md - 1)*5 + mb) 23778 p_bc = pbc((mc - 1)*5 + mb) 23779 DO ma = 1, 11 23780 p_index = p_index + 1 23781 tmp = scale*prim(p_index) 23782 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23783 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23784 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23785 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23786 END DO 23787 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 23788 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 23789 END DO 23790 END DO 23791 END DO 23792 END SUBROUTINE block_11_5 23793! ************************************************************************************************** 23794!> \brief ... 23795!> \param mc_max ... 23796!> \param md_max ... 23797!> \param kbd ... 23798!> \param kbc ... 23799!> \param kad ... 23800!> \param kac ... 23801!> \param pbd ... 23802!> \param pbc ... 23803!> \param pad ... 23804!> \param pac ... 23805!> \param prim ... 23806!> \param scale ... 23807! ************************************************************************************************** 23808 SUBROUTINE block_11_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23809 INTEGER :: mc_max, md_max 23810 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(11*md_max), kac(11*mc_max), & 23811 pbd(6*md_max), pbc(6*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*6*mc_max*md_max), & 23812 scale 23813 23814 INTEGER :: ma, mb, mc, md, p_index 23815 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23816 23817 kbd(1:6*md_max) = 0.0_dp 23818 kbc(1:6*mc_max) = 0.0_dp 23819 kad(1:11*md_max) = 0.0_dp 23820 kac(1:11*mc_max) = 0.0_dp 23821 p_index = 0 23822 DO md = 1, md_max 23823 DO mc = 1, mc_max 23824 DO mb = 1, 6 23825 ks_bd = 0.0_dp 23826 ks_bc = 0.0_dp 23827 p_bd = pbd((md - 1)*6 + mb) 23828 p_bc = pbc((mc - 1)*6 + mb) 23829 DO ma = 1, 11 23830 p_index = p_index + 1 23831 tmp = scale*prim(p_index) 23832 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23833 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23834 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23835 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23836 END DO 23837 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 23838 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 23839 END DO 23840 END DO 23841 END DO 23842 END SUBROUTINE block_11_6 23843! ************************************************************************************************** 23844!> \brief ... 23845!> \param mc_max ... 23846!> \param md_max ... 23847!> \param kbd ... 23848!> \param kbc ... 23849!> \param kad ... 23850!> \param kac ... 23851!> \param pbd ... 23852!> \param pbc ... 23853!> \param pad ... 23854!> \param pac ... 23855!> \param prim ... 23856!> \param scale ... 23857! ************************************************************************************************** 23858 SUBROUTINE block_11_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23859 INTEGER :: mc_max, md_max 23860 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(11*md_max), kac(11*mc_max), & 23861 pbd(7*md_max), pbc(7*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*7*mc_max*md_max), & 23862 scale 23863 23864 INTEGER :: ma, mb, mc, md, p_index 23865 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23866 23867 kbd(1:7*md_max) = 0.0_dp 23868 kbc(1:7*mc_max) = 0.0_dp 23869 kad(1:11*md_max) = 0.0_dp 23870 kac(1:11*mc_max) = 0.0_dp 23871 p_index = 0 23872 DO md = 1, md_max 23873 DO mc = 1, mc_max 23874 DO mb = 1, 7 23875 ks_bd = 0.0_dp 23876 ks_bc = 0.0_dp 23877 p_bd = pbd((md - 1)*7 + mb) 23878 p_bc = pbc((mc - 1)*7 + mb) 23879 DO ma = 1, 11 23880 p_index = p_index + 1 23881 tmp = scale*prim(p_index) 23882 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23883 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23884 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23885 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23886 END DO 23887 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 23888 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 23889 END DO 23890 END DO 23891 END DO 23892 END SUBROUTINE block_11_7 23893! ************************************************************************************************** 23894!> \brief ... 23895!> \param mc_max ... 23896!> \param md_max ... 23897!> \param kbd ... 23898!> \param kbc ... 23899!> \param kad ... 23900!> \param kac ... 23901!> \param pbd ... 23902!> \param pbc ... 23903!> \param pad ... 23904!> \param pac ... 23905!> \param prim ... 23906!> \param scale ... 23907! ************************************************************************************************** 23908 SUBROUTINE block_11_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23909 INTEGER :: mc_max, md_max 23910 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(11*md_max), kac(11*mc_max), & 23911 pbd(9*md_max), pbc(9*mc_max), pad(11*md_max), pac(11*mc_max), prim(11*9*mc_max*md_max), & 23912 scale 23913 23914 INTEGER :: ma, mb, mc, md, p_index 23915 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23916 23917 kbd(1:9*md_max) = 0.0_dp 23918 kbc(1:9*mc_max) = 0.0_dp 23919 kad(1:11*md_max) = 0.0_dp 23920 kac(1:11*mc_max) = 0.0_dp 23921 p_index = 0 23922 DO md = 1, md_max 23923 DO mc = 1, mc_max 23924 DO mb = 1, 9 23925 ks_bd = 0.0_dp 23926 ks_bc = 0.0_dp 23927 p_bd = pbd((md - 1)*9 + mb) 23928 p_bc = pbc((mc - 1)*9 + mb) 23929 DO ma = 1, 11 23930 p_index = p_index + 1 23931 tmp = scale*prim(p_index) 23932 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23933 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23934 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23935 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23936 END DO 23937 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 23938 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 23939 END DO 23940 END DO 23941 END DO 23942 END SUBROUTINE block_11_9 23943! ************************************************************************************************** 23944!> \brief ... 23945!> \param mc_max ... 23946!> \param md_max ... 23947!> \param kbd ... 23948!> \param kbc ... 23949!> \param kad ... 23950!> \param kac ... 23951!> \param pbd ... 23952!> \param pbc ... 23953!> \param pad ... 23954!> \param pac ... 23955!> \param prim ... 23956!> \param scale ... 23957! ************************************************************************************************** 23958 SUBROUTINE block_11_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 23959 INTEGER :: mc_max, md_max 23960 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(11*md_max), kac(11*mc_max), & 23961 pbd(10*md_max), pbc(10*mc_max), pad(11*md_max), pac(11*mc_max), & 23962 prim(11*10*mc_max*md_max), scale 23963 23964 INTEGER :: ma, mb, mc, md, p_index 23965 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 23966 23967 kbd(1:10*md_max) = 0.0_dp 23968 kbc(1:10*mc_max) = 0.0_dp 23969 kad(1:11*md_max) = 0.0_dp 23970 kac(1:11*mc_max) = 0.0_dp 23971 p_index = 0 23972 DO md = 1, md_max 23973 DO mc = 1, mc_max 23974 DO mb = 1, 10 23975 ks_bd = 0.0_dp 23976 ks_bc = 0.0_dp 23977 p_bd = pbd((md - 1)*10 + mb) 23978 p_bc = pbc((mc - 1)*10 + mb) 23979 DO ma = 1, 11 23980 p_index = p_index + 1 23981 tmp = scale*prim(p_index) 23982 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 23983 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 23984 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 23985 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 23986 END DO 23987 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 23988 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 23989 END DO 23990 END DO 23991 END DO 23992 END SUBROUTINE block_11_10 23993! ************************************************************************************************** 23994!> \brief ... 23995!> \param mc_max ... 23996!> \param md_max ... 23997!> \param kbd ... 23998!> \param kbc ... 23999!> \param kad ... 24000!> \param kac ... 24001!> \param pbd ... 24002!> \param pbc ... 24003!> \param pad ... 24004!> \param pac ... 24005!> \param prim ... 24006!> \param scale ... 24007! ************************************************************************************************** 24008 SUBROUTINE block_11_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24009 INTEGER :: mc_max, md_max 24010 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(11*md_max), kac(11*mc_max), & 24011 pbd(11*md_max), pbc(11*mc_max), pad(11*md_max), pac(11*mc_max), & 24012 prim(11*11*mc_max*md_max), scale 24013 24014 INTEGER :: ma, mb, mc, md, p_index 24015 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24016 24017 kbd(1:11*md_max) = 0.0_dp 24018 kbc(1:11*mc_max) = 0.0_dp 24019 kad(1:11*md_max) = 0.0_dp 24020 kac(1:11*mc_max) = 0.0_dp 24021 p_index = 0 24022 DO md = 1, md_max 24023 DO mc = 1, mc_max 24024 DO mb = 1, 11 24025 ks_bd = 0.0_dp 24026 ks_bc = 0.0_dp 24027 p_bd = pbd((md - 1)*11 + mb) 24028 p_bc = pbc((mc - 1)*11 + mb) 24029 DO ma = 1, 11 24030 p_index = p_index + 1 24031 tmp = scale*prim(p_index) 24032 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 24033 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 24034 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 24035 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 24036 END DO 24037 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 24038 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 24039 END DO 24040 END DO 24041 END DO 24042 END SUBROUTINE block_11_11 24043! ************************************************************************************************** 24044!> \brief ... 24045!> \param mc_max ... 24046!> \param md_max ... 24047!> \param kbd ... 24048!> \param kbc ... 24049!> \param kad ... 24050!> \param kac ... 24051!> \param pbd ... 24052!> \param pbc ... 24053!> \param pad ... 24054!> \param pac ... 24055!> \param prim ... 24056!> \param scale ... 24057! ************************************************************************************************** 24058 SUBROUTINE block_11_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24059 INTEGER :: mc_max, md_max 24060 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(11*md_max), kac(11*mc_max), & 24061 pbd(15*md_max), pbc(15*mc_max), pad(11*md_max), pac(11*mc_max), & 24062 prim(11*15*mc_max*md_max), scale 24063 24064 INTEGER :: ma, mb, mc, md, p_index 24065 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24066 24067 kbd(1:15*md_max) = 0.0_dp 24068 kbc(1:15*mc_max) = 0.0_dp 24069 kad(1:11*md_max) = 0.0_dp 24070 kac(1:11*mc_max) = 0.0_dp 24071 p_index = 0 24072 DO md = 1, md_max 24073 DO mc = 1, mc_max 24074 DO mb = 1, 15 24075 ks_bd = 0.0_dp 24076 ks_bc = 0.0_dp 24077 p_bd = pbd((md - 1)*15 + mb) 24078 p_bc = pbc((mc - 1)*15 + mb) 24079 DO ma = 1, 11 24080 p_index = p_index + 1 24081 tmp = scale*prim(p_index) 24082 ks_bc = ks_bc + tmp*pad((md - 1)*11 + ma) 24083 ks_bd = ks_bd + tmp*pac((mc - 1)*11 + ma) 24084 kad((md - 1)*11 + ma) = kad((md - 1)*11 + ma) - tmp*p_bc 24085 kac((mc - 1)*11 + ma) = kac((mc - 1)*11 + ma) - tmp*p_bd 24086 END DO 24087 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 24088 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 24089 END DO 24090 END DO 24091 END DO 24092 END SUBROUTINE block_11_15 24093! ************************************************************************************************** 24094!> \brief ... 24095!> \param kbd ... 24096!> \param kbc ... 24097!> \param kad ... 24098!> \param kac ... 24099!> \param pbd ... 24100!> \param pbc ... 24101!> \param pad ... 24102!> \param pac ... 24103!> \param prim ... 24104!> \param scale ... 24105! ************************************************************************************************** 24106 SUBROUTINE block_15_1_1_1(kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24107 REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(15*1), & 24108 kac(15*1), pbd(1*1), pbc(1*1), & 24109 pad(15*1), pac(15*1), prim(15*1*1*1), & 24110 scale 24111 24112 INTEGER :: ma, mb, mc, md, p_index 24113 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24114 24115 kbd(1:1*1) = 0.0_dp 24116 kbc(1:1*1) = 0.0_dp 24117 kad(1:15*1) = 0.0_dp 24118 kac(1:15*1) = 0.0_dp 24119 p_index = 0 24120 DO md = 1, 1 24121 DO mc = 1, 1 24122 DO mb = 1, 1 24123 ks_bd = 0.0_dp 24124 ks_bc = 0.0_dp 24125 p_bd = pbd((md - 1)*1 + mb) 24126 p_bc = pbc((mc - 1)*1 + mb) 24127 DO ma = 1, 15 24128 p_index = p_index + 1 24129 tmp = scale*prim(p_index) 24130 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24131 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24132 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24133 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24134 END DO 24135 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 24136 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 24137 END DO 24138 END DO 24139 END DO 24140 END SUBROUTINE block_15_1_1_1 24141! ************************************************************************************************** 24142!> \brief ... 24143!> \param md_max ... 24144!> \param kbd ... 24145!> \param kbc ... 24146!> \param kad ... 24147!> \param kac ... 24148!> \param pbd ... 24149!> \param pbc ... 24150!> \param pad ... 24151!> \param pac ... 24152!> \param prim ... 24153!> \param scale ... 24154! ************************************************************************************************** 24155 SUBROUTINE block_15_1_1(md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24156 INTEGER :: md_max 24157 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(15*md_max), kac(15*1), pbd(1*md_max), & 24158 pbc(1*1), pad(15*md_max), pac(15*1), prim(15*1*1*md_max), scale 24159 24160 INTEGER :: ma, mb, mc, md, p_index 24161 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24162 24163 kbd(1:1*md_max) = 0.0_dp 24164 kbc(1:1*1) = 0.0_dp 24165 kad(1:15*md_max) = 0.0_dp 24166 kac(1:15*1) = 0.0_dp 24167 p_index = 0 24168 DO md = 1, md_max 24169 DO mc = 1, 1 24170 DO mb = 1, 1 24171 ks_bd = 0.0_dp 24172 ks_bc = 0.0_dp 24173 p_bd = pbd((md - 1)*1 + mb) 24174 p_bc = pbc((mc - 1)*1 + mb) 24175 DO ma = 1, 15 24176 p_index = p_index + 1 24177 tmp = scale*prim(p_index) 24178 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24179 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24180 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24181 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24182 END DO 24183 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 24184 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 24185 END DO 24186 END DO 24187 END DO 24188 END SUBROUTINE block_15_1_1 24189! ************************************************************************************************** 24190!> \brief ... 24191!> \param mc_max ... 24192!> \param md_max ... 24193!> \param kbd ... 24194!> \param kbc ... 24195!> \param kad ... 24196!> \param kac ... 24197!> \param pbd ... 24198!> \param pbc ... 24199!> \param pad ... 24200!> \param pac ... 24201!> \param prim ... 24202!> \param scale ... 24203! ************************************************************************************************** 24204 SUBROUTINE block_15_1(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24205 INTEGER :: mc_max, md_max 24206 REAL(KIND=dp) :: kbd(1*md_max), kbc(1*mc_max), kad(15*md_max), kac(15*mc_max), & 24207 pbd(1*md_max), pbc(1*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*1*mc_max*md_max), & 24208 scale 24209 24210 INTEGER :: ma, mb, mc, md, p_index 24211 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24212 24213 kbd(1:1*md_max) = 0.0_dp 24214 kbc(1:1*mc_max) = 0.0_dp 24215 kad(1:15*md_max) = 0.0_dp 24216 kac(1:15*mc_max) = 0.0_dp 24217 p_index = 0 24218 DO md = 1, md_max 24219 DO mc = 1, mc_max 24220 DO mb = 1, 1 24221 ks_bd = 0.0_dp 24222 ks_bc = 0.0_dp 24223 p_bd = pbd((md - 1)*1 + mb) 24224 p_bc = pbc((mc - 1)*1 + mb) 24225 DO ma = 1, 15 24226 p_index = p_index + 1 24227 tmp = scale*prim(p_index) 24228 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24229 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24230 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24231 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24232 END DO 24233 kbd((md - 1)*1 + mb) = kbd((md - 1)*1 + mb) - ks_bd 24234 kbc((mc - 1)*1 + mb) = kbc((mc - 1)*1 + mb) - ks_bc 24235 END DO 24236 END DO 24237 END DO 24238 END SUBROUTINE block_15_1 24239! ************************************************************************************************** 24240!> \brief ... 24241!> \param mc_max ... 24242!> \param md_max ... 24243!> \param kbd ... 24244!> \param kbc ... 24245!> \param kad ... 24246!> \param kac ... 24247!> \param pbd ... 24248!> \param pbc ... 24249!> \param pad ... 24250!> \param pac ... 24251!> \param prim ... 24252!> \param scale ... 24253! ************************************************************************************************** 24254 SUBROUTINE block_15_2(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24255 INTEGER :: mc_max, md_max 24256 REAL(KIND=dp) :: kbd(2*md_max), kbc(2*mc_max), kad(15*md_max), kac(15*mc_max), & 24257 pbd(2*md_max), pbc(2*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*2*mc_max*md_max), & 24258 scale 24259 24260 INTEGER :: ma, mb, mc, md, p_index 24261 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24262 24263 kbd(1:2*md_max) = 0.0_dp 24264 kbc(1:2*mc_max) = 0.0_dp 24265 kad(1:15*md_max) = 0.0_dp 24266 kac(1:15*mc_max) = 0.0_dp 24267 p_index = 0 24268 DO md = 1, md_max 24269 DO mc = 1, mc_max 24270 DO mb = 1, 2 24271 ks_bd = 0.0_dp 24272 ks_bc = 0.0_dp 24273 p_bd = pbd((md - 1)*2 + mb) 24274 p_bc = pbc((mc - 1)*2 + mb) 24275 DO ma = 1, 15 24276 p_index = p_index + 1 24277 tmp = scale*prim(p_index) 24278 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24279 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24280 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24281 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24282 END DO 24283 kbd((md - 1)*2 + mb) = kbd((md - 1)*2 + mb) - ks_bd 24284 kbc((mc - 1)*2 + mb) = kbc((mc - 1)*2 + mb) - ks_bc 24285 END DO 24286 END DO 24287 END DO 24288 END SUBROUTINE block_15_2 24289! ************************************************************************************************** 24290!> \brief ... 24291!> \param mc_max ... 24292!> \param md_max ... 24293!> \param kbd ... 24294!> \param kbc ... 24295!> \param kad ... 24296!> \param kac ... 24297!> \param pbd ... 24298!> \param pbc ... 24299!> \param pad ... 24300!> \param pac ... 24301!> \param prim ... 24302!> \param scale ... 24303! ************************************************************************************************** 24304 SUBROUTINE block_15_3(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24305 INTEGER :: mc_max, md_max 24306 REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(15*md_max), kac(15*mc_max), & 24307 pbd(3*md_max), pbc(3*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*3*mc_max*md_max), & 24308 scale 24309 24310 INTEGER :: ma, mb, mc, md, p_index 24311 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24312 24313 kbd(1:3*md_max) = 0.0_dp 24314 kbc(1:3*mc_max) = 0.0_dp 24315 kad(1:15*md_max) = 0.0_dp 24316 kac(1:15*mc_max) = 0.0_dp 24317 p_index = 0 24318 DO md = 1, md_max 24319 DO mc = 1, mc_max 24320 DO mb = 1, 3 24321 ks_bd = 0.0_dp 24322 ks_bc = 0.0_dp 24323 p_bd = pbd((md - 1)*3 + mb) 24324 p_bc = pbc((mc - 1)*3 + mb) 24325 DO ma = 1, 15 24326 p_index = p_index + 1 24327 tmp = scale*prim(p_index) 24328 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24329 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24330 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24331 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24332 END DO 24333 kbd((md - 1)*3 + mb) = kbd((md - 1)*3 + mb) - ks_bd 24334 kbc((mc - 1)*3 + mb) = kbc((mc - 1)*3 + mb) - ks_bc 24335 END DO 24336 END DO 24337 END DO 24338 END SUBROUTINE block_15_3 24339! ************************************************************************************************** 24340!> \brief ... 24341!> \param mc_max ... 24342!> \param md_max ... 24343!> \param kbd ... 24344!> \param kbc ... 24345!> \param kad ... 24346!> \param kac ... 24347!> \param pbd ... 24348!> \param pbc ... 24349!> \param pad ... 24350!> \param pac ... 24351!> \param prim ... 24352!> \param scale ... 24353! ************************************************************************************************** 24354 SUBROUTINE block_15_4(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24355 INTEGER :: mc_max, md_max 24356 REAL(KIND=dp) :: kbd(4*md_max), kbc(4*mc_max), kad(15*md_max), kac(15*mc_max), & 24357 pbd(4*md_max), pbc(4*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*4*mc_max*md_max), & 24358 scale 24359 24360 INTEGER :: ma, mb, mc, md, p_index 24361 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24362 24363 kbd(1:4*md_max) = 0.0_dp 24364 kbc(1:4*mc_max) = 0.0_dp 24365 kad(1:15*md_max) = 0.0_dp 24366 kac(1:15*mc_max) = 0.0_dp 24367 p_index = 0 24368 DO md = 1, md_max 24369 DO mc = 1, mc_max 24370 DO mb = 1, 4 24371 ks_bd = 0.0_dp 24372 ks_bc = 0.0_dp 24373 p_bd = pbd((md - 1)*4 + mb) 24374 p_bc = pbc((mc - 1)*4 + mb) 24375 DO ma = 1, 15 24376 p_index = p_index + 1 24377 tmp = scale*prim(p_index) 24378 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24379 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24380 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24381 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24382 END DO 24383 kbd((md - 1)*4 + mb) = kbd((md - 1)*4 + mb) - ks_bd 24384 kbc((mc - 1)*4 + mb) = kbc((mc - 1)*4 + mb) - ks_bc 24385 END DO 24386 END DO 24387 END DO 24388 END SUBROUTINE block_15_4 24389! ************************************************************************************************** 24390!> \brief ... 24391!> \param mc_max ... 24392!> \param md_max ... 24393!> \param kbd ... 24394!> \param kbc ... 24395!> \param kad ... 24396!> \param kac ... 24397!> \param pbd ... 24398!> \param pbc ... 24399!> \param pad ... 24400!> \param pac ... 24401!> \param prim ... 24402!> \param scale ... 24403! ************************************************************************************************** 24404 SUBROUTINE block_15_5(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24405 INTEGER :: mc_max, md_max 24406 REAL(KIND=dp) :: kbd(5*md_max), kbc(5*mc_max), kad(15*md_max), kac(15*mc_max), & 24407 pbd(5*md_max), pbc(5*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*5*mc_max*md_max), & 24408 scale 24409 24410 INTEGER :: ma, mb, mc, md, p_index 24411 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24412 24413 kbd(1:5*md_max) = 0.0_dp 24414 kbc(1:5*mc_max) = 0.0_dp 24415 kad(1:15*md_max) = 0.0_dp 24416 kac(1:15*mc_max) = 0.0_dp 24417 p_index = 0 24418 DO md = 1, md_max 24419 DO mc = 1, mc_max 24420 DO mb = 1, 5 24421 ks_bd = 0.0_dp 24422 ks_bc = 0.0_dp 24423 p_bd = pbd((md - 1)*5 + mb) 24424 p_bc = pbc((mc - 1)*5 + mb) 24425 DO ma = 1, 15 24426 p_index = p_index + 1 24427 tmp = scale*prim(p_index) 24428 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24429 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24430 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24431 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24432 END DO 24433 kbd((md - 1)*5 + mb) = kbd((md - 1)*5 + mb) - ks_bd 24434 kbc((mc - 1)*5 + mb) = kbc((mc - 1)*5 + mb) - ks_bc 24435 END DO 24436 END DO 24437 END DO 24438 END SUBROUTINE block_15_5 24439! ************************************************************************************************** 24440!> \brief ... 24441!> \param mc_max ... 24442!> \param md_max ... 24443!> \param kbd ... 24444!> \param kbc ... 24445!> \param kad ... 24446!> \param kac ... 24447!> \param pbd ... 24448!> \param pbc ... 24449!> \param pad ... 24450!> \param pac ... 24451!> \param prim ... 24452!> \param scale ... 24453! ************************************************************************************************** 24454 SUBROUTINE block_15_6(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24455 INTEGER :: mc_max, md_max 24456 REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(15*md_max), kac(15*mc_max), & 24457 pbd(6*md_max), pbc(6*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*6*mc_max*md_max), & 24458 scale 24459 24460 INTEGER :: ma, mb, mc, md, p_index 24461 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24462 24463 kbd(1:6*md_max) = 0.0_dp 24464 kbc(1:6*mc_max) = 0.0_dp 24465 kad(1:15*md_max) = 0.0_dp 24466 kac(1:15*mc_max) = 0.0_dp 24467 p_index = 0 24468 DO md = 1, md_max 24469 DO mc = 1, mc_max 24470 DO mb = 1, 6 24471 ks_bd = 0.0_dp 24472 ks_bc = 0.0_dp 24473 p_bd = pbd((md - 1)*6 + mb) 24474 p_bc = pbc((mc - 1)*6 + mb) 24475 DO ma = 1, 15 24476 p_index = p_index + 1 24477 tmp = scale*prim(p_index) 24478 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24479 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24480 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24481 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24482 END DO 24483 kbd((md - 1)*6 + mb) = kbd((md - 1)*6 + mb) - ks_bd 24484 kbc((mc - 1)*6 + mb) = kbc((mc - 1)*6 + mb) - ks_bc 24485 END DO 24486 END DO 24487 END DO 24488 END SUBROUTINE block_15_6 24489! ************************************************************************************************** 24490!> \brief ... 24491!> \param mc_max ... 24492!> \param md_max ... 24493!> \param kbd ... 24494!> \param kbc ... 24495!> \param kad ... 24496!> \param kac ... 24497!> \param pbd ... 24498!> \param pbc ... 24499!> \param pad ... 24500!> \param pac ... 24501!> \param prim ... 24502!> \param scale ... 24503! ************************************************************************************************** 24504 SUBROUTINE block_15_7(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24505 INTEGER :: mc_max, md_max 24506 REAL(KIND=dp) :: kbd(7*md_max), kbc(7*mc_max), kad(15*md_max), kac(15*mc_max), & 24507 pbd(7*md_max), pbc(7*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*7*mc_max*md_max), & 24508 scale 24509 24510 INTEGER :: ma, mb, mc, md, p_index 24511 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24512 24513 kbd(1:7*md_max) = 0.0_dp 24514 kbc(1:7*mc_max) = 0.0_dp 24515 kad(1:15*md_max) = 0.0_dp 24516 kac(1:15*mc_max) = 0.0_dp 24517 p_index = 0 24518 DO md = 1, md_max 24519 DO mc = 1, mc_max 24520 DO mb = 1, 7 24521 ks_bd = 0.0_dp 24522 ks_bc = 0.0_dp 24523 p_bd = pbd((md - 1)*7 + mb) 24524 p_bc = pbc((mc - 1)*7 + mb) 24525 DO ma = 1, 15 24526 p_index = p_index + 1 24527 tmp = scale*prim(p_index) 24528 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24529 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24530 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24531 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24532 END DO 24533 kbd((md - 1)*7 + mb) = kbd((md - 1)*7 + mb) - ks_bd 24534 kbc((mc - 1)*7 + mb) = kbc((mc - 1)*7 + mb) - ks_bc 24535 END DO 24536 END DO 24537 END DO 24538 END SUBROUTINE block_15_7 24539! ************************************************************************************************** 24540!> \brief ... 24541!> \param mc_max ... 24542!> \param md_max ... 24543!> \param kbd ... 24544!> \param kbc ... 24545!> \param kad ... 24546!> \param kac ... 24547!> \param pbd ... 24548!> \param pbc ... 24549!> \param pad ... 24550!> \param pac ... 24551!> \param prim ... 24552!> \param scale ... 24553! ************************************************************************************************** 24554 SUBROUTINE block_15_9(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24555 INTEGER :: mc_max, md_max 24556 REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(15*md_max), kac(15*mc_max), & 24557 pbd(9*md_max), pbc(9*mc_max), pad(15*md_max), pac(15*mc_max), prim(15*9*mc_max*md_max), & 24558 scale 24559 24560 INTEGER :: ma, mb, mc, md, p_index 24561 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24562 24563 kbd(1:9*md_max) = 0.0_dp 24564 kbc(1:9*mc_max) = 0.0_dp 24565 kad(1:15*md_max) = 0.0_dp 24566 kac(1:15*mc_max) = 0.0_dp 24567 p_index = 0 24568 DO md = 1, md_max 24569 DO mc = 1, mc_max 24570 DO mb = 1, 9 24571 ks_bd = 0.0_dp 24572 ks_bc = 0.0_dp 24573 p_bd = pbd((md - 1)*9 + mb) 24574 p_bc = pbc((mc - 1)*9 + mb) 24575 DO ma = 1, 15 24576 p_index = p_index + 1 24577 tmp = scale*prim(p_index) 24578 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24579 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24580 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24581 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24582 END DO 24583 kbd((md - 1)*9 + mb) = kbd((md - 1)*9 + mb) - ks_bd 24584 kbc((mc - 1)*9 + mb) = kbc((mc - 1)*9 + mb) - ks_bc 24585 END DO 24586 END DO 24587 END DO 24588 END SUBROUTINE block_15_9 24589! ************************************************************************************************** 24590!> \brief ... 24591!> \param mc_max ... 24592!> \param md_max ... 24593!> \param kbd ... 24594!> \param kbc ... 24595!> \param kad ... 24596!> \param kac ... 24597!> \param pbd ... 24598!> \param pbc ... 24599!> \param pad ... 24600!> \param pac ... 24601!> \param prim ... 24602!> \param scale ... 24603! ************************************************************************************************** 24604 SUBROUTINE block_15_10(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24605 INTEGER :: mc_max, md_max 24606 REAL(KIND=dp) :: kbd(10*md_max), kbc(10*mc_max), kad(15*md_max), kac(15*mc_max), & 24607 pbd(10*md_max), pbc(10*mc_max), pad(15*md_max), pac(15*mc_max), & 24608 prim(15*10*mc_max*md_max), scale 24609 24610 INTEGER :: ma, mb, mc, md, p_index 24611 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24612 24613 kbd(1:10*md_max) = 0.0_dp 24614 kbc(1:10*mc_max) = 0.0_dp 24615 kad(1:15*md_max) = 0.0_dp 24616 kac(1:15*mc_max) = 0.0_dp 24617 p_index = 0 24618 DO md = 1, md_max 24619 DO mc = 1, mc_max 24620 DO mb = 1, 10 24621 ks_bd = 0.0_dp 24622 ks_bc = 0.0_dp 24623 p_bd = pbd((md - 1)*10 + mb) 24624 p_bc = pbc((mc - 1)*10 + mb) 24625 DO ma = 1, 15 24626 p_index = p_index + 1 24627 tmp = scale*prim(p_index) 24628 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24629 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24630 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24631 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24632 END DO 24633 kbd((md - 1)*10 + mb) = kbd((md - 1)*10 + mb) - ks_bd 24634 kbc((mc - 1)*10 + mb) = kbc((mc - 1)*10 + mb) - ks_bc 24635 END DO 24636 END DO 24637 END DO 24638 END SUBROUTINE block_15_10 24639! ************************************************************************************************** 24640!> \brief ... 24641!> \param mc_max ... 24642!> \param md_max ... 24643!> \param kbd ... 24644!> \param kbc ... 24645!> \param kad ... 24646!> \param kac ... 24647!> \param pbd ... 24648!> \param pbc ... 24649!> \param pad ... 24650!> \param pac ... 24651!> \param prim ... 24652!> \param scale ... 24653! ************************************************************************************************** 24654 SUBROUTINE block_15_11(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24655 INTEGER :: mc_max, md_max 24656 REAL(KIND=dp) :: kbd(11*md_max), kbc(11*mc_max), kad(15*md_max), kac(15*mc_max), & 24657 pbd(11*md_max), pbc(11*mc_max), pad(15*md_max), pac(15*mc_max), & 24658 prim(15*11*mc_max*md_max), scale 24659 24660 INTEGER :: ma, mb, mc, md, p_index 24661 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24662 24663 kbd(1:11*md_max) = 0.0_dp 24664 kbc(1:11*mc_max) = 0.0_dp 24665 kad(1:15*md_max) = 0.0_dp 24666 kac(1:15*mc_max) = 0.0_dp 24667 p_index = 0 24668 DO md = 1, md_max 24669 DO mc = 1, mc_max 24670 DO mb = 1, 11 24671 ks_bd = 0.0_dp 24672 ks_bc = 0.0_dp 24673 p_bd = pbd((md - 1)*11 + mb) 24674 p_bc = pbc((mc - 1)*11 + mb) 24675 DO ma = 1, 15 24676 p_index = p_index + 1 24677 tmp = scale*prim(p_index) 24678 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24679 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24680 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24681 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24682 END DO 24683 kbd((md - 1)*11 + mb) = kbd((md - 1)*11 + mb) - ks_bd 24684 kbc((mc - 1)*11 + mb) = kbc((mc - 1)*11 + mb) - ks_bc 24685 END DO 24686 END DO 24687 END DO 24688 END SUBROUTINE block_15_11 24689! ************************************************************************************************** 24690!> \brief ... 24691!> \param mc_max ... 24692!> \param md_max ... 24693!> \param kbd ... 24694!> \param kbc ... 24695!> \param kad ... 24696!> \param kac ... 24697!> \param pbd ... 24698!> \param pbc ... 24699!> \param pad ... 24700!> \param pac ... 24701!> \param prim ... 24702!> \param scale ... 24703! ************************************************************************************************** 24704 SUBROUTINE block_15_15(mc_max, md_max, kbd, kbc, kad, kac, pbd, pbc, pad, pac, prim, scale) 24705 INTEGER :: mc_max, md_max 24706 REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(15*md_max), kac(15*mc_max), & 24707 pbd(15*md_max), pbc(15*mc_max), pad(15*md_max), pac(15*mc_max), & 24708 prim(15*15*mc_max*md_max), scale 24709 24710 INTEGER :: ma, mb, mc, md, p_index 24711 REAL(KIND=dp) :: ks_bc, ks_bd, p_bc, p_bd, tmp 24712 24713 kbd(1:15*md_max) = 0.0_dp 24714 kbc(1:15*mc_max) = 0.0_dp 24715 kad(1:15*md_max) = 0.0_dp 24716 kac(1:15*mc_max) = 0.0_dp 24717 p_index = 0 24718 DO md = 1, md_max 24719 DO mc = 1, mc_max 24720 DO mb = 1, 15 24721 ks_bd = 0.0_dp 24722 ks_bc = 0.0_dp 24723 p_bd = pbd((md - 1)*15 + mb) 24724 p_bc = pbc((mc - 1)*15 + mb) 24725 DO ma = 1, 15 24726 p_index = p_index + 1 24727 tmp = scale*prim(p_index) 24728 ks_bc = ks_bc + tmp*pad((md - 1)*15 + ma) 24729 ks_bd = ks_bd + tmp*pac((mc - 1)*15 + ma) 24730 kad((md - 1)*15 + ma) = kad((md - 1)*15 + ma) - tmp*p_bc 24731 kac((mc - 1)*15 + ma) = kac((mc - 1)*15 + ma) - tmp*p_bd 24732 END DO 24733 kbd((md - 1)*15 + mb) = kbd((md - 1)*15 + mb) - ks_bd 24734 kbc((mc - 1)*15 + mb) = kbc((mc - 1)*15 + mb) - ks_bc 24735 END DO 24736 END DO 24737 END DO 24738 END SUBROUTINE block_15_15 24739#endif 24740END MODULE hfx_contract_block 24741