1 module quadfilt 2 3 real*8, allocatable :: shpf(:,:,:) 4 real*8, allocatable :: shglf(:,:,:,:) 5 real*8, allocatable :: Qptf(:,:,:) 6 real*8, allocatable :: Qwtf(:,:) 7 8 real*8, allocatable :: numNden(:,:) 9 10 real*8, allocatable :: xnd(:,:) 11 real*8, allocatable :: xmodcomp(:,:) 12 real*8, allocatable :: xmcomp(:,:) 13 real*8, allocatable :: xlcomp(:,:) 14 real*8, allocatable :: xl1comp(:,:) 15 real*8, allocatable :: xl2comp(:,:) 16 real*8, allocatable :: ucomp(:,:) 17 real*8, allocatable :: scomp(:) 18 19 end module 20 21c------------------------------------------------------------------------------ 22 23 subroutine setfilt 24 25 use quadfilt 26 27 include "common.h" 28 29 ifiltrl = mod(iLES,10) 30 31 if (ifiltrl .eq. 1) then 32 nintf(1) = 1 ! tets 33 nintf(2) = 1 ! hexes 34 nintf(3) = 1 ! wedges 35 nintf(5) = 1 ! pyramids 36 else if (ifiltrl .eq. 2) then 37 nintf(1) = 4 38 nintf(2) = 8 39 nintf(3) = 6 40 nintf(5) = 8 41 else if (ifiltrl .eq. 3) then 42 nintf(1) = 16 43 nintf(2) = 27 44 nintf(3) = 18 45 nintf(5) = 27 46 else if (ifiltrl .eq. 4) then 47 nintf(1) = 29 48 nintf(2) = 64 49 nintf(3) = 48 50 nintf(5) = 64 51 endif 52 53 54 allocate ( shpf(MAXTOP,maxsh,maxval(nintf)) ) 55 allocate ( shglf(MAXTOP,nsd,maxsh,maxval(nintf)) ) 56 allocate ( Qptf(MAXTOP,4,maxval(nintf)) ) 57 allocate ( Qwtf(MAXTOP,maxval(nintf)) ) 58 59 60 allocate ( numNden(nshg,2) ) 61C 62C In development 63C 64 allocate ( xnd(70,2) ) 65 allocate ( xmodcomp(70,5) ) 66 allocate ( xmcomp(70,6) ) 67 allocate ( xlcomp(70,6) ) 68 allocate ( xl1comp(70,6) ) 69 allocate ( xl2comp(70,6) ) 70 allocate ( ucomp(70,3) ) 71 allocate ( scomp(70) ) 72C 73C In development 74C 75 76 numNden = zero 77 78c.... return 79 80 return 81 end 82 83c------------------------------------------------------------------------------ 84 85 subroutine filtprep 86 87 use quadfilt 88 89 include "common.h" 90 91 real*8, allocatable :: tmpQptf (:,:), tmpQwtf (:) 92 93 allocate (tmpQptf(4,nint(1))) 94 allocate (tmpQwtf(nintf(1))) 95 call symtet(nintf(1),tmpQptf,tmpQwtf,nerr) 96 Qptf(1,1:4,1:nintf(1)) = tmpQptf(1:4,1:nintf(1)) 97 Qwtf(1,1:nintf(1)) = tmpQwtf(1:nintf(1)) 98c 99c.... adjust quadrature weights to be consistent with the 100c design of tau. 101c 102 do i = 1, nintf(1) 103 Qwtf(1,i) = (four/three)*Qwtf(1,i) 104 enddo 105 106 deallocate (tmpQptf) 107 deallocate (tmpQwtf) 108 109 110 allocate (tmpQptf(4,nint(2))) 111 allocate (tmpQwtf(nintf(2))) 112 call symhex(nintf(2),tmpQptf,tmpQwtf,nerr) 113 Qptf(2,1:4,1:nintf(2)) = tmpQptf(1:4,1:nintf(2)) 114 Qwtf(2,1:nintf(2)) = tmpQwtf(1:nintf(2)) 115 deallocate (tmpQptf) 116 deallocate (tmpQwtf) 117 118 allocate (tmpQptf(4,nintf(3))) 119 allocate (tmpQwtf(nintf(3))) 120 call symwdg(nintf(3),tmpQptf,tmpQwtf,nerr) 121 Qptf(3,1:4,1:nintf(3)) = tmpQptf(1:4,1:nintf(3)) 122 Qwtf(3,1:nintf(3)) = tmpQwtf(1:nintf(3)) 123 deallocate (tmpQptf) 124 deallocate (tmpQwtf) 125 126 allocate (tmpQptf(4,nintf(5))) 127 allocate (tmpQwtf(nintf(5))) 128 call sympyr(nintf(5),tmpQptf,tmpQwtf,nerr) 129 Qptf(5,1:4,1:nintf(5)) = tmpQptf(1:4,1:nintf(5)) 130 Qwtf(5,1:nintf(5)) = tmpQwtf(1:nintf(5)) 131 deallocate (tmpQptf) 132 deallocate (tmpQwtf) 133 134c 135c.... loop through element blocks 136c 137 do iblk = 1, nelblk 138c 139c.... get coord. system and element type 140c 141 lcsyst = lcblk(3,iblk) 142 nshl = lcblk(10,iblk) 143c 144c.... generate the shape-functions in local coordinates 145c 146 if (lcsyst .eq. 1) then ! tets 147 148 do i=1,nintf(1) 149 call shpTet(ipord,Qptf(1,1:3,i),shpf(1,:,i), 150 & shglf(1,:,:,i)) 151 enddo 152c 153c.... permute to positive volume element 154c 155 shglf(1,:,1:nshl,1:nintf(1)) = 156 & shglf(1,:,1:nshl,1:nintf(1))/two 157 158c 159 else if (lcsyst .eq. 2) then ! hexes 160c 161 162 163 do i=1,nintf(2) 164 call shphex (ipord, Qptf(2,1:3,i),shpf(2,:,i), 165 & shglf(2,:,:,i)) 166 167 enddo 168c 169 else if (lcsyst .eq. 3) then ! wedges 170c 171 do i=1,nintf(3) 172 call shp6W (ipord,Qptf(3,1:3,i),shpf(3,:,i), 173 & shglf(3,:,:,i)) 174 enddo 175c 176 else if (lcsyst .eq. 5) then ! pyramids 177c 178 do i=1,nintf(5) 179 call shppyr (ipord,Qptf(5,1:3,i),shpf(5,:,i), 180 & shglf(5,:,:,i)) 181 enddo 182 183c 184c.... nonexistent element 185c 186 else 187c 188 call error ('filtprep ', 'elem Cat', lelCat) 189c 190 endif 191c 192c.... end of generation 193c 194 enddo 195 196c 197c.... return 198c 199 return 200 end 201 202