1 subroutine local (global, rlocal, ientmp, n, code) 2c 3c---------------------------------------------------------------------- 4c 5c This subroutine performs a vector gather/scatter operation. 6c 7c input: 8c global (nshg,n) : global array 9c rlocal (npro,nshl,n) : local array 10c ien (npro,nshl) : nodal connectivity 11c n : number of d.o.f.'s to be copied 12c code : the transfer code 13c .eq. 'gather ', from global to local 14c .eq. 'scatter ', add local to global 15c .eq. 'globaliz', from local to global 16c 17c 18c Zdenek Johan, Winter 1992. 19c---------------------------------------------------------------------- 20c 21 include "common.h" 22 23 dimension global(nshg,n), rlocal(npro,nshl,n), 24 & ien(npro,nshl), ientmp(npro,nshl) 25c 26 character*8 code 27 28c 29c.... cubic basis has negatives in ien 30c 31 if (ipord > 2) then 32 ien = abs(ientmp) 33 else 34 ien = ientmp 35 endif 36c 37c.... ------------------------> 'localization ' <-------------------- 38c 39 if (code .eq. 'gather ') then 40c 41c.... gather the data 42c 43 44 do j = 1, n 45 do i = 1, nshl 46 rlocal(:,i,j) = global(ien(:,i),j) 47 enddo 48 enddo 49 50 51c 52c.... transfer count 53c 54 gbytes = gbytes + n*nshl*npro 55c 56c.... return 57c 58 return 59 endif 60c 61c.... -------------------------> 'assembling ' <---------------------- 62c 63 if (code .eq. 'scatter ') then 64c 65c.... scatter the data (possible collisions) 66c 67 do j = 1, n 68 do i = 1, nshl 69 do nel = 1,npro 70 global(ien(nel,i),j) = global(ien(nel,i),j) 71 & + rlocal(nel,i,j) 72 enddo 73 enddo 74 enddo 75 76c 77c.... transfer and flop counts 78c 79 sbytes = sbytes + n*nshl*npro 80 flops = flops + n*nshl*npro 81c 82c.... return 83c 84 return 85 endif 86c 87c.... -------------------------> 'globalizing ' <---------------------- 88c 89 if (code .eq. 'globaliz') then 90c 91c.... scatter the data (possible collisions) 92c 93 do j = 1, n 94 do i = 1, nshl 95 do nel = 1,npro 96 global(ien(nel,i),j) = rlocal(nel,i,j) 97 enddo 98 enddo 99 enddo 100c 101c.... return 102c 103 return 104 endif 105c 106c.... ---------------------------> error <--------------------------- 107c 108 call error ('local ', code, 0) 109c 110c.... end 111c 112 end 113c 114 subroutine localx (global, rlocal, ien, n, code) 115c 116c---------------------------------------------------------------------- 117c 118c This subroutine performs a vector gather/scatter operation for the 119c nodal coordinates array. 120c 121c input: 122c global (numnp,n) : global array 123c rlocal (npro,nenl,n) : local array 124c ien (npro,nshl) : nodal connectivity 125c n : number of d.o.f.'s to be copied 126c code : the transfer code 127c .eq. 'gather ', from global to local 128c .eq. 'scatter ', add local to global 129c 130c 131c Zdenek Johan, Winter 1992. 132c---------------------------------------------------------------------- 133c 134 include "common.h" 135 136 dimension global(numnp,n), rlocal(npro,nenl,n), 137 & ien(npro,nshl) 138c 139 character*8 code 140c 141c.... ------------------------> 'localization ' <-------------------- 142c 143 if (code .eq. 'gather ') then 144c 145c.... gather the data 146c 147 do j = 1, n 148 do i = 1, nenl 149 rlocal(:,i,j) = global(ien(:,i),j) 150 enddo 151 enddo 152 153 154c 155c.... transfer count 156c 157 gbytes = gbytes + n*nenl*npro 158c 159c.... return 160c 161 return 162 endif 163c 164c.... -------------------------> 'assembling ' <---------------------- 165c 166 if (code .eq. 'scatter ') then 167c 168c.... scatter the data (possible collisions) 169c 170 171 do j = 1, n 172 do i = 1, nenl 173 do nel = 1,npro 174 global(ien(nel,i),j) = global(ien(nel,i),j) 175 & + rlocal(nel,i,j) 176 enddo 177 enddo 178 enddo 179 180 181c 182c.... transfer and flop counts 183c 184 sbytes = sbytes + n*nenl*npro 185 flops = flops + n*nenl*npro 186c 187c.... return 188c 189 return 190 endif 191c 192c.... ---------------------------> error <--------------------------- 193c 194 call error ('local ', code, 0) 195c 196c.... end 197c 198 end 199c 200 201c subroutine localM (global, xKebe, xGoC, ien) 202cc 203cc---------------------------------------------------------------------- 204cc This routine assembles a global tangent matrix from the element 205cc matrices. 206cc 207cc 208cc 209cc 210cc 211cc | C G^T | 212cc globalK = | | 213cc | G K | 214cc 215cc 216cc 217cc 218cc Chris Whiting, Winter '98 219cc---------------------------------------------------------------------- 220cc 221c include "common.h" 222c 223c dimension global(nshg*4,nshg*4),xKebe(npro,3*nshl,3*nshl), 224c & xGoC(npro,4*nshl,nshl), 225c & ien(npro,nshape) 226cc 227c character*8 code 228cc 229cc.... -------------------------> 'assembling ' <---------------------- 230cc 231c 232cc 233cc.... scatter the data (possible collisions) 234cc 235c 236cc 237cc.... k 238cc 239c do iel = 1, numel 240c 241c do i = 1, nshl 242c i0 = (i-1)*3 243cc 244c do j = 1, nshl 245c j0 = (j-1)*3 246cc 247c ia = (ien(iel,i)-1)*4 + 1 248c ib = (ien(iel,j)-1)*4 + 1 249cc 250c global(ia+1,ib+1) = global(ia+1,ib+1) 251c & + xKebe(iel,i0+1,j0+1) 252c global(ia+1,ib+2) = global(ia+1,ib+2) 253c & + xKebe(iel,i0+1,j0+2) 254c global(ia+1,ib+3) = global(ia+1,ib+3) 255c & + xKebe(iel,i0+1,j0+3) 256c global(ia+2,ib+1) = global(ia+2,ib+1) 257c & + xKebe(iel,i0+2,j0+1) 258c global(ia+2,ib+2) = global(ia+2,ib+2) 259c & + xKebe(iel,i0+2,j0+2) 260c global(ia+2,ib+3) = global(ia+2,ib+3) 261c & + xKebe(iel,i0+2,j0+3) 262c global(ia+3,ib+1) = global(ia+3,ib+1) 263c & + xKebe(iel,i0+3,j0+1) 264c global(ia+3,ib+2) = global(ia+3,ib+2) 265c & + xKebe(iel,i0+3,j0+2) 266c global(ia+3,ib+3) = global(ia+3,ib+3) 267c & + xKebe(iel,i0+3,j0+3) 268cc 269c enddo 270cc 271c enddo 272cc 273c enddo 274c 275cc 276cc.... G and G^T 277cc 278c do iel = 1, numel 279c 280c do i = 1, nshl 281c i0 = (i-1)*3 282c do j = 1, nshl 283c 284c ia = (ien(iel,i)-1)*4 + 1 285c ib = (ien(iel,j)-1)*4 + 1 286cc 287c global(ia+1,ib ) = global(ia+1,ib )+ xGoC(iel,i0+1,j) 288c global(ia+2,ib ) = global(ia+2,ib )+ xGoC(iel,i0+2,j) 289c global(ia+3,ib ) = global(ia+3,ib )+ xGoC(iel,i0+3,j) 290c global(ia ,ib+1) = global(ia ,ib+1)+ xGoC(iel,i0+1,j) 291c global(ia ,ib+2) = global(ia ,ib+2)+ xGoC(iel,i0+2,j) 292c global(ia ,ib+3) = global(ia ,ib+3)+ xGoC(iel,i0+3,j) 293c 294cc 295c enddo 296cc 297c enddo 298c enddo 299c 300cc 301cc.... C 302cc 303c do iel = 1, numel 304c do i = 1, nshl 305c i0 = 3*nshl + i 306c do j = 1, nshl 307c ia = (ien(iel,i)-1)*4 + 1 308c ib = (ien(iel,j)-1)*4 + 1 309cc 310c global(ia,ib) = global(ia,ib) + xGoC(iel,i0,j) 311cc 312c enddo 313c enddo 314c 315cc 316c enddo 317c 318c 319c 320ccad ttim(4) = ttim(4) + secs(0.0) 321c 322cc 323cc.... transfer and flop counts 324cc 325c sbytes = sbytes + nshl*nenl*npro 326c flops = flops + nshl*nenl*npro 327cc 328cc.... return 329cc 330ccad call timer ('Back ') 331c return 332cc 333cc.... ---------------------------> error <--------------------------- 334cc 335c call error ('local ', code, 0) 336cc 337cc.... end 338cc 339c end 340cc 341c 342 343 344 subroutine localSum (global, rlocal, ientmp, nHits, n) 345c 346c---------------------------------------------------------------------- 347c 348c sum the data from the local array to the global degrees of 349c freedom and keep track of the number of locals contributing 350c to each global dof. This may be used to find the average. 351c 352c---------------------------------------------------------------------- 353c 354 include "common.h" 355 356 dimension global(nshg,n), rlocal(npro,nshl,n), 357 & ien(npro,nshl), ientmp(npro,nshl), 358 & nHits(nshg) 359c 360c.... cubic basis has negatives in ien 361c 362 if (ipord > 2) then 363 ien = abs(ientmp) 364 else 365 ien = ientmp 366 endif 367c 368c.... -------------------------> 'assembling ' <---------------------- 369c 370 do j = 1, n 371 do i = 1, nshl 372 do nel = 1,npro 373 idg = ien(nel,i) 374 global(idg,j) = global(idg,j) + rlocal(nel,i,j) 375 enddo 376 enddo 377 enddo 378 do i = 1, nshl 379 do nel = 1,npro 380 idg = ien(nel,i) 381 nHits(idg) = nHits(idg) + 1 382 enddo 383 enddo 384c 385c.... end 386c 387 end 388 389 subroutine localb (global, rlocal, ientmp, n, code) 390c 391c---------------------------------------------------------------------- 392c 393c This subroutine performs a vector gather/scatter operation on boundary only. 394c 395c input: 396c global (nshg,n) : global array 397c rlocal (npro,nshl,n) : local array 398c ien (npro,nshl) : nodal connectivity 399c n : number of d.o.f.'s to be copied 400c code : the transfer code 401c .eq. 'gather ', from global to local 402c .eq. 'scatter ', add local to global 403c .eq. 'globaliz', from local to global 404c 405c 406c Zdenek Johan, Winter 1992. 407c---------------------------------------------------------------------- 408c 409 include "common.h" 410 411 dimension global(nshg,n), rlocal(npro,nshlb,n), 412 & ien(npro,nshl), ientmp(npro,nshl) 413c 414 character*8 code 415 416c 417c.... cubic basis has negatives in ien 418c 419 if (ipord > 2) then 420 ien = abs(ientmp) 421 else 422 ien = ientmp 423 endif 424c 425c.... ------------------------> 'localization ' <-------------------- 426c 427 if (code .eq. 'gather ') then 428c 429c.... set timer 430c 431cad call timer ('Gather ') 432c 433c.... gather the data 434c 435 436 do j = 1, n 437 do i = 1, nshlb 438 rlocal(:,i,j) = global(ien(:,i),j) 439 enddo 440 enddo 441 442 443c 444c.... transfer count 445c 446 gbytes = gbytes + n*nshl*npro 447c 448c.... return 449c 450cad call timer ('Back ') 451 return 452 endif 453c 454c.... -------------------------> 'assembling ' <---------------------- 455c 456 if (code .eq. 'scatter ') then 457c 458c.... set timer 459c 460cad call timer ('Scatter ') 461c 462c.... scatter the data (possible collisions) 463c 464 do j = 1, n 465 do i = 1, nshlb 466 do nel = 1,npro 467 global(ien(nel,i),j) = global(ien(nel,i),j) 468 & + rlocal(nel,i,j) 469 enddo 470 enddo 471 enddo 472 473c 474c.... transfer and flop counts 475c 476 sbytes = sbytes + n*nshlb*npro 477 flops = flops + n*nshlb*npro 478c 479c.... return 480c 481CAD call timer ('Back ') 482 return 483 endif 484c 485c.... -------------------------> 'globalizing ' <---------------------- 486c 487 if (code .eq. 'globaliz') then 488c 489c.... scatter the data (possible collisions) 490c 491 do j = 1, n 492 do i = 1, nshlb 493 do nel = 1,npro 494 global(ien(nel,i),j) = rlocal(nel,i,j) 495 enddo 496 enddo 497 enddo 498c 499c.... return 500c 501cad call timer ('Back ') 502 return 503 endif 504c 505c.... ---------------------------> error <--------------------------- 506c 507 call error ('local ', code, 0) 508c 509c.... end 510c 511 end 512c 513 514 515 516 517