c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine add c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c addition of update to the vector u c--------------------------------------------------------------------- include 'header.h' integer i, j, k, m do m = 1, 5 do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 u(m,i,j,k) = u(m,i,j,k) + rhs(m,i,j,k) enddo enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine adi c--------------------------------------------------------------------- c--------------------------------------------------------------------- call compute_rhs call x_solve call y_solve call z_solve call add return end !-------------------------------------------------------------------------! ! ! ! N A S P A R A L L E L B E N C H M A R K S 2.3 ! ! ! ! S E R I A L V E R S I O N S ! ! ! ! B T ! ! ! !-------------------------------------------------------------------------! ! ! ! This benchmark is a serial version of the NPB BT code. ! ! ! ! Permission to use, copy, distribute and modify this software ! ! for any purpose with or without fee is hereby granted. We ! ! request, however, that all derived work reference the NAS ! ! Parallel Benchmarks 2.3. This software is provided "as is" ! ! without express or implied warranty. ! ! ! ! Information on NPB 2.3, including the technical report, the ! ! original specifications, source code, results and information ! ! on how to submit new results, is available at: ! ! ! ! http://www.nas.nasa.gov/NAS/NPB/ ! ! ! ! Send comments or suggestions to npb@nas.nasa.gov ! ! Send bug reports to npb-bugs@nas.nasa.gov ! ! ! ! NAS Parallel Benchmarks Group ! ! NASA Ames Research Center ! ! Mail Stop: T27A-1 ! ! Moffett Field, CA 94035-1000 ! ! ! ! E-mail: npb@nas.nasa.gov ! ! Fax: (415) 604-3957 ! ! ! !-------------------------------------------------------------------------! c--------------------------------------------------------------------- c c Authors: R. Van der Wijngaart c T. Harris c M. Yarrow c c--------------------------------------------------------------------- c--------------------------------------------------------------------- program BT c--------------------------------------------------------------------- include 'header.h' integer i, niter, step, fstatus, n3 double precision navg, mflops c external timer_read c double precision tmax, timer_read logical verified character class c--------------------------------------------------------------------- c Root node reads input file (if it exists) else takes c defaults from parameters c--------------------------------------------------------------------- write(*, 1000) c open (unit=2,file='inputbt.data',status='old', iostat=fstatus) c if (fstatus .eq. 0) then c write(*,233) c 233 format(' Reading from input file inputbt.data') c read (2,*) niter c read (2,*) dt c read (2,*) grid_points(1), grid_points(2), grid_points(3) c close(2) c else write(*,234) niter = niter_default dt = dt_default grid_points(1) = problem_size grid_points(2) = problem_size grid_points(3) = problem_size c endif 234 format(' No input file inputbt.data. Using compiled defaults') write(*, 1001) grid_points(1), grid_points(2), grid_points(3) write(*, 1002) niter, dt 1000 format(//, ' NAS Parallel Benchmarks 2.3-serial verision', > ' - BT Benchmark ',/) 1001 format(' Size: ', i3, 'x', i3, 'x', i3) 1002 format(' Iterations: ', i3, ' dt: ', F10.6) if ( (grid_points(1) .gt. IMAX) .or. > (grid_points(2) .gt. JMAX) .or. > (grid_points(3) .gt. KMAX) ) then c print *, (grid_points(i),i=1,3) c print *,' Problem size too big for compiled array sizes' write(6,*) (grid_points(i),i=1,3) write(6,*) ' Problem size too big for compiled array sizes' goto 999 endif call set_constants call initialize call lhsinit call exact_rhs c--------------------------------------------------------------------- c do one time step to touch all code, and reinitialize c--------------------------------------------------------------------- call adi call initialize c call timer_clear(1) c call timer_start(1) do step = 1, niter if (mod(step, 20) .eq. 0 .or. > step .eq. 1) then write(*, 200) step 200 format(' Time step ', i4) endif call adi end do c call timer_stop(1) c tmax = timer_read(1) call verify(niter, class, verified) n3 = grid_points(1)*grid_points(2)*grid_points(3) navg = (grid_points(1)+grid_points(2)+grid_points(3))/3.0 c if( tmax .ne. 0. ) then c mflops = 1.0e-6*float(niter)* c > (3478.8*float(n3)-17655.7*navg**2+28023.7*navg) c > / tmax c else c mflops = 0.0 c endif c call print_results('BT', class, grid_points(1), c > grid_points(2), grid_points(3), niter, c > tmax, mflops, ' floating point', c > verified, npbversion,compiletime, cs1, cs2, cs3, cs4, cs5, c > cs6, '(none)') 999 continue end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine error_norm(rms) c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c this function computes the norm of the difference between the c computed solution and the exact solution c--------------------------------------------------------------------- include 'header.h' integer i, j, k, m, d double precision xi, eta, zeta, u_exact(5), rms(5), add do m = 1, 5 rms(m) = 0.0d0 enddo do k = 0, grid_points(3)-1 zeta = dble(k) * dnzm1 do j = 0, grid_points(2)-1 eta = dble(j) * dnym1 do i = 0, grid_points(1)-1 xi = dble(i) * dnxm1 call exact_solution(xi, eta, zeta, u_exact) do m = 1, 5 add = u(m,i,j,k)-u_exact(m) rms(m) = rms(m) + add*add enddo enddo enddo enddo do m = 1, 5 do d = 1, 3 rms(m) = rms(m) / dble(grid_points(d)-2) enddo rms(m) = dsqrt(rms(m)) enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine rhs_norm(rms) c--------------------------------------------------------------------- c--------------------------------------------------------------------- include 'header.h' integer i, j, k, d, m double precision rms(5), add do m = 1, 5 rms(m) = 0.0d0 enddo do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 do m = 1, 5 add = rhs(m,i,j,k) rms(m) = rms(m) + add*add enddo enddo enddo enddo do m = 1, 5 do d = 1, 3 rms(m) = rms(m) / dble(grid_points(d)-2) enddo rms(m) = dsqrt(rms(m)) enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine exact_rhs c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c compute the right hand side based on exact solution c--------------------------------------------------------------------- include 'header.h' double precision dtemp(5), xi, eta, zeta, dtpp integer m, i, j, k, ip1, im1, jp1, jm1, km1, kp1 c--------------------------------------------------------------------- c initialize c--------------------------------------------------------------------- do m = 1, 5 do k= 0, grid_points(3)-1 do j = 0, grid_points(2)-1 do i = 0, grid_points(1)-1 forcing(i,j,k,m) = 0.0d0 enddo enddo enddo enddo c--------------------------------------------------------------------- c xi-direction flux differences c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 zeta = dble(k) * dnzm1 do j = 1, grid_points(2)-2 eta = dble(j) * dnym1 do i=0, grid_points(1)-1 xi = dble(i) * dnxm1 call exact_solution(xi, eta, zeta, dtemp) do m = 1, 5 ue(i,m) = dtemp(m) enddo dtpp = 1.0d0 / dtemp(1) do m = 2, 5 buf(i,m) = dtpp * dtemp(m) enddo cuf(i) = buf(i,2) * buf(i,2) buf(i,1) = cuf(i) + buf(i,3) * buf(i,3) + > buf(i,4) * buf(i,4) q(i) = 0.5d0*(buf(i,2)*ue(i,2) + buf(i,3)*ue(i,3) + > buf(i,4)*ue(i,4)) enddo do i = 1, grid_points(1)-2 im1 = i-1 ip1 = i+1 forcing(i,j,k,1) = forcing(i,j,k,1) - > tx2*( ue(ip1,2)-ue(im1,2) )+ > dx1tx1*(ue(ip1,1)-2.0d0*ue(i,1)+ue(im1,1)) forcing(i,j,k,2) = forcing(i,j,k,2) - tx2 * ( > (ue(ip1,2)*buf(ip1,2)+c2*(ue(ip1,5)-q(ip1)))- > (ue(im1,2)*buf(im1,2)+c2*(ue(im1,5)-q(im1))))+ > xxcon1*(buf(ip1,2)-2.0d0*buf(i,2)+buf(im1,2))+ > dx2tx1*( ue(ip1,2)-2.0d0* ue(i,2)+ue(im1,2)) forcing(i,j,k,3) = forcing(i,j,k,3) - tx2 * ( > ue(ip1,3)*buf(ip1,2)-ue(im1,3)*buf(im1,2))+ > xxcon2*(buf(ip1,3)-2.0d0*buf(i,3)+buf(im1,3))+ > dx3tx1*( ue(ip1,3)-2.0d0*ue(i,3) +ue(im1,3)) forcing(i,j,k,4) = forcing(i,j,k,4) - tx2*( > ue(ip1,4)*buf(ip1,2)-ue(im1,4)*buf(im1,2))+ > xxcon2*(buf(ip1,4)-2.0d0*buf(i,4)+buf(im1,4))+ > dx4tx1*( ue(ip1,4)-2.0d0* ue(i,4)+ ue(im1,4)) forcing(i,j,k,5) = forcing(i,j,k,5) - tx2*( > buf(ip1,2)*(c1*ue(ip1,5)-c2*q(ip1))- > buf(im1,2)*(c1*ue(im1,5)-c2*q(im1)))+ > 0.5d0*xxcon3*(buf(ip1,1)-2.0d0*buf(i,1)+ > buf(im1,1))+ > xxcon4*(cuf(ip1)-2.0d0*cuf(i)+cuf(im1))+ > xxcon5*(buf(ip1,5)-2.0d0*buf(i,5)+buf(im1,5))+ > dx5tx1*( ue(ip1,5)-2.0d0* ue(i,5)+ ue(im1,5)) enddo c--------------------------------------------------------------------- c Fourth-order dissipation c--------------------------------------------------------------------- do m = 1, 5 i = 1 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (5.0d0*ue(i,m) - 4.0d0*ue(i+1,m) +ue(i+2,m)) i = 2 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (-4.0d0*ue(i-1,m) + 6.0d0*ue(i,m) - > 4.0d0*ue(i+1,m) + ue(i+2,m)) enddo do m = 1, 5 do i = 1*3, grid_points(1)-3*1-1 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp* > (ue(i-2,m) - 4.0d0*ue(i-1,m) + > 6.0d0*ue(i,m) - 4.0d0*ue(i+1,m) + ue(i+2,m)) enddo enddo do m = 1, 5 i = grid_points(1)-3 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (ue(i-2,m) - 4.0d0*ue(i-1,m) + > 6.0d0*ue(i,m) - 4.0d0*ue(i+1,m)) i = grid_points(1)-2 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (ue(i-2,m) - 4.0d0*ue(i-1,m) + 5.0d0*ue(i,m)) enddo enddo enddo c--------------------------------------------------------------------- c eta-direction flux differences c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 zeta = dble(k) * dnzm1 do i=1, grid_points(1)-2 xi = dble(i) * dnxm1 do j=0, grid_points(2)-1 eta = dble(j) * dnym1 call exact_solution(xi, eta, zeta, dtemp) do m = 1, 5 ue(j,m) = dtemp(m) enddo dtpp = 1.0d0/dtemp(1) do m = 2, 5 buf(j,m) = dtpp * dtemp(m) enddo cuf(j) = buf(j,3) * buf(j,3) buf(j,1) = cuf(j) + buf(j,2) * buf(j,2) + > buf(j,4) * buf(j,4) q(j) = 0.5d0*(buf(j,2)*ue(j,2) + buf(j,3)*ue(j,3) + > buf(j,4)*ue(j,4)) enddo do j = 1, grid_points(2)-2 jm1 = j-1 jp1 = j+1 forcing(i,j,k,1) = forcing(i,j,k,1) - > ty2*( ue(jp1,3)-ue(jm1,3) )+ > dy1ty1*(ue(jp1,1)-2.0d0*ue(j,1)+ue(jm1,1)) forcing(i,j,k,2) = forcing(i,j,k,2) - ty2*( > ue(jp1,2)*buf(jp1,3)-ue(jm1,2)*buf(jm1,3))+ > yycon2*(buf(jp1,2)-2.0d0*buf(j,2)+buf(jm1,2))+ > dy2ty1*( ue(jp1,2)-2.0* ue(j,2)+ ue(jm1,2)) forcing(i,j,k,3) = forcing(i,j,k,3) - ty2*( > (ue(jp1,3)*buf(jp1,3)+c2*(ue(jp1,5)-q(jp1)))- > (ue(jm1,3)*buf(jm1,3)+c2*(ue(jm1,5)-q(jm1))))+ > yycon1*(buf(jp1,3)-2.0d0*buf(j,3)+buf(jm1,3))+ > dy3ty1*( ue(jp1,3)-2.0d0*ue(j,3) +ue(jm1,3)) forcing(i,j,k,4) = forcing(i,j,k,4) - ty2*( > ue(jp1,4)*buf(jp1,3)-ue(jm1,4)*buf(jm1,3))+ > yycon2*(buf(jp1,4)-2.0d0*buf(j,4)+buf(jm1,4))+ > dy4ty1*( ue(jp1,4)-2.0d0*ue(j,4)+ ue(jm1,4)) forcing(i,j,k,5) = forcing(i,j,k,5) - ty2*( > buf(jp1,3)*(c1*ue(jp1,5)-c2*q(jp1))- > buf(jm1,3)*(c1*ue(jm1,5)-c2*q(jm1)))+ > 0.5d0*yycon3*(buf(jp1,1)-2.0d0*buf(j,1)+ > buf(jm1,1))+ > yycon4*(cuf(jp1)-2.0d0*cuf(j)+cuf(jm1))+ > yycon5*(buf(jp1,5)-2.0d0*buf(j,5)+buf(jm1,5))+ > dy5ty1*(ue(jp1,5)-2.0d0*ue(j,5)+ue(jm1,5)) enddo c--------------------------------------------------------------------- c Fourth-order dissipation c--------------------------------------------------------------------- do m = 1, 5 j = 1 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (5.0d0*ue(j,m) - 4.0d0*ue(j+1,m) +ue(j+2,m)) j = 2 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (-4.0d0*ue(j-1,m) + 6.0d0*ue(j,m) - > 4.0d0*ue(j+1,m) + ue(j+2,m)) enddo do m = 1, 5 do j = 1*3, grid_points(2)-3*1-1 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp* > (ue(j-2,m) - 4.0d0*ue(j-1,m) + > 6.0d0*ue(j,m) - 4.0d0*ue(j+1,m) + ue(j+2,m)) enddo enddo do m = 1, 5 j = grid_points(2)-3 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (ue(j-2,m) - 4.0d0*ue(j-1,m) + > 6.0d0*ue(j,m) - 4.0d0*ue(j+1,m)) j = grid_points(2)-2 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (ue(j-2,m) - 4.0d0*ue(j-1,m) + 5.0d0*ue(j,m)) enddo enddo enddo c--------------------------------------------------------------------- c zeta-direction flux differences c--------------------------------------------------------------------- do j=1, grid_points(2)-2 eta = dble(j) * dnym1 do i = 1, grid_points(1)-2 xi = dble(i) * dnxm1 do k=0, grid_points(3)-1 zeta = dble(k) * dnzm1 call exact_solution(xi, eta, zeta, dtemp) do m = 1, 5 ue(k,m) = dtemp(m) enddo dtpp = 1.0d0/dtemp(1) do m = 2, 5 buf(k,m) = dtpp * dtemp(m) enddo cuf(k) = buf(k,4) * buf(k,4) buf(k,1) = cuf(k) + buf(k,2) * buf(k,2) + > buf(k,3) * buf(k,3) q(k) = 0.5d0*(buf(k,2)*ue(k,2) + buf(k,3)*ue(k,3) + > buf(k,4)*ue(k,4)) enddo do k=1, grid_points(3)-2 km1 = k-1 kp1 = k+1 forcing(i,j,k,1) = forcing(i,j,k,1) - > tz2*( ue(kp1,4)-ue(km1,4) )+ > dz1tz1*(ue(kp1,1)-2.0d0*ue(k,1)+ue(km1,1)) forcing(i,j,k,2) = forcing(i,j,k,2) - tz2 * ( > ue(kp1,2)*buf(kp1,4)-ue(km1,2)*buf(km1,4))+ > zzcon2*(buf(kp1,2)-2.0d0*buf(k,2)+buf(km1,2))+ > dz2tz1*( ue(kp1,2)-2.0d0* ue(k,2)+ ue(km1,2)) forcing(i,j,k,3) = forcing(i,j,k,3) - tz2 * ( > ue(kp1,3)*buf(kp1,4)-ue(km1,3)*buf(km1,4))+ > zzcon2*(buf(kp1,3)-2.0d0*buf(k,3)+buf(km1,3))+ > dz3tz1*(ue(kp1,3)-2.0d0*ue(k,3)+ue(km1,3)) forcing(i,j,k,4) = forcing(i,j,k,4) - tz2 * ( > (ue(kp1,4)*buf(kp1,4)+c2*(ue(kp1,5)-q(kp1)))- > (ue(km1,4)*buf(km1,4)+c2*(ue(km1,5)-q(km1))))+ > zzcon1*(buf(kp1,4)-2.0d0*buf(k,4)+buf(km1,4))+ > dz4tz1*( ue(kp1,4)-2.0d0*ue(k,4) +ue(km1,4)) forcing(i,j,k,5) = forcing(i,j,k,5) - tz2 * ( > buf(kp1,4)*(c1*ue(kp1,5)-c2*q(kp1))- > buf(km1,4)*(c1*ue(km1,5)-c2*q(km1)))+ > 0.5d0*zzcon3*(buf(kp1,1)-2.0d0*buf(k,1) > +buf(km1,1))+ > zzcon4*(cuf(kp1)-2.0d0*cuf(k)+cuf(km1))+ > zzcon5*(buf(kp1,5)-2.0d0*buf(k,5)+buf(km1,5))+ > dz5tz1*( ue(kp1,5)-2.0d0*ue(k,5)+ ue(km1,5)) enddo c--------------------------------------------------------------------- c Fourth-order dissipation c--------------------------------------------------------------------- do m = 1, 5 k = 1 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (5.0d0*ue(k,m) - 4.0d0*ue(k+1,m) +ue(k+2,m)) k = 2 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (-4.0d0*ue(k-1,m) + 6.0d0*ue(k,m) - > 4.0d0*ue(k+1,m) + ue(k+2,m)) enddo do m = 1, 5 do k = 1*3, grid_points(3)-3*1-1 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp* > (ue(k-2,m) - 4.0d0*ue(k-1,m) + > 6.0d0*ue(k,m) - 4.0d0*ue(k+1,m) + ue(k+2,m)) enddo enddo do m = 1, 5 k = grid_points(3)-3 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (ue(k-2,m) - 4.0d0*ue(k-1,m) + > 6.0d0*ue(k,m) - 4.0d0*ue(k+1,m)) k = grid_points(3)-2 forcing(i,j,k,m) = forcing(i,j,k,m) - dssp * > (ue(k-2,m) - 4.0d0*ue(k-1,m) + 5.0d0*ue(k,m)) enddo enddo enddo c--------------------------------------------------------------------- c now change the sign of the forcing function, c--------------------------------------------------------------------- do m = 1, 5 do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 forcing(i,j,k,m) = -1.d0 * forcing(i,j,k,m) enddo enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine exact_solution(xi,eta,zeta,dtemp) c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c this function returns the exact solution at point xi, eta, zeta c--------------------------------------------------------------------- include 'header.h' double precision xi, eta, zeta, dtemp(5) integer m do m = 1, 5 dtemp(m) = ce(m,1) + > xi*(ce(m,2) + xi*(ce(m,5) + xi*(ce(m,8) + xi*ce(m,11)))) + > eta*(ce(m,3) + eta*(ce(m,6) + eta*(ce(m,9) + eta*ce(m,12))))+ > zeta*(ce(m,4) + zeta*(ce(m,7) + zeta*(ce(m,10) + > zeta*ce(m,13)))) enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine initialize c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c This subroutine initializes the field variable u using c tri-linear transfinite interpolation of the boundary values c--------------------------------------------------------------------- include 'header.h' integer i, j, k, m, ix, iy, iz double precision xi, eta, zeta, Pface(5,3,2), Pxi, Peta, > Pzeta, temp(5) c--------------------------------------------------------------------- c Later (in compute_rhs) we compute 1/u for every element. A few of c the corner elements are not used, but it convenient (and faster) c to compute the whole thing with a simple loop. Make sure those c values are nonzero by initializing the whole thing here. c--------------------------------------------------------------------- do m = 1, 5 do k = 0, IMAX-1 do j = 0, IMAX-1 do i = 0, IMAX-1 u(m,i,j,k) = 1.0 end do end do end do end do c--------------------------------------------------------------------- c--------------------------------------------------------------------- c first store the "interpolated" values everywhere on the grid c--------------------------------------------------------------------- do k = 0, grid_points(3)-1 zeta = dble(k) * dnzm1 do j = 0, grid_points(2)-1 eta = dble(j) * dnym1 do i = 0, grid_points(1)-1 xi = dble(i) * dnxm1 do ix = 1, 2 call exact_solution(dble(ix-1), eta, zeta, > Pface(1,1,ix)) enddo do iy = 1, 2 call exact_solution(xi, dble(iy-1) , zeta, > Pface(1,2,iy)) enddo do iz = 1, 2 call exact_solution(xi, eta, dble(iz-1), > Pface(1,3,iz)) enddo do m = 1, 5 Pxi = xi * Pface(m,1,2) + > (1.0d0-xi) * Pface(m,1,1) Peta = eta * Pface(m,2,2) + > (1.0d0-eta) * Pface(m,2,1) Pzeta = zeta * Pface(m,3,2) + > (1.0d0-zeta) * Pface(m,3,1) u(m,i,j,k) = Pxi + Peta + Pzeta - > Pxi*Peta - Pxi*Pzeta - Peta*Pzeta + > Pxi*Peta*Pzeta enddo enddo enddo enddo c--------------------------------------------------------------------- c now store the exact values on the boundaries c--------------------------------------------------------------------- c--------------------------------------------------------------------- c west face c--------------------------------------------------------------------- i = 0 xi = 0.0d0 do k = 0, grid_points(3)-1 zeta = dble(k) * dnzm1 do j = 0, grid_points(2)-1 eta = dble(j) * dnym1 call exact_solution(xi, eta, zeta, temp) do m = 1, 5 u(m,i,j,k) = temp(m) enddo enddo enddo c--------------------------------------------------------------------- c east face c--------------------------------------------------------------------- i = grid_points(1)-1 xi = 1.0d0 do k = 0, grid_points(3)-1 zeta = dble(k) * dnzm1 do j = 0, grid_points(2)-1 eta = dble(j) * dnym1 call exact_solution(xi, eta, zeta, temp) do m = 1, 5 u(m,i,j,k) = temp(m) enddo enddo enddo c--------------------------------------------------------------------- c south face c--------------------------------------------------------------------- j = 0 eta = 0.0d0 do k = 0, grid_points(3)-1 zeta = dble(k) * dnzm1 do i = 0, grid_points(1)-1 xi = dble(i) * dnxm1 call exact_solution(xi, eta, zeta, temp) do m = 1, 5 u(m,i,j,k) = temp(m) enddo enddo enddo c--------------------------------------------------------------------- c north face c--------------------------------------------------------------------- j = grid_points(2)-1 eta = 1.0d0 do k = 0, grid_points(3)-1 zeta = dble(k) * dnzm1 do i = 0, grid_points(1)-1 xi = dble(i) * dnxm1 call exact_solution(xi, eta, zeta, temp) do m = 1, 5 u(m,i,j,k) = temp(m) enddo enddo enddo c--------------------------------------------------------------------- c bottom face c--------------------------------------------------------------------- k = 0 zeta = 0.0d0 do i =0, grid_points(1)-1 xi = dble(i) *dnxm1 do j = 0, grid_points(2)-1 eta = dble(j) * dnym1 call exact_solution(xi, eta, zeta, temp) do m = 1, 5 u(m,i,j,k) = temp(m) enddo enddo enddo c--------------------------------------------------------------------- c top face c--------------------------------------------------------------------- k = grid_points(3)-1 zeta = 1.0d0 do i =0, grid_points(1)-1 xi = dble(i) * dnxm1 do j = 0, grid_points(2)-1 eta = dble(j) * dnym1 call exact_solution(xi, eta, zeta, temp) do m = 1, 5 u(m,i,j,k) = temp(m) enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine lhsinit c--------------------------------------------------------------------- c--------------------------------------------------------------------- include 'header.h' integer i, j, k, c, m, n c = 1 c--------------------------------------------------------------------- c zero the whole left hand side for starters c--------------------------------------------------------------------- do m = 1,5 do n = 1, 5 do k = 0, grid_points(3)-1 do j = 0, grid_points(2)-1 do i = 0, grid_points(1)-1 lhs(m,n,1,i,j,k) = 0.0d0 lhs(m,n,2,i,j,k) = 0.0d0 lhs(m,n,3,i,j,k) = 0.0d0 enddo enddo enddo enddo enddo c--------------------------------------------------------------------- c next, set all diagonal values to 1. This is overkill, but convenient c--------------------------------------------------------------------- do m = 1, 5 do k = 0, grid_points(3)-1 do j = 0, grid_points(2)-1 do i = 0, grid_points(1)-1 lhs(m,m,2,i,j,k) = 1.0d0 enddo enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine lhsx c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c This function computes the left hand side in the xi-direction c--------------------------------------------------------------------- include 'header.h' integer i, j, k c--------------------------------------------------------------------- c determine a (labeled f) and n jacobians c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 0, grid_points(1)-1 tmp1 = 1.0d+00 / u(1,i,j,k) tmp2 = tmp1 * tmp1 tmp3 = tmp1 * tmp2 c--------------------------------------------------------------------- c c--------------------------------------------------------------------- fjac(1, 1, i, j, k) = 0.0d+00 fjac(1, 2, i, j, k) = 1.0d+00 fjac(1, 3, i, j, k) = 0.0d+00 fjac(1, 4, i, j, k) = 0.0d+00 fjac(1, 5, i, j, k) = 0.0d+00 fjac(2, 1, i, j, k) = -(u(2,i,j,k) * tmp2 * > u(2,i,j,k)) > + c2 * 0.50d+00 * (u(2,i,j,k) * u(2,i,j,k) > + u(3,i,j,k) * u(3,i,j,k) > + u(4,i,j,k) * u(4,i,j,k) ) * tmp2 fjac(2,2,i,j,k) = ( 2.0d+00 - c2 ) > * ( u(2,i,j,k) / u(1,i,j,k) ) fjac(2,3,i,j,k) = - c2 * ( u(3,i,j,k) * tmp1 ) fjac(2,4,i,j,k) = - c2 * ( u(4,i,j,k) * tmp1 ) fjac(2,5,i,j,k) = c2 fjac(3,1,i,j,k) = - ( u(2,i,j,k)*u(3,i,j,k) ) * tmp2 fjac(3,2,i,j,k) = u(3,i,j,k) * tmp1 fjac(3,3,i,j,k) = u(2,i,j,k) * tmp1 fjac(3,4,i,j,k) = 0.0d+00 fjac(3,5,i,j,k) = 0.0d+00 fjac(4,1,i,j,k) = - ( u(2,i,j,k)*u(4,i,j,k) ) * tmp2 fjac(4,2,i,j,k) = u(4,i,j,k) * tmp1 fjac(4,3,i,j,k) = 0.0d+00 fjac(4,4,i,j,k) = u(2,i,j,k) * tmp1 fjac(4,5,i,j,k) = 0.0d+00 fjac(5,1,i,j,k) = ( c2 * ( u(2,i,j,k) * u(2,i,j,k) > + u(3,i,j,k) * u(3,i,j,k) > + u(4,i,j,k) * u(4,i,j,k) ) * tmp2 > - c1 * ( u(5,i,j,k) * tmp1 ) ) > * ( u(2,i,j,k) * tmp1 ) fjac(5,2,i,j,k) = c1 * u(5,i,j,k) * tmp1 > - 0.50d+00 * c2 > * ( 3.0d+00*u(2,i,j,k)*u(2,i,j,k) > + u(3,i,j,k)*u(3,i,j,k) > + u(4,i,j,k)*u(4,i,j,k) ) * tmp2 fjac(5,3,i,j,k) = - c2 * ( u(3,i,j,k)*u(2,i,j,k) ) > * tmp2 fjac(5,4,i,j,k) = - c2 * ( u(4,i,j,k)*u(2,i,j,k) ) > * tmp2 fjac(5,5,i,j,k) = c1 * ( u(2,i,j,k) * tmp1 ) njac(1,1,i,j,k) = 0.0d+00 njac(1,2,i,j,k) = 0.0d+00 njac(1,3,i,j,k) = 0.0d+00 njac(1,4,i,j,k) = 0.0d+00 njac(1,5,i,j,k) = 0.0d+00 njac(2,1,i,j,k) = - con43 * c3c4 * tmp2 * u(2,i,j,k) njac(2,2,i,j,k) = con43 * c3c4 * tmp1 njac(2,3,i,j,k) = 0.0d+00 njac(2,4,i,j,k) = 0.0d+00 njac(2,5,i,j,k) = 0.0d+00 njac(3,1,i,j,k) = - c3c4 * tmp2 * u(3,i,j,k) njac(3,2,i,j,k) = 0.0d+00 njac(3,3,i,j,k) = c3c4 * tmp1 njac(3,4,i,j,k) = 0.0d+00 njac(3,5,i,j,k) = 0.0d+00 njac(4,1,i,j,k) = - c3c4 * tmp2 * u(4,i,j,k) njac(4,2,i,j,k) = 0.0d+00 njac(4,3,i,j,k) = 0.0d+00 njac(4,4,i,j,k) = c3c4 * tmp1 njac(4,5,i,j,k) = 0.0d+00 njac(5,1,i,j,k) = - ( con43 * c3c4 > - c1345 ) * tmp3 * (u(2,i,j,k)**2) > - ( c3c4 - c1345 ) * tmp3 * (u(3,i,j,k)**2) > - ( c3c4 - c1345 ) * tmp3 * (u(4,i,j,k)**2) > - c1345 * tmp2 * u(5,i,j,k) njac(5,2,i,j,k) = ( con43 * c3c4 > - c1345 ) * tmp2 * u(2,i,j,k) njac(5,3,i,j,k) = ( c3c4 - c1345 ) * tmp2 * u(3,i,j,k) njac(5,4,i,j,k) = ( c3c4 - c1345 ) * tmp2 * u(4,i,j,k) njac(5,5,i,j,k) = ( c1345 ) * tmp1 enddo c--------------------------------------------------------------------- c now jacobians set, so form left hand side in x direction c--------------------------------------------------------------------- do i = 1, grid_points(1)-2 tmp1 = dt * tx1 tmp2 = dt * tx2 lhs(1,1,aa,i,j,k) = - tmp2 * fjac(1,1,i-1,j,k) > - tmp1 * njac(1,1,i-1,j,k) > - tmp1 * dx1 lhs(1,2,aa,i,j,k) = - tmp2 * fjac(1,2,i-1,j,k) > - tmp1 * njac(1,2,i-1,j,k) lhs(1,3,aa,i,j,k) = - tmp2 * fjac(1,3,i-1,j,k) > - tmp1 * njac(1,3,i-1,j,k) lhs(1,4,aa,i,j,k) = - tmp2 * fjac(1,4,i-1,j,k) > - tmp1 * njac(1,4,i-1,j,k) lhs(1,5,aa,i,j,k) = - tmp2 * fjac(1,5,i-1,j,k) > - tmp1 * njac(1,5,i-1,j,k) lhs(2,1,aa,i,j,k) = - tmp2 * fjac(2,1,i-1,j,k) > - tmp1 * njac(2,1,i-1,j,k) lhs(2,2,aa,i,j,k) = - tmp2 * fjac(2,2,i-1,j,k) > - tmp1 * njac(2,2,i-1,j,k) > - tmp1 * dx2 lhs(2,3,aa,i,j,k) = - tmp2 * fjac(2,3,i-1,j,k) > - tmp1 * njac(2,3,i-1,j,k) lhs(2,4,aa,i,j,k) = - tmp2 * fjac(2,4,i-1,j,k) > - tmp1 * njac(2,4,i-1,j,k) lhs(2,5,aa,i,j,k) = - tmp2 * fjac(2,5,i-1,j,k) > - tmp1 * njac(2,5,i-1,j,k) lhs(3,1,aa,i,j,k) = - tmp2 * fjac(3,1,i-1,j,k) > - tmp1 * njac(3,1,i-1,j,k) lhs(3,2,aa,i,j,k) = - tmp2 * fjac(3,2,i-1,j,k) > - tmp1 * njac(3,2,i-1,j,k) lhs(3,3,aa,i,j,k) = - tmp2 * fjac(3,3,i-1,j,k) > - tmp1 * njac(3,3,i-1,j,k) > - tmp1 * dx3 lhs(3,4,aa,i,j,k) = - tmp2 * fjac(3,4,i-1,j,k) > - tmp1 * njac(3,4,i-1,j,k) lhs(3,5,aa,i,j,k) = - tmp2 * fjac(3,5,i-1,j,k) > - tmp1 * njac(3,5,i-1,j,k) lhs(4,1,aa,i,j,k) = - tmp2 * fjac(4,1,i-1,j,k) > - tmp1 * njac(4,1,i-1,j,k) lhs(4,2,aa,i,j,k) = - tmp2 * fjac(4,2,i-1,j,k) > - tmp1 * njac(4,2,i-1,j,k) lhs(4,3,aa,i,j,k) = - tmp2 * fjac(4,3,i-1,j,k) > - tmp1 * njac(4,3,i-1,j,k) lhs(4,4,aa,i,j,k) = - tmp2 * fjac(4,4,i-1,j,k) > - tmp1 * njac(4,4,i-1,j,k) > - tmp1 * dx4 lhs(4,5,aa,i,j,k) = - tmp2 * fjac(4,5,i-1,j,k) > - tmp1 * njac(4,5,i-1,j,k) lhs(5,1,aa,i,j,k) = - tmp2 * fjac(5,1,i-1,j,k) > - tmp1 * njac(5,1,i-1,j,k) lhs(5,2,aa,i,j,k) = - tmp2 * fjac(5,2,i-1,j,k) > - tmp1 * njac(5,2,i-1,j,k) lhs(5,3,aa,i,j,k) = - tmp2 * fjac(5,3,i-1,j,k) > - tmp1 * njac(5,3,i-1,j,k) lhs(5,4,aa,i,j,k) = - tmp2 * fjac(5,4,i-1,j,k) > - tmp1 * njac(5,4,i-1,j,k) lhs(5,5,aa,i,j,k) = - tmp2 * fjac(5,5,i-1,j,k) > - tmp1 * njac(5,5,i-1,j,k) > - tmp1 * dx5 lhs(1,1,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(1,1,i,j,k) > + tmp1 * 2.0d+00 * dx1 lhs(1,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,2,i,j,k) lhs(1,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,3,i,j,k) lhs(1,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,4,i,j,k) lhs(1,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,5,i,j,k) lhs(2,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,1,i,j,k) lhs(2,2,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(2,2,i,j,k) > + tmp1 * 2.0d+00 * dx2 lhs(2,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,3,i,j,k) lhs(2,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,4,i,j,k) lhs(2,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,5,i,j,k) lhs(3,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,1,i,j,k) lhs(3,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,2,i,j,k) lhs(3,3,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(3,3,i,j,k) > + tmp1 * 2.0d+00 * dx3 lhs(3,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,4,i,j,k) lhs(3,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,5,i,j,k) lhs(4,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,1,i,j,k) lhs(4,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,2,i,j,k) lhs(4,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,3,i,j,k) lhs(4,4,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(4,4,i,j,k) > + tmp1 * 2.0d+00 * dx4 lhs(4,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,5,i,j,k) lhs(5,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,1,i,j,k) lhs(5,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,2,i,j,k) lhs(5,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,3,i,j,k) lhs(5,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,4,i,j,k) lhs(5,5,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(5,5,i,j,k) > + tmp1 * 2.0d+00 * dx5 lhs(1,1,cc,i,j,k) = tmp2 * fjac(1,1,i+1,j,k) > - tmp1 * njac(1,1,i+1,j,k) > - tmp1 * dx1 lhs(1,2,cc,i,j,k) = tmp2 * fjac(1,2,i+1,j,k) > - tmp1 * njac(1,2,i+1,j,k) lhs(1,3,cc,i,j,k) = tmp2 * fjac(1,3,i+1,j,k) > - tmp1 * njac(1,3,i+1,j,k) lhs(1,4,cc,i,j,k) = tmp2 * fjac(1,4,i+1,j,k) > - tmp1 * njac(1,4,i+1,j,k) lhs(1,5,cc,i,j,k) = tmp2 * fjac(1,5,i+1,j,k) > - tmp1 * njac(1,5,i+1,j,k) lhs(2,1,cc,i,j,k) = tmp2 * fjac(2,1,i+1,j,k) > - tmp1 * njac(2,1,i+1,j,k) lhs(2,2,cc,i,j,k) = tmp2 * fjac(2,2,i+1,j,k) > - tmp1 * njac(2,2,i+1,j,k) > - tmp1 * dx2 lhs(2,3,cc,i,j,k) = tmp2 * fjac(2,3,i+1,j,k) > - tmp1 * njac(2,3,i+1,j,k) lhs(2,4,cc,i,j,k) = tmp2 * fjac(2,4,i+1,j,k) > - tmp1 * njac(2,4,i+1,j,k) lhs(2,5,cc,i,j,k) = tmp2 * fjac(2,5,i+1,j,k) > - tmp1 * njac(2,5,i+1,j,k) lhs(3,1,cc,i,j,k) = tmp2 * fjac(3,1,i+1,j,k) > - tmp1 * njac(3,1,i+1,j,k) lhs(3,2,cc,i,j,k) = tmp2 * fjac(3,2,i+1,j,k) > - tmp1 * njac(3,2,i+1,j,k) lhs(3,3,cc,i,j,k) = tmp2 * fjac(3,3,i+1,j,k) > - tmp1 * njac(3,3,i+1,j,k) > - tmp1 * dx3 lhs(3,4,cc,i,j,k) = tmp2 * fjac(3,4,i+1,j,k) > - tmp1 * njac(3,4,i+1,j,k) lhs(3,5,cc,i,j,k) = tmp2 * fjac(3,5,i+1,j,k) > - tmp1 * njac(3,5,i+1,j,k) lhs(4,1,cc,i,j,k) = tmp2 * fjac(4,1,i+1,j,k) > - tmp1 * njac(4,1,i+1,j,k) lhs(4,2,cc,i,j,k) = tmp2 * fjac(4,2,i+1,j,k) > - tmp1 * njac(4,2,i+1,j,k) lhs(4,3,cc,i,j,k) = tmp2 * fjac(4,3,i+1,j,k) > - tmp1 * njac(4,3,i+1,j,k) lhs(4,4,cc,i,j,k) = tmp2 * fjac(4,4,i+1,j,k) > - tmp1 * njac(4,4,i+1,j,k) > - tmp1 * dx4 lhs(4,5,cc,i,j,k) = tmp2 * fjac(4,5,i+1,j,k) > - tmp1 * njac(4,5,i+1,j,k) lhs(5,1,cc,i,j,k) = tmp2 * fjac(5,1,i+1,j,k) > - tmp1 * njac(5,1,i+1,j,k) lhs(5,2,cc,i,j,k) = tmp2 * fjac(5,2,i+1,j,k) > - tmp1 * njac(5,2,i+1,j,k) lhs(5,3,cc,i,j,k) = tmp2 * fjac(5,3,i+1,j,k) > - tmp1 * njac(5,3,i+1,j,k) lhs(5,4,cc,i,j,k) = tmp2 * fjac(5,4,i+1,j,k) > - tmp1 * njac(5,4,i+1,j,k) lhs(5,5,cc,i,j,k) = tmp2 * fjac(5,5,i+1,j,k) > - tmp1 * njac(5,5,i+1,j,k) > - tmp1 * dx5 enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine lhsy c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c This function computes the left hand side for the three y-factors c--------------------------------------------------------------------- include 'header.h' integer i, j, k c--------------------------------------------------------------------- c Compute the indices for storing the tri-diagonal matrix; c determine a (labeled f) and n jacobians for cell c c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 do j = 0, grid_points(2)-1 do i = 1, grid_points(1)-2 tmp1 = 1.0d+00 / u(1,i,j,k) tmp2 = tmp1 * tmp1 tmp3 = tmp1 * tmp2 fjac(1, 1, i, j, k) = 0.0d+00 fjac(1, 2, i, j, k) = 0.0d+00 fjac(1, 3, i, j, k) = 1.0d+00 fjac(1, 4, i, j, k) = 0.0d+00 fjac(1, 5, i, j, k) = 0.0d+00 fjac(2,1,i,j,k) = - ( u(2,i,j,k)*u(3,i,j,k) ) > * tmp2 fjac(2,2,i,j,k) = u(3,i,j,k) * tmp1 fjac(2,3,i,j,k) = u(2,i,j,k) * tmp1 fjac(2,4,i,j,k) = 0.0d+00 fjac(2,5,i,j,k) = 0.0d+00 fjac(3,1,i,j,k) = - ( u(3,i,j,k)*u(3,i,j,k)*tmp2) > + 0.50d+00 * c2 * ( ( u(2,i,j,k) * u(2,i,j,k) > + u(3,i,j,k) * u(3,i,j,k) > + u(4,i,j,k) * u(4,i,j,k) ) > * tmp2 ) fjac(3,2,i,j,k) = - c2 * u(2,i,j,k) * tmp1 fjac(3,3,i,j,k) = ( 2.0d+00 - c2 ) > * u(3,i,j,k) * tmp1 fjac(3,4,i,j,k) = - c2 * u(4,i,j,k) * tmp1 fjac(3,5,i,j,k) = c2 fjac(4,1,i,j,k) = - ( u(3,i,j,k)*u(4,i,j,k) ) > * tmp2 fjac(4,2,i,j,k) = 0.0d+00 fjac(4,3,i,j,k) = u(4,i,j,k) * tmp1 fjac(4,4,i,j,k) = u(3,i,j,k) * tmp1 fjac(4,5,i,j,k) = 0.0d+00 fjac(5,1,i,j,k) = ( c2 * ( u(2,i,j,k) * u(2,i,j,k) > + u(3,i,j,k) * u(3,i,j,k) > + u(4,i,j,k) * u(4,i,j,k) ) > * tmp2 > - c1 * u(5,i,j,k) * tmp1 ) > * u(3,i,j,k) * tmp1 fjac(5,2,i,j,k) = - c2 * u(2,i,j,k)*u(3,i,j,k) > * tmp2 fjac(5,3,i,j,k) = c1 * u(5,i,j,k) * tmp1 > - 0.50d+00 * c2 > * ( ( u(2,i,j,k)*u(2,i,j,k) > + 3.0d+00 * u(3,i,j,k)*u(3,i,j,k) > + u(4,i,j,k)*u(4,i,j,k) ) > * tmp2 ) fjac(5,4,i,j,k) = - c2 * ( u(3,i,j,k)*u(4,i,j,k) ) > * tmp2 fjac(5,5,i,j,k) = c1 * u(3,i,j,k) * tmp1 njac(1,1,i,j,k) = 0.0d+00 njac(1,2,i,j,k) = 0.0d+00 njac(1,3,i,j,k) = 0.0d+00 njac(1,4,i,j,k) = 0.0d+00 njac(1,5,i,j,k) = 0.0d+00 njac(2,1,i,j,k) = - c3c4 * tmp2 * u(2,i,j,k) njac(2,2,i,j,k) = c3c4 * tmp1 njac(2,3,i,j,k) = 0.0d+00 njac(2,4,i,j,k) = 0.0d+00 njac(2,5,i,j,k) = 0.0d+00 njac(3,1,i,j,k) = - con43 * c3c4 * tmp2 * u(3,i,j,k) njac(3,2,i,j,k) = 0.0d+00 njac(3,3,i,j,k) = con43 * c3c4 * tmp1 njac(3,4,i,j,k) = 0.0d+00 njac(3,5,i,j,k) = 0.0d+00 njac(4,1,i,j,k) = - c3c4 * tmp2 * u(4,i,j,k) njac(4,2,i,j,k) = 0.0d+00 njac(4,3,i,j,k) = 0.0d+00 njac(4,4,i,j,k) = c3c4 * tmp1 njac(4,5,i,j,k) = 0.0d+00 njac(5,1,i,j,k) = - ( c3c4 > - c1345 ) * tmp3 * (u(2,i,j,k)**2) > - ( con43 * c3c4 > - c1345 ) * tmp3 * (u(3,i,j,k)**2) > - ( c3c4 - c1345 ) * tmp3 * (u(4,i,j,k)**2) > - c1345 * tmp2 * u(5,i,j,k) njac(5,2,i,j,k) = ( c3c4 - c1345 ) * tmp2 * u(2,i,j,k) njac(5,3,i,j,k) = ( con43 * c3c4 > - c1345 ) * tmp2 * u(3,i,j,k) njac(5,4,i,j,k) = ( c3c4 - c1345 ) * tmp2 * u(4,i,j,k) njac(5,5,i,j,k) = ( c1345 ) * tmp1 enddo enddo enddo c--------------------------------------------------------------------- c now joacobians set, so form left hand side in y direction c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 tmp1 = dt * ty1 tmp2 = dt * ty2 lhs(1,1,aa,i,j,k) = - tmp2 * fjac(1,1,i,j-1,k) > - tmp1 * njac(1,1,i,j-1,k) > - tmp1 * dy1 lhs(1,2,aa,i,j,k) = - tmp2 * fjac(1,2,i,j-1,k) > - tmp1 * njac(1,2,i,j-1,k) lhs(1,3,aa,i,j,k) = - tmp2 * fjac(1,3,i,j-1,k) > - tmp1 * njac(1,3,i,j-1,k) lhs(1,4,aa,i,j,k) = - tmp2 * fjac(1,4,i,j-1,k) > - tmp1 * njac(1,4,i,j-1,k) lhs(1,5,aa,i,j,k) = - tmp2 * fjac(1,5,i,j-1,k) > - tmp1 * njac(1,5,i,j-1,k) lhs(2,1,aa,i,j,k) = - tmp2 * fjac(2,1,i,j-1,k) > - tmp1 * njac(2,1,i,j-1,k) lhs(2,2,aa,i,j,k) = - tmp2 * fjac(2,2,i,j-1,k) > - tmp1 * njac(2,2,i,j-1,k) > - tmp1 * dy2 lhs(2,3,aa,i,j,k) = - tmp2 * fjac(2,3,i,j-1,k) > - tmp1 * njac(2,3,i,j-1,k) lhs(2,4,aa,i,j,k) = - tmp2 * fjac(2,4,i,j-1,k) > - tmp1 * njac(2,4,i,j-1,k) lhs(2,5,aa,i,j,k) = - tmp2 * fjac(2,5,i,j-1,k) > - tmp1 * njac(2,5,i,j-1,k) lhs(3,1,aa,i,j,k) = - tmp2 * fjac(3,1,i,j-1,k) > - tmp1 * njac(3,1,i,j-1,k) lhs(3,2,aa,i,j,k) = - tmp2 * fjac(3,2,i,j-1,k) > - tmp1 * njac(3,2,i,j-1,k) lhs(3,3,aa,i,j,k) = - tmp2 * fjac(3,3,i,j-1,k) > - tmp1 * njac(3,3,i,j-1,k) > - tmp1 * dy3 lhs(3,4,aa,i,j,k) = - tmp2 * fjac(3,4,i,j-1,k) > - tmp1 * njac(3,4,i,j-1,k) lhs(3,5,aa,i,j,k) = - tmp2 * fjac(3,5,i,j-1,k) > - tmp1 * njac(3,5,i,j-1,k) lhs(4,1,aa,i,j,k) = - tmp2 * fjac(4,1,i,j-1,k) > - tmp1 * njac(4,1,i,j-1,k) lhs(4,2,aa,i,j,k) = - tmp2 * fjac(4,2,i,j-1,k) > - tmp1 * njac(4,2,i,j-1,k) lhs(4,3,aa,i,j,k) = - tmp2 * fjac(4,3,i,j-1,k) > - tmp1 * njac(4,3,i,j-1,k) lhs(4,4,aa,i,j,k) = - tmp2 * fjac(4,4,i,j-1,k) > - tmp1 * njac(4,4,i,j-1,k) > - tmp1 * dy4 lhs(4,5,aa,i,j,k) = - tmp2 * fjac(4,5,i,j-1,k) > - tmp1 * njac(4,5,i,j-1,k) lhs(5,1,aa,i,j,k) = - tmp2 * fjac(5,1,i,j-1,k) > - tmp1 * njac(5,1,i,j-1,k) lhs(5,2,aa,i,j,k) = - tmp2 * fjac(5,2,i,j-1,k) > - tmp1 * njac(5,2,i,j-1,k) lhs(5,3,aa,i,j,k) = - tmp2 * fjac(5,3,i,j-1,k) > - tmp1 * njac(5,3,i,j-1,k) lhs(5,4,aa,i,j,k) = - tmp2 * fjac(5,4,i,j-1,k) > - tmp1 * njac(5,4,i,j-1,k) lhs(5,5,aa,i,j,k) = - tmp2 * fjac(5,5,i,j-1,k) > - tmp1 * njac(5,5,i,j-1,k) > - tmp1 * dy5 lhs(1,1,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(1,1,i,j,k) > + tmp1 * 2.0d+00 * dy1 lhs(1,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,2,i,j,k) lhs(1,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,3,i,j,k) lhs(1,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,4,i,j,k) lhs(1,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,5,i,j,k) lhs(2,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,1,i,j,k) lhs(2,2,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(2,2,i,j,k) > + tmp1 * 2.0d+00 * dy2 lhs(2,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,3,i,j,k) lhs(2,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,4,i,j,k) lhs(2,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,5,i,j,k) lhs(3,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,1,i,j,k) lhs(3,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,2,i,j,k) lhs(3,3,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(3,3,i,j,k) > + tmp1 * 2.0d+00 * dy3 lhs(3,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,4,i,j,k) lhs(3,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,5,i,j,k) lhs(4,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,1,i,j,k) lhs(4,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,2,i,j,k) lhs(4,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,3,i,j,k) lhs(4,4,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(4,4,i,j,k) > + tmp1 * 2.0d+00 * dy4 lhs(4,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,5,i,j,k) lhs(5,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,1,i,j,k) lhs(5,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,2,i,j,k) lhs(5,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,3,i,j,k) lhs(5,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,4,i,j,k) lhs(5,5,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(5,5,i,j,k) > + tmp1 * 2.0d+00 * dy5 lhs(1,1,cc,i,j,k) = tmp2 * fjac(1,1,i,j+1,k) > - tmp1 * njac(1,1,i,j+1,k) > - tmp1 * dy1 lhs(1,2,cc,i,j,k) = tmp2 * fjac(1,2,i,j+1,k) > - tmp1 * njac(1,2,i,j+1,k) lhs(1,3,cc,i,j,k) = tmp2 * fjac(1,3,i,j+1,k) > - tmp1 * njac(1,3,i,j+1,k) lhs(1,4,cc,i,j,k) = tmp2 * fjac(1,4,i,j+1,k) > - tmp1 * njac(1,4,i,j+1,k) lhs(1,5,cc,i,j,k) = tmp2 * fjac(1,5,i,j+1,k) > - tmp1 * njac(1,5,i,j+1,k) lhs(2,1,cc,i,j,k) = tmp2 * fjac(2,1,i,j+1,k) > - tmp1 * njac(2,1,i,j+1,k) lhs(2,2,cc,i,j,k) = tmp2 * fjac(2,2,i,j+1,k) > - tmp1 * njac(2,2,i,j+1,k) > - tmp1 * dy2 lhs(2,3,cc,i,j,k) = tmp2 * fjac(2,3,i,j+1,k) > - tmp1 * njac(2,3,i,j+1,k) lhs(2,4,cc,i,j,k) = tmp2 * fjac(2,4,i,j+1,k) > - tmp1 * njac(2,4,i,j+1,k) lhs(2,5,cc,i,j,k) = tmp2 * fjac(2,5,i,j+1,k) > - tmp1 * njac(2,5,i,j+1,k) lhs(3,1,cc,i,j,k) = tmp2 * fjac(3,1,i,j+1,k) > - tmp1 * njac(3,1,i,j+1,k) lhs(3,2,cc,i,j,k) = tmp2 * fjac(3,2,i,j+1,k) > - tmp1 * njac(3,2,i,j+1,k) lhs(3,3,cc,i,j,k) = tmp2 * fjac(3,3,i,j+1,k) > - tmp1 * njac(3,3,i,j+1,k) > - tmp1 * dy3 lhs(3,4,cc,i,j,k) = tmp2 * fjac(3,4,i,j+1,k) > - tmp1 * njac(3,4,i,j+1,k) lhs(3,5,cc,i,j,k) = tmp2 * fjac(3,5,i,j+1,k) > - tmp1 * njac(3,5,i,j+1,k) lhs(4,1,cc,i,j,k) = tmp2 * fjac(4,1,i,j+1,k) > - tmp1 * njac(4,1,i,j+1,k) lhs(4,2,cc,i,j,k) = tmp2 * fjac(4,2,i,j+1,k) > - tmp1 * njac(4,2,i,j+1,k) lhs(4,3,cc,i,j,k) = tmp2 * fjac(4,3,i,j+1,k) > - tmp1 * njac(4,3,i,j+1,k) lhs(4,4,cc,i,j,k) = tmp2 * fjac(4,4,i,j+1,k) > - tmp1 * njac(4,4,i,j+1,k) > - tmp1 * dy4 lhs(4,5,cc,i,j,k) = tmp2 * fjac(4,5,i,j+1,k) > - tmp1 * njac(4,5,i,j+1,k) lhs(5,1,cc,i,j,k) = tmp2 * fjac(5,1,i,j+1,k) > - tmp1 * njac(5,1,i,j+1,k) lhs(5,2,cc,i,j,k) = tmp2 * fjac(5,2,i,j+1,k) > - tmp1 * njac(5,2,i,j+1,k) lhs(5,3,cc,i,j,k) = tmp2 * fjac(5,3,i,j+1,k) > - tmp1 * njac(5,3,i,j+1,k) lhs(5,4,cc,i,j,k) = tmp2 * fjac(5,4,i,j+1,k) > - tmp1 * njac(5,4,i,j+1,k) lhs(5,5,cc,i,j,k) = tmp2 * fjac(5,5,i,j+1,k) > - tmp1 * njac(5,5,i,j+1,k) > - tmp1 * dy5 enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine lhsz c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c This function computes the left hand side for the three z-factors c--------------------------------------------------------------------- include 'header.h' integer i, j, k c--------------------------------------------------------------------- c Compute the indices for storing the block-diagonal matrix; c determine c (labeled f) and s jacobians c--------------------------------------------------------------------- do k = 0, grid_points(3)-1 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 tmp1 = 1.0d+00 / u(1,i,j,k) tmp2 = tmp1 * tmp1 tmp3 = tmp1 * tmp2 fjac(1,1,i,j,k) = 0.0d+00 fjac(1,2,i,j,k) = 0.0d+00 fjac(1,3,i,j,k) = 0.0d+00 fjac(1,4,i,j,k) = 1.0d+00 fjac(1,5,i,j,k) = 0.0d+00 fjac(2,1,i,j,k) = - ( u(2,i,j,k)*u(4,i,j,k) ) > * tmp2 fjac(2,2,i,j,k) = u(4,i,j,k) * tmp1 fjac(2,3,i,j,k) = 0.0d+00 fjac(2,4,i,j,k) = u(2,i,j,k) * tmp1 fjac(2,5,i,j,k) = 0.0d+00 fjac(3,1,i,j,k) = - ( u(3,i,j,k)*u(4,i,j,k) ) > * tmp2 fjac(3,2,i,j,k) = 0.0d+00 fjac(3,3,i,j,k) = u(4,i,j,k) * tmp1 fjac(3,4,i,j,k) = u(3,i,j,k) * tmp1 fjac(3,5,i,j,k) = 0.0d+00 fjac(4,1,i,j,k) = - (u(4,i,j,k)*u(4,i,j,k) * tmp2 ) > + 0.50d+00 * c2 * ( ( u(2,i,j,k) * u(2,i,j,k) > + u(3,i,j,k) * u(3,i,j,k) > + u(4,i,j,k) * u(4,i,j,k) ) * tmp2 ) fjac(4,2,i,j,k) = - c2 * u(2,i,j,k) * tmp1 fjac(4,3,i,j,k) = - c2 * u(3,i,j,k) * tmp1 fjac(4,4,i,j,k) = ( 2.0d+00 - c2 ) > * u(4,i,j,k) * tmp1 fjac(4,5,i,j,k) = c2 fjac(5,1,i,j,k) = ( c2 * ( u(2,i,j,k) * u(2,i,j,k) > + u(3,i,j,k) * u(3,i,j,k) > + u(4,i,j,k) * u(4,i,j,k) ) > * tmp2 > - c1 * ( u(5,i,j,k) * tmp1 ) ) > * ( u(4,i,j,k) * tmp1 ) fjac(5,2,i,j,k) = - c2 * ( u(2,i,j,k)*u(4,i,j,k) ) > * tmp2 fjac(5,3,i,j,k) = - c2 * ( u(3,i,j,k)*u(4,i,j,k) ) > * tmp2 fjac(5,4,i,j,k) = c1 * ( u(5,i,j,k) * tmp1 ) > - 0.50d+00 * c2 > * ( ( u(2,i,j,k)*u(2,i,j,k) > + u(3,i,j,k)*u(3,i,j,k) > + 3.0d+00*u(4,i,j,k)*u(4,i,j,k) ) > * tmp2 ) fjac(5,5,i,j,k) = c1 * u(4,i,j,k) * tmp1 njac(1,1,i,j,k) = 0.0d+00 njac(1,2,i,j,k) = 0.0d+00 njac(1,3,i,j,k) = 0.0d+00 njac(1,4,i,j,k) = 0.0d+00 njac(1,5,i,j,k) = 0.0d+00 njac(2,1,i,j,k) = - c3c4 * tmp2 * u(2,i,j,k) njac(2,2,i,j,k) = c3c4 * tmp1 njac(2,3,i,j,k) = 0.0d+00 njac(2,4,i,j,k) = 0.0d+00 njac(2,5,i,j,k) = 0.0d+00 njac(3,1,i,j,k) = - c3c4 * tmp2 * u(3,i,j,k) njac(3,2,i,j,k) = 0.0d+00 njac(3,3,i,j,k) = c3c4 * tmp1 njac(3,4,i,j,k) = 0.0d+00 njac(3,5,i,j,k) = 0.0d+00 njac(4,1,i,j,k) = - con43 * c3c4 * tmp2 * u(4,i,j,k) njac(4,2,i,j,k) = 0.0d+00 njac(4,3,i,j,k) = 0.0d+00 njac(4,4,i,j,k) = con43 * c3 * c4 * tmp1 njac(4,5,i,j,k) = 0.0d+00 njac(5,1,i,j,k) = - ( c3c4 > - c1345 ) * tmp3 * (u(2,i,j,k)**2) > - ( c3c4 - c1345 ) * tmp3 * (u(3,i,j,k)**2) > - ( con43 * c3c4 > - c1345 ) * tmp3 * (u(4,i,j,k)**2) > - c1345 * tmp2 * u(5,i,j,k) njac(5,2,i,j,k) = ( c3c4 - c1345 ) * tmp2 * u(2,i,j,k) njac(5,3,i,j,k) = ( c3c4 - c1345 ) * tmp2 * u(3,i,j,k) njac(5,4,i,j,k) = ( con43 * c3c4 > - c1345 ) * tmp2 * u(4,i,j,k) njac(5,5,i,j,k) = ( c1345 )* tmp1 enddo enddo enddo c--------------------------------------------------------------------- c now jacobians set, so form left hand side in z direction c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 tmp1 = dt * tz1 tmp2 = dt * tz2 lhs(1,1,aa,i,j,k) = - tmp2 * fjac(1,1,i,j,k-1) > - tmp1 * njac(1,1,i,j,k-1) > - tmp1 * dz1 lhs(1,2,aa,i,j,k) = - tmp2 * fjac(1,2,i,j,k-1) > - tmp1 * njac(1,2,i,j,k-1) lhs(1,3,aa,i,j,k) = - tmp2 * fjac(1,3,i,j,k-1) > - tmp1 * njac(1,3,i,j,k-1) lhs(1,4,aa,i,j,k) = - tmp2 * fjac(1,4,i,j,k-1) > - tmp1 * njac(1,4,i,j,k-1) lhs(1,5,aa,i,j,k) = - tmp2 * fjac(1,5,i,j,k-1) > - tmp1 * njac(1,5,i,j,k-1) lhs(2,1,aa,i,j,k) = - tmp2 * fjac(2,1,i,j,k-1) > - tmp1 * njac(2,1,i,j,k-1) lhs(2,2,aa,i,j,k) = - tmp2 * fjac(2,2,i,j,k-1) > - tmp1 * njac(2,2,i,j,k-1) > - tmp1 * dz2 lhs(2,3,aa,i,j,k) = - tmp2 * fjac(2,3,i,j,k-1) > - tmp1 * njac(2,3,i,j,k-1) lhs(2,4,aa,i,j,k) = - tmp2 * fjac(2,4,i,j,k-1) > - tmp1 * njac(2,4,i,j,k-1) lhs(2,5,aa,i,j,k) = - tmp2 * fjac(2,5,i,j,k-1) > - tmp1 * njac(2,5,i,j,k-1) lhs(3,1,aa,i,j,k) = - tmp2 * fjac(3,1,i,j,k-1) > - tmp1 * njac(3,1,i,j,k-1) lhs(3,2,aa,i,j,k) = - tmp2 * fjac(3,2,i,j,k-1) > - tmp1 * njac(3,2,i,j,k-1) lhs(3,3,aa,i,j,k) = - tmp2 * fjac(3,3,i,j,k-1) > - tmp1 * njac(3,3,i,j,k-1) > - tmp1 * dz3 lhs(3,4,aa,i,j,k) = - tmp2 * fjac(3,4,i,j,k-1) > - tmp1 * njac(3,4,i,j,k-1) lhs(3,5,aa,i,j,k) = - tmp2 * fjac(3,5,i,j,k-1) > - tmp1 * njac(3,5,i,j,k-1) lhs(4,1,aa,i,j,k) = - tmp2 * fjac(4,1,i,j,k-1) > - tmp1 * njac(4,1,i,j,k-1) lhs(4,2,aa,i,j,k) = - tmp2 * fjac(4,2,i,j,k-1) > - tmp1 * njac(4,2,i,j,k-1) lhs(4,3,aa,i,j,k) = - tmp2 * fjac(4,3,i,j,k-1) > - tmp1 * njac(4,3,i,j,k-1) lhs(4,4,aa,i,j,k) = - tmp2 * fjac(4,4,i,j,k-1) > - tmp1 * njac(4,4,i,j,k-1) > - tmp1 * dz4 lhs(4,5,aa,i,j,k) = - tmp2 * fjac(4,5,i,j,k-1) > - tmp1 * njac(4,5,i,j,k-1) lhs(5,1,aa,i,j,k) = - tmp2 * fjac(5,1,i,j,k-1) > - tmp1 * njac(5,1,i,j,k-1) lhs(5,2,aa,i,j,k) = - tmp2 * fjac(5,2,i,j,k-1) > - tmp1 * njac(5,2,i,j,k-1) lhs(5,3,aa,i,j,k) = - tmp2 * fjac(5,3,i,j,k-1) > - tmp1 * njac(5,3,i,j,k-1) lhs(5,4,aa,i,j,k) = - tmp2 * fjac(5,4,i,j,k-1) > - tmp1 * njac(5,4,i,j,k-1) lhs(5,5,aa,i,j,k) = - tmp2 * fjac(5,5,i,j,k-1) > - tmp1 * njac(5,5,i,j,k-1) > - tmp1 * dz5 lhs(1,1,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(1,1,i,j,k) > + tmp1 * 2.0d+00 * dz1 lhs(1,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,2,i,j,k) lhs(1,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,3,i,j,k) lhs(1,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,4,i,j,k) lhs(1,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(1,5,i,j,k) lhs(2,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,1,i,j,k) lhs(2,2,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(2,2,i,j,k) > + tmp1 * 2.0d+00 * dz2 lhs(2,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,3,i,j,k) lhs(2,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,4,i,j,k) lhs(2,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(2,5,i,j,k) lhs(3,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,1,i,j,k) lhs(3,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,2,i,j,k) lhs(3,3,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(3,3,i,j,k) > + tmp1 * 2.0d+00 * dz3 lhs(3,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,4,i,j,k) lhs(3,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(3,5,i,j,k) lhs(4,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,1,i,j,k) lhs(4,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,2,i,j,k) lhs(4,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,3,i,j,k) lhs(4,4,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(4,4,i,j,k) > + tmp1 * 2.0d+00 * dz4 lhs(4,5,bb,i,j,k) = tmp1 * 2.0d+00 * njac(4,5,i,j,k) lhs(5,1,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,1,i,j,k) lhs(5,2,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,2,i,j,k) lhs(5,3,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,3,i,j,k) lhs(5,4,bb,i,j,k) = tmp1 * 2.0d+00 * njac(5,4,i,j,k) lhs(5,5,bb,i,j,k) = 1.0d+00 > + tmp1 * 2.0d+00 * njac(5,5,i,j,k) > + tmp1 * 2.0d+00 * dz5 lhs(1,1,cc,i,j,k) = tmp2 * fjac(1,1,i,j,k+1) > - tmp1 * njac(1,1,i,j,k+1) > - tmp1 * dz1 lhs(1,2,cc,i,j,k) = tmp2 * fjac(1,2,i,j,k+1) > - tmp1 * njac(1,2,i,j,k+1) lhs(1,3,cc,i,j,k) = tmp2 * fjac(1,3,i,j,k+1) > - tmp1 * njac(1,3,i,j,k+1) lhs(1,4,cc,i,j,k) = tmp2 * fjac(1,4,i,j,k+1) > - tmp1 * njac(1,4,i,j,k+1) lhs(1,5,cc,i,j,k) = tmp2 * fjac(1,5,i,j,k+1) > - tmp1 * njac(1,5,i,j,k+1) lhs(2,1,cc,i,j,k) = tmp2 * fjac(2,1,i,j,k+1) > - tmp1 * njac(2,1,i,j,k+1) lhs(2,2,cc,i,j,k) = tmp2 * fjac(2,2,i,j,k+1) > - tmp1 * njac(2,2,i,j,k+1) > - tmp1 * dz2 lhs(2,3,cc,i,j,k) = tmp2 * fjac(2,3,i,j,k+1) > - tmp1 * njac(2,3,i,j,k+1) lhs(2,4,cc,i,j,k) = tmp2 * fjac(2,4,i,j,k+1) > - tmp1 * njac(2,4,i,j,k+1) lhs(2,5,cc,i,j,k) = tmp2 * fjac(2,5,i,j,k+1) > - tmp1 * njac(2,5,i,j,k+1) lhs(3,1,cc,i,j,k) = tmp2 * fjac(3,1,i,j,k+1) > - tmp1 * njac(3,1,i,j,k+1) lhs(3,2,cc,i,j,k) = tmp2 * fjac(3,2,i,j,k+1) > - tmp1 * njac(3,2,i,j,k+1) lhs(3,3,cc,i,j,k) = tmp2 * fjac(3,3,i,j,k+1) > - tmp1 * njac(3,3,i,j,k+1) > - tmp1 * dz3 lhs(3,4,cc,i,j,k) = tmp2 * fjac(3,4,i,j,k+1) > - tmp1 * njac(3,4,i,j,k+1) lhs(3,5,cc,i,j,k) = tmp2 * fjac(3,5,i,j,k+1) > - tmp1 * njac(3,5,i,j,k+1) lhs(4,1,cc,i,j,k) = tmp2 * fjac(4,1,i,j,k+1) > - tmp1 * njac(4,1,i,j,k+1) lhs(4,2,cc,i,j,k) = tmp2 * fjac(4,2,i,j,k+1) > - tmp1 * njac(4,2,i,j,k+1) lhs(4,3,cc,i,j,k) = tmp2 * fjac(4,3,i,j,k+1) > - tmp1 * njac(4,3,i,j,k+1) lhs(4,4,cc,i,j,k) = tmp2 * fjac(4,4,i,j,k+1) > - tmp1 * njac(4,4,i,j,k+1) > - tmp1 * dz4 lhs(4,5,cc,i,j,k) = tmp2 * fjac(4,5,i,j,k+1) > - tmp1 * njac(4,5,i,j,k+1) lhs(5,1,cc,i,j,k) = tmp2 * fjac(5,1,i,j,k+1) > - tmp1 * njac(5,1,i,j,k+1) lhs(5,2,cc,i,j,k) = tmp2 * fjac(5,2,i,j,k+1) > - tmp1 * njac(5,2,i,j,k+1) lhs(5,3,cc,i,j,k) = tmp2 * fjac(5,3,i,j,k+1) > - tmp1 * njac(5,3,i,j,k+1) lhs(5,4,cc,i,j,k) = tmp2 * fjac(5,4,i,j,k+1) > - tmp1 * njac(5,4,i,j,k+1) lhs(5,5,cc,i,j,k) = tmp2 * fjac(5,5,i,j,k+1) > - tmp1 * njac(5,5,i,j,k+1) > - tmp1 * dz5 enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine compute_rhs c--------------------------------------------------------------------- c--------------------------------------------------------------------- include 'header.h' integer i, j, k, m double precision rho_inv, uijk, up1, um1, vijk, vp1, vm1, > wijk, wp1, wm1 c--------------------------------------------------------------------- c compute the reciprocal of density, and the kinetic energy, c and the speed of sound. c--------------------------------------------------------------------- do k = 0, grid_points(3)-1 do j = 0, grid_points(2)-1 do i = 0, grid_points(1)-1 rho_inv = 1.0d0/u(1,i,j,k) rho_i(i,j,k) = rho_inv us(i,j,k) = u(2,i,j,k) * rho_inv vs(i,j,k) = u(3,i,j,k) * rho_inv ws(i,j,k) = u(4,i,j,k) * rho_inv square(i,j,k) = 0.5d0* ( > u(2,i,j,k)*u(2,i,j,k) + > u(3,i,j,k)*u(3,i,j,k) + > u(4,i,j,k)*u(4,i,j,k) ) * rho_inv qs(i,j,k) = square(i,j,k) * rho_inv enddo enddo enddo c--------------------------------------------------------------------- c copy the exact forcing term to the right hand side; because c this forcing term is known, we can store it on the whole grid c including the boundary c--------------------------------------------------------------------- do k = 0, grid_points(3)-1 do j = 0, grid_points(2)-1 do i = 0, grid_points(1)-1 do m = 1, 5 rhs(m,i,j,k) = forcing(i,j,k,m) enddo enddo enddo enddo c--------------------------------------------------------------------- c compute xi-direction fluxes c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 uijk = us(i,j,k) up1 = us(i+1,j,k) um1 = us(i-1,j,k) rhs(1,i,j,k) = rhs(1,i,j,k) + dx1tx1 * > (u(1,i+1,j,k) - 2.0d0*u(1,i,j,k) + > u(1,i-1,j,k)) - > tx2 * (u(2,i+1,j,k) - u(2,i-1,j,k)) rhs(2,i,j,k) = rhs(2,i,j,k) + dx2tx1 * > (u(2,i+1,j,k) - 2.0d0*u(2,i,j,k) + > u(2,i-1,j,k)) + > xxcon2*con43 * (up1 - 2.0d0*uijk + um1) - > tx2 * (u(2,i+1,j,k)*up1 - > u(2,i-1,j,k)*um1 + > (u(5,i+1,j,k)- square(i+1,j,k)- > u(5,i-1,j,k)+ square(i-1,j,k))* > c2) rhs(3,i,j,k) = rhs(3,i,j,k) + dx3tx1 * > (u(3,i+1,j,k) - 2.0d0*u(3,i,j,k) + > u(3,i-1,j,k)) + > xxcon2 * (vs(i+1,j,k) - 2.0d0*vs(i,j,k) + > vs(i-1,j,k)) - > tx2 * (u(3,i+1,j,k)*up1 - > u(3,i-1,j,k)*um1) rhs(4,i,j,k) = rhs(4,i,j,k) + dx4tx1 * > (u(4,i+1,j,k) - 2.0d0*u(4,i,j,k) + > u(4,i-1,j,k)) + > xxcon2 * (ws(i+1,j,k) - 2.0d0*ws(i,j,k) + > ws(i-1,j,k)) - > tx2 * (u(4,i+1,j,k)*up1 - > u(4,i-1,j,k)*um1) rhs(5,i,j,k) = rhs(5,i,j,k) + dx5tx1 * > (u(5,i+1,j,k) - 2.0d0*u(5,i,j,k) + > u(5,i-1,j,k)) + > xxcon3 * (qs(i+1,j,k) - 2.0d0*qs(i,j,k) + > qs(i-1,j,k)) + > xxcon4 * (up1*up1 - 2.0d0*uijk*uijk + > um1*um1) + > xxcon5 * (u(5,i+1,j,k)*rho_i(i+1,j,k) - > 2.0d0*u(5,i,j,k)*rho_i(i,j,k) + > u(5,i-1,j,k)*rho_i(i-1,j,k)) - > tx2 * ( (c1*u(5,i+1,j,k) - > c2*square(i+1,j,k))*up1 - > (c1*u(5,i-1,j,k) - > c2*square(i-1,j,k))*um1 ) enddo enddo enddo c--------------------------------------------------------------------- c add fourth order xi-direction dissipation c--------------------------------------------------------------------- i = 1 do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k)- dssp * > ( 5.0d0*u(m,i,j,k) - 4.0d0*u(m,i+1,j,k) + > u(m,i+2,j,k)) enddo enddo enddo i = 2 do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > (-4.0d0*u(m,i-1,j,k) + 6.0d0*u(m,i,j,k) - > 4.0d0*u(m,i+1,j,k) + u(m,i+2,j,k)) enddo enddo enddo do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 3,grid_points(1)-4 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i-2,j,k) - 4.0d0*u(m,i-1,j,k) + > 6.0*u(m,i,j,k) - 4.0d0*u(m,i+1,j,k) + > u(m,i+2,j,k) ) enddo enddo enddo enddo i = grid_points(1)-3 do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i-2,j,k) - 4.0d0*u(m,i-1,j,k) + > 6.0d0*u(m,i,j,k) - 4.0d0*u(m,i+1,j,k) ) enddo enddo enddo i = grid_points(1)-2 do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i-2,j,k) - 4.d0*u(m,i-1,j,k) + > 5.d0*u(m,i,j,k) ) enddo enddo enddo c--------------------------------------------------------------------- c compute eta-direction fluxes c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 vijk = vs(i,j,k) vp1 = vs(i,j+1,k) vm1 = vs(i,j-1,k) rhs(1,i,j,k) = rhs(1,i,j,k) + dy1ty1 * > (u(1,i,j+1,k) - 2.0d0*u(1,i,j,k) + > u(1,i,j-1,k)) - > ty2 * (u(3,i,j+1,k) - u(3,i,j-1,k)) rhs(2,i,j,k) = rhs(2,i,j,k) + dy2ty1 * > (u(2,i,j+1,k) - 2.0d0*u(2,i,j,k) + > u(2,i,j-1,k)) + > yycon2 * (us(i,j+1,k) - 2.0d0*us(i,j,k) + > us(i,j-1,k)) - > ty2 * (u(2,i,j+1,k)*vp1 - > u(2,i,j-1,k)*vm1) rhs(3,i,j,k) = rhs(3,i,j,k) + dy3ty1 * > (u(3,i,j+1,k) - 2.0d0*u(3,i,j,k) + > u(3,i,j-1,k)) + > yycon2*con43 * (vp1 - 2.0d0*vijk + vm1) - > ty2 * (u(3,i,j+1,k)*vp1 - > u(3,i,j-1,k)*vm1 + > (u(5,i,j+1,k) - square(i,j+1,k) - > u(5,i,j-1,k) + square(i,j-1,k)) > *c2) rhs(4,i,j,k) = rhs(4,i,j,k) + dy4ty1 * > (u(4,i,j+1,k) - 2.0d0*u(4,i,j,k) + > u(4,i,j-1,k)) + > yycon2 * (ws(i,j+1,k) - 2.0d0*ws(i,j,k) + > ws(i,j-1,k)) - > ty2 * (u(4,i,j+1,k)*vp1 - > u(4,i,j-1,k)*vm1) rhs(5,i,j,k) = rhs(5,i,j,k) + dy5ty1 * > (u(5,i,j+1,k) - 2.0d0*u(5,i,j,k) + > u(5,i,j-1,k)) + > yycon3 * (qs(i,j+1,k) - 2.0d0*qs(i,j,k) + > qs(i,j-1,k)) + > yycon4 * (vp1*vp1 - 2.0d0*vijk*vijk + > vm1*vm1) + > yycon5 * (u(5,i,j+1,k)*rho_i(i,j+1,k) - > 2.0d0*u(5,i,j,k)*rho_i(i,j,k) + > u(5,i,j-1,k)*rho_i(i,j-1,k)) - > ty2 * ((c1*u(5,i,j+1,k) - > c2*square(i,j+1,k)) * vp1 - > (c1*u(5,i,j-1,k) - > c2*square(i,j-1,k)) * vm1) enddo enddo enddo c--------------------------------------------------------------------- c add fourth order eta-direction dissipation c--------------------------------------------------------------------- j = 1 do k = 1, grid_points(3)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k)- dssp * > ( 5.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j+1,k) + > u(m,i,j+2,k)) enddo enddo enddo j = 2 do k = 1, grid_points(3)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > (-4.0d0*u(m,i,j-1,k) + 6.0d0*u(m,i,j,k) - > 4.0d0*u(m,i,j+1,k) + u(m,i,j+2,k)) enddo enddo enddo do k = 1, grid_points(3)-2 do j = 3, grid_points(2)-4 do i = 1,grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i,j-2,k) - 4.0d0*u(m,i,j-1,k) + > 6.0*u(m,i,j,k) - 4.0d0*u(m,i,j+1,k) + > u(m,i,j+2,k) ) enddo enddo enddo enddo j = grid_points(2)-3 do k = 1, grid_points(3)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i,j-2,k) - 4.0d0*u(m,i,j-1,k) + > 6.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j+1,k) ) enddo enddo enddo j = grid_points(2)-2 do k = 1, grid_points(3)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i,j-2,k) - 4.d0*u(m,i,j-1,k) + > 5.d0*u(m,i,j,k) ) enddo enddo enddo c--------------------------------------------------------------------- c compute zeta-direction fluxes c--------------------------------------------------------------------- do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 wijk = ws(i,j,k) wp1 = ws(i,j,k+1) wm1 = ws(i,j,k-1) rhs(1,i,j,k) = rhs(1,i,j,k) + dz1tz1 * > (u(1,i,j,k+1) - 2.0d0*u(1,i,j,k) + > u(1,i,j,k-1)) - > tz2 * (u(4,i,j,k+1) - u(4,i,j,k-1)) rhs(2,i,j,k) = rhs(2,i,j,k) + dz2tz1 * > (u(2,i,j,k+1) - 2.0d0*u(2,i,j,k) + > u(2,i,j,k-1)) + > zzcon2 * (us(i,j,k+1) - 2.0d0*us(i,j,k) + > us(i,j,k-1)) - > tz2 * (u(2,i,j,k+1)*wp1 - > u(2,i,j,k-1)*wm1) rhs(3,i,j,k) = rhs(3,i,j,k) + dz3tz1 * > (u(3,i,j,k+1) - 2.0d0*u(3,i,j,k) + > u(3,i,j,k-1)) + > zzcon2 * (vs(i,j,k+1) - 2.0d0*vs(i,j,k) + > vs(i,j,k-1)) - > tz2 * (u(3,i,j,k+1)*wp1 - > u(3,i,j,k-1)*wm1) rhs(4,i,j,k) = rhs(4,i,j,k) + dz4tz1 * > (u(4,i,j,k+1) - 2.0d0*u(4,i,j,k) + > u(4,i,j,k-1)) + > zzcon2*con43 * (wp1 - 2.0d0*wijk + wm1) - > tz2 * (u(4,i,j,k+1)*wp1 - > u(4,i,j,k-1)*wm1 + > (u(5,i,j,k+1) - square(i,j,k+1) - > u(5,i,j,k-1) + square(i,j,k-1)) > *c2) rhs(5,i,j,k) = rhs(5,i,j,k) + dz5tz1 * > (u(5,i,j,k+1) - 2.0d0*u(5,i,j,k) + > u(5,i,j,k-1)) + > zzcon3 * (qs(i,j,k+1) - 2.0d0*qs(i,j,k) + > qs(i,j,k-1)) + > zzcon4 * (wp1*wp1 - 2.0d0*wijk*wijk + > wm1*wm1) + > zzcon5 * (u(5,i,j,k+1)*rho_i(i,j,k+1) - > 2.0d0*u(5,i,j,k)*rho_i(i,j,k) + > u(5,i,j,k-1)*rho_i(i,j,k-1)) - > tz2 * ( (c1*u(5,i,j,k+1) - > c2*square(i,j,k+1))*wp1 - > (c1*u(5,i,j,k-1) - > c2*square(i,j,k-1))*wm1) enddo enddo enddo c--------------------------------------------------------------------- c add fourth order zeta-direction dissipation c--------------------------------------------------------------------- k = 1 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k)- dssp * > ( 5.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j,k+1) + > u(m,i,j,k+2)) enddo enddo enddo k = 2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > (-4.0d0*u(m,i,j,k-1) + 6.0d0*u(m,i,j,k) - > 4.0d0*u(m,i,j,k+1) + u(m,i,j,k+2)) enddo enddo enddo do k = 3, grid_points(3)-4 do j = 1, grid_points(2)-2 do i = 1,grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i,j,k-2) - 4.0d0*u(m,i,j,k-1) + > 6.0*u(m,i,j,k) - 4.0d0*u(m,i,j,k+1) + > u(m,i,j,k+2) ) enddo enddo enddo enddo k = grid_points(3)-3 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i,j,k-2) - 4.0d0*u(m,i,j,k-1) + > 6.0d0*u(m,i,j,k) - 4.0d0*u(m,i,j,k+1) ) enddo enddo enddo k = grid_points(3)-2 do j = 1, grid_points(2)-2 do i = 1, grid_points(1)-2 do m = 1, 5 rhs(m,i,j,k) = rhs(m,i,j,k) - dssp * > ( u(m,i,j,k-2) - 4.d0*u(m,i,j,k-1) + > 5.d0*u(m,i,j,k) ) enddo enddo enddo do k = 1, grid_points(3)-2 do j = 1, grid_points(2)-2 do m = 1, 5 do i = 1, grid_points(1)-2 rhs(m,i,j,k) = rhs(m,i,j,k) * dt enddo enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine set_constants c--------------------------------------------------------------------- c--------------------------------------------------------------------- include 'header.h' ce(1,1) = 2.0d0 ce(1,2) = 0.0d0 ce(1,3) = 0.0d0 ce(1,4) = 4.0d0 ce(1,5) = 5.0d0 ce(1,6) = 3.0d0 ce(1,7) = 0.5d0 ce(1,8) = 0.02d0 ce(1,9) = 0.01d0 ce(1,10) = 0.03d0 ce(1,11) = 0.5d0 ce(1,12) = 0.4d0 ce(1,13) = 0.3d0 ce(2,1) = 1.0d0 ce(2,2) = 0.0d0 ce(2,3) = 0.0d0 ce(2,4) = 0.0d0 ce(2,5) = 1.0d0 ce(2,6) = 2.0d0 ce(2,7) = 3.0d0 ce(2,8) = 0.01d0 ce(2,9) = 0.03d0 ce(2,10) = 0.02d0 ce(2,11) = 0.4d0 ce(2,12) = 0.3d0 ce(2,13) = 0.5d0 ce(3,1) = 2.0d0 ce(3,2) = 2.0d0 ce(3,3) = 0.0d0 ce(3,4) = 0.0d0 ce(3,5) = 0.0d0 ce(3,6) = 2.0d0 ce(3,7) = 3.0d0 ce(3,8) = 0.04d0 ce(3,9) = 0.03d0 ce(3,10) = 0.05d0 ce(3,11) = 0.3d0 ce(3,12) = 0.5d0 ce(3,13) = 0.4d0 ce(4,1) = 2.0d0 ce(4,2) = 2.0d0 ce(4,3) = 0.0d0 ce(4,4) = 0.0d0 ce(4,5) = 0.0d0 ce(4,6) = 2.0d0 ce(4,7) = 3.0d0 ce(4,8) = 0.03d0 ce(4,9) = 0.05d0 ce(4,10) = 0.04d0 ce(4,11) = 0.2d0 ce(4,12) = 0.1d0 ce(4,13) = 0.3d0 ce(5,1) = 5.0d0 ce(5,2) = 4.0d0 ce(5,3) = 3.0d0 ce(5,4) = 2.0d0 ce(5,5) = 0.1d0 ce(5,6) = 0.4d0 ce(5,7) = 0.3d0 ce(5,8) = 0.05d0 ce(5,9) = 0.04d0 ce(5,10) = 0.03d0 ce(5,11) = 0.1d0 ce(5,12) = 0.3d0 ce(5,13) = 0.2d0 c1 = 1.4d0 c2 = 0.4d0 c3 = 0.1d0 c4 = 1.0d0 c5 = 1.4d0 dnxm1 = 1.0d0 / dble(grid_points(1)-1) dnym1 = 1.0d0 / dble(grid_points(2)-1) dnzm1 = 1.0d0 / dble(grid_points(3)-1) c1c2 = c1 * c2 c1c5 = c1 * c5 c3c4 = c3 * c4 c1345 = c1c5 * c3c4 conz1 = (1.0d0-c1c5) tx1 = 1.0d0 / (dnxm1 * dnxm1) tx2 = 1.0d0 / (2.0d0 * dnxm1) tx3 = 1.0d0 / dnxm1 ty1 = 1.0d0 / (dnym1 * dnym1) ty2 = 1.0d0 / (2.0d0 * dnym1) ty3 = 1.0d0 / dnym1 tz1 = 1.0d0 / (dnzm1 * dnzm1) tz2 = 1.0d0 / (2.0d0 * dnzm1) tz3 = 1.0d0 / dnzm1 dx1 = 0.75d0 dx2 = 0.75d0 dx3 = 0.75d0 dx4 = 0.75d0 dx5 = 0.75d0 dy1 = 0.75d0 dy2 = 0.75d0 dy3 = 0.75d0 dy4 = 0.75d0 dy5 = 0.75d0 dz1 = 1.0d0 dz2 = 1.0d0 dz3 = 1.0d0 dz4 = 1.0d0 dz5 = 1.0d0 dxmax = dmax1(dx3, dx4) dymax = dmax1(dy2, dy4) dzmax = dmax1(dz2, dz3) dssp = 0.25d0 * dmax1(dx1, dmax1(dy1, dz1) ) c4dssp = 4.0d0 * dssp c5dssp = 5.0d0 * dssp dttx1 = dt*tx1 dttx2 = dt*tx2 dtty1 = dt*ty1 dtty2 = dt*ty2 dttz1 = dt*tz1 dttz2 = dt*tz2 c2dttx1 = 2.0d0*dttx1 c2dtty1 = 2.0d0*dtty1 c2dttz1 = 2.0d0*dttz1 dtdssp = dt*dssp comz1 = dtdssp comz4 = 4.0d0*dtdssp comz5 = 5.0d0*dtdssp comz6 = 6.0d0*dtdssp c3c4tx3 = c3c4*tx3 c3c4ty3 = c3c4*ty3 c3c4tz3 = c3c4*tz3 dx1tx1 = dx1*tx1 dx2tx1 = dx2*tx1 dx3tx1 = dx3*tx1 dx4tx1 = dx4*tx1 dx5tx1 = dx5*tx1 dy1ty1 = dy1*ty1 dy2ty1 = dy2*ty1 dy3ty1 = dy3*ty1 dy4ty1 = dy4*ty1 dy5ty1 = dy5*ty1 dz1tz1 = dz1*tz1 dz2tz1 = dz2*tz1 dz3tz1 = dz3*tz1 dz4tz1 = dz4*tz1 dz5tz1 = dz5*tz1 c2iv = 2.5d0 con43 = 4.0d0/3.0d0 con16 = 1.0d0/6.0d0 xxcon1 = c3c4tx3*con43*tx3 xxcon2 = c3c4tx3*tx3 xxcon3 = c3c4tx3*conz1*tx3 xxcon4 = c3c4tx3*con16*tx3 xxcon5 = c3c4tx3*c1c5*tx3 yycon1 = c3c4ty3*con43*ty3 yycon2 = c3c4ty3*ty3 yycon3 = c3c4ty3*conz1*ty3 yycon4 = c3c4ty3*con16*ty3 yycon5 = c3c4ty3*c1c5*ty3 zzcon1 = c3c4tz3*con43*tz3 zzcon2 = c3c4tz3*tz3 zzcon3 = c3c4tz3*conz1*tz3 zzcon4 = c3c4tz3*con16*tz3 zzcon5 = c3c4tz3*c1c5*tz3 return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine verify(no_time_steps, class, verified) c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c verification routine c--------------------------------------------------------------------- include 'header.h' double precision xcrref(5),xceref(5),xcrdif(5),xcedif(5), > epsilon, xce(5), xcr(5), dtref integer m, no_time_steps character class logical verified c--------------------------------------------------------------------- c tolerance level c--------------------------------------------------------------------- epsilon = 1.0d-08 c--------------------------------------------------------------------- c compute the error norm and the residual norm, and exit if not printing c--------------------------------------------------------------------- call error_norm(xce) call compute_rhs call rhs_norm(xcr) do m = 1, 5 xcr(m) = xcr(m) / dt enddo class = 'U' verified = .true. do m = 1,5 xcrref(m) = 1.0 xceref(m) = 1.0 end do c--------------------------------------------------------------------- c reference data for 12X12X12 grids after 100 time steps, with DT = 1.0d-02 c--------------------------------------------------------------------- if ( (grid_points(1) .eq. 12 ) .and. > (grid_points(2) .eq. 12 ) .and. > (grid_points(3) .eq. 12 ) .and. > (no_time_steps .eq. 60 )) then class = 'S' dtref = 1.0d-2 c--------------------------------------------------------------------- c Reference values of RMS-norms of residual. c--------------------------------------------------------------------- xcrref(1) = 1.7034283709541311d-01 xcrref(2) = 1.2975252070034097d-02 xcrref(3) = 3.2527926989486055d-02 xcrref(4) = 2.6436421275166801d-02 xcrref(5) = 1.9211784131744430d-01 c--------------------------------------------------------------------- c Reference values of RMS-norms of solution error. c--------------------------------------------------------------------- xceref(1) = 4.9976913345811579d-04 xceref(2) = 4.5195666782961927d-05 xceref(3) = 7.3973765172921357d-05 xceref(4) = 7.3821238632439731d-05 xceref(5) = 8.9269630987491446d-04 c--------------------------------------------------------------------- c reference data for 24X24X24 grids after 200 time steps, with DT = 0.8d-3 c--------------------------------------------------------------------- elseif ( (grid_points(1) .eq. 24) .and. > (grid_points(2) .eq. 24) .and. > (grid_points(3) .eq. 24) .and. > (no_time_steps . eq. 200) ) then class = 'W' dtref = 0.8d-3 c--------------------------------------------------------------------- c Reference values of RMS-norms of residual. c--------------------------------------------------------------------- xcrref(1) = 0.1125590409344d+03 xcrref(2) = 0.1180007595731d+02 xcrref(3) = 0.2710329767846d+02 xcrref(4) = 0.2469174937669d+02 xcrref(5) = 0.2638427874317d+03 c--------------------------------------------------------------------- c Reference values of RMS-norms of solution error. c--------------------------------------------------------------------- xceref(1) = 0.4419655736008d+01 xceref(2) = 0.4638531260002d+00 xceref(3) = 0.1011551749967d+01 xceref(4) = 0.9235878729944d+00 xceref(5) = 0.1018045837718d+02 c--------------------------------------------------------------------- c reference data for 64X64X64 grids after 200 time steps, with DT = 0.8d-3 c--------------------------------------------------------------------- elseif ( (grid_points(1) .eq. 64) .and. > (grid_points(2) .eq. 64) .and. > (grid_points(3) .eq. 64) .and. > (no_time_steps . eq. 200) ) then class = 'A' dtref = 0.8d-3 c--------------------------------------------------------------------- c Reference values of RMS-norms of residual. c--------------------------------------------------------------------- xcrref(1) = 1.0806346714637264d+02 xcrref(2) = 1.1319730901220813d+01 xcrref(3) = 2.5974354511582465d+01 xcrref(4) = 2.3665622544678910d+01 xcrref(5) = 2.5278963211748344d+02 c--------------------------------------------------------------------- c Reference values of RMS-norms of solution error. c--------------------------------------------------------------------- xceref(1) = 4.2348416040525025d+00 xceref(2) = 4.4390282496995698d-01 xceref(3) = 9.6692480136345650d-01 xceref(4) = 8.8302063039765474d-01 xceref(5) = 9.7379901770829278d+00 c--------------------------------------------------------------------- c reference data for 102X102X102 grids after 200 time steps, c with DT = 3.0d-04 c--------------------------------------------------------------------- elseif ( (grid_points(1) .eq. 102) .and. > (grid_points(2) .eq. 102) .and. > (grid_points(3) .eq. 102) .and. > (no_time_steps . eq. 200) ) then class = 'B' dtref = 3.0d-4 c--------------------------------------------------------------------- c Reference values of RMS-norms of residual. c--------------------------------------------------------------------- xcrref(1) = 1.4233597229287254d+03 xcrref(2) = 9.9330522590150238d+01 xcrref(3) = 3.5646025644535285d+02 xcrref(4) = 3.2485447959084092d+02 xcrref(5) = 3.2707541254659363d+03 c--------------------------------------------------------------------- c Reference values of RMS-norms of solution error. c--------------------------------------------------------------------- xceref(1) = 5.2969847140936856d+01 xceref(2) = 4.4632896115670668d+00 xceref(3) = 1.3122573342210174d+01 xceref(4) = 1.2006925323559144d+01 xceref(5) = 1.2459576151035986d+02 c--------------------------------------------------------------------- c reference data for 162X162X162 grids after 200 time steps, c with DT = 1.0d-04 c--------------------------------------------------------------------- elseif ( (grid_points(1) .eq. 162) .and. > (grid_points(2) .eq. 162) .and. > (grid_points(3) .eq. 162) .and. > (no_time_steps . eq. 200) ) then class = 'C' dtref = 1.0d-4 c--------------------------------------------------------------------- c Reference values of RMS-norms of residual. c--------------------------------------------------------------------- xcrref(1) = 0.62398116551764615d+04 xcrref(2) = 0.50793239190423964d+03 xcrref(3) = 0.15423530093013596d+04 xcrref(4) = 0.13302387929291190d+04 xcrref(5) = 0.11604087428436455d+05 c--------------------------------------------------------------------- c Reference values of RMS-norms of solution error. c--------------------------------------------------------------------- xceref(1) = 0.16462008369091265d+03 xceref(2) = 0.11497107903824313d+02 xceref(3) = 0.41207446207461508d+02 xceref(4) = 0.37087651059694167d+02 xceref(5) = 0.36211053051841265d+03 else verified = .false. endif c--------------------------------------------------------------------- c verification test for residuals if gridsize is either 12X12X12 or c 64X64X64 or 102X102X102 or 162X162X162 c--------------------------------------------------------------------- c--------------------------------------------------------------------- c Compute the difference of solution values and the known reference values. c--------------------------------------------------------------------- do m = 1, 5 xcrdif(m) = dabs((xcr(m)-xcrref(m))/xcrref(m)) xcedif(m) = dabs((xce(m)-xceref(m))/xceref(m)) enddo c--------------------------------------------------------------------- c Output the comparison of computed results to known cases. c--------------------------------------------------------------------- if (class .ne. 'U') then write(*, 1990) class 1990 format(' Verification being performed for class ', a) write (*,2000) epsilon 2000 format(' accuracy setting for epsilon = ', E20.13) if (dabs(dt-dtref) .gt. epsilon) then verified = .false. class = 'U' write (*,1000) dtref 1000 format(' DT does not match the reference value of ', > E15.8) endif else write(*, 1995) 1995 format(' Unknown class') endif if (class .ne. 'U') then write (*,2001) else write (*, 2005) endif 2001 format(' Comparison of RMS-norms of residual') 2005 format(' RMS-norms of residual') do m = 1, 5 if (class .eq. 'U') then write(*, 2015) m, xcr(m) else if (xcrdif(m) .gt. epsilon) then verified = .false. write (*,2010) m,xcr(m),xcrref(m),xcrdif(m) else write (*,2011) m,xcr(m),xcrref(m),xcrdif(m) endif enddo if (class .ne. 'U') then write (*,2002) else write (*,2006) endif 2002 format(' Comparison of RMS-norms of solution error') 2006 format(' RMS-norms of solution error') do m = 1, 5 if (class .eq. 'U') then write(*, 2015) m, xce(m) else if (xcedif(m) .gt. epsilon) then verified = .false. write (*,2010) m,xce(m),xceref(m),xcedif(m) else write (*,2011) m,xce(m),xceref(m),xcedif(m) endif enddo 2010 format(' FAILURE: ', i2, E20.13, E20.13, E20.13) 2011 format(' ', i2, E20.13, E20.13, E20.13) 2015 format(' ', i2, E20.13) if (class .eq. 'U') then write(*, 2022) write(*, 2023) 2022 format(' No reference values provided') 2023 format(' No verification performed') else if (verified) then write(*, 2020) 2020 format(' Verification Successful') else write(*, 2021) 2021 format(' Verification failed') endif return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine x_solve c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c c Performs line solves in X direction by first factoring c the block-tridiagonal matrix into an upper triangular matrix, c and then performing back substitution to solve for the unknow c vectors of each line. c c Make sure we treat elements zero to cell_size in the direction c of the sweep. c c--------------------------------------------------------------------- include 'header.h' call lhsx call x_solve_cell call x_backsubstitute return end subroutine x_backsubstitute c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c back solve: if last cell, then generate U(isize)=rhs(isize) c else assume U(isize) is loaded in un pack backsub_info c so just use it c after call u(istart) will be sent to next cell c--------------------------------------------------------------------- include 'header.h' integer i, j, k, m, n do k=1,grid_points(3)-2 do j=1,grid_points(2)-2 do i=grid_points(1)-2,0,-1 do m=1,BLOCK_SIZE do n=1,BLOCK_SIZE rhs(m,i,j,k) = rhs(m,i,j,k) > - lhs(m,n,cc,i,j,k)*rhs(n,i+1,j,k) enddo enddo enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine x_solve_cell c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c performs guaussian elimination on this cell. c c assumes that unpacking routines for non-first cells c preload C' and rhs' from previous cell. c c assumed send happens outside this routine, but that c c'(IMAX) and rhs'(IMAX) will be sent to next cell c--------------------------------------------------------------------- include 'header.h' integer i,j,k,isize isize = grid_points(1)-1 c--------------------------------------------------------------------- c outer most do loops - sweeping in i direction c--------------------------------------------------------------------- do k=1,grid_points(3)-2 do j=1,grid_points(2)-2 c--------------------------------------------------------------------- c multiply c(0,j,k) by b_inverse and copy back to c c multiply rhs(0) by b_inverse(0) and copy to rhs c--------------------------------------------------------------------- call binvcrhs( lhs(1,1,bb,0,j,k), > lhs(1,1,cc,0,j,k), > rhs(1,0,j,k) ) enddo enddo c--------------------------------------------------------------------- c begin inner most do loop c do all the elements of the cell unless last c--------------------------------------------------------------------- do k=1,grid_points(3)-2 do j=1,grid_points(2)-2 do i=1,isize-1 c--------------------------------------------------------------------- c rhs(i) = rhs(i) - A*rhs(i-1) c--------------------------------------------------------------------- call matvec_sub(lhs(1,1,aa,i,j,k), > rhs(1,i-1,j,k),rhs(1,i,j,k)) c--------------------------------------------------------------------- c B(i) = B(i) - C(i-1)*A(i) c--------------------------------------------------------------------- call matmul_sub(lhs(1,1,aa,i,j,k), > lhs(1,1,cc,i-1,j,k), > lhs(1,1,bb,i,j,k)) c--------------------------------------------------------------------- c multiply c(i,j,k) by b_inverse and copy back to c c multiply rhs(1,j,k) by b_inverse(1,j,k) and copy to rhs c--------------------------------------------------------------------- call binvcrhs( lhs(1,1,bb,i,j,k), > lhs(1,1,cc,i,j,k), > rhs(1,i,j,k) ) enddo enddo enddo do k=1,grid_points(3)-2 do j=1,grid_points(2)-2 c--------------------------------------------------------------------- c rhs(isize) = rhs(isize) - A*rhs(isize-1) c--------------------------------------------------------------------- call matvec_sub(lhs(1,1,aa,isize,j,k), > rhs(1,isize-1,j,k),rhs(1,isize,j,k)) c--------------------------------------------------------------------- c B(isize) = B(isize) - C(isize-1)*A(isize) c--------------------------------------------------------------------- call matmul_sub(lhs(1,1,aa,isize,j,k), > lhs(1,1,cc,isize-1,j,k), > lhs(1,1,bb,isize,j,k)) c--------------------------------------------------------------------- c multiply rhs() by b_inverse() and copy to rhs c--------------------------------------------------------------------- call binvrhs( lhs(1,1,bb,i,j,k), > rhs(1,i,j,k) ) enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine matvec_sub(ablock,avec,bvec) c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c subtracts bvec=bvec - ablock*avec c--------------------------------------------------------------------- implicit none double precision ablock,avec,bvec dimension ablock(5,5),avec(5),bvec(5) integer i do i=1,5 c--------------------------------------------------------------------- c rhs(i,ic,jc,kc,ccell) = rhs(i,ic,jc,kc,ccell) c $ - lhs(i,1,ablock,ia,ja,ka,acell)* c--------------------------------------------------------------------- bvec(i) = bvec(i) - ablock(i,1)*avec(1) > - ablock(i,2)*avec(2) > - ablock(i,3)*avec(3) > - ablock(i,4)*avec(4) > - ablock(i,5)*avec(5) enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine matmul_sub(ablock, bblock, cblock) c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c subtracts a(i,j,k) X b(i,j,k) from c(i,j,k) c--------------------------------------------------------------------- implicit none double precision ablock, bblock, cblock dimension ablock(5,5), bblock(5,5), cblock(5,5) integer j do j=1,5 cblock(1,j) = cblock(1,j) - ablock(1,1)*bblock(1,j) > - ablock(1,2)*bblock(2,j) > - ablock(1,3)*bblock(3,j) > - ablock(1,4)*bblock(4,j) > - ablock(1,5)*bblock(5,j) cblock(2,j) = cblock(2,j) - ablock(2,1)*bblock(1,j) > - ablock(2,2)*bblock(2,j) > - ablock(2,3)*bblock(3,j) > - ablock(2,4)*bblock(4,j) > - ablock(2,5)*bblock(5,j) cblock(3,j) = cblock(3,j) - ablock(3,1)*bblock(1,j) > - ablock(3,2)*bblock(2,j) > - ablock(3,3)*bblock(3,j) > - ablock(3,4)*bblock(4,j) > - ablock(3,5)*bblock(5,j) cblock(4,j) = cblock(4,j) - ablock(4,1)*bblock(1,j) > - ablock(4,2)*bblock(2,j) > - ablock(4,3)*bblock(3,j) > - ablock(4,4)*bblock(4,j) > - ablock(4,5)*bblock(5,j) cblock(5,j) = cblock(5,j) - ablock(5,1)*bblock(1,j) > - ablock(5,2)*bblock(2,j) > - ablock(5,3)*bblock(3,j) > - ablock(5,4)*bblock(4,j) > - ablock(5,5)*bblock(5,j) enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine binvcrhs( lhs,c,r ) c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c c--------------------------------------------------------------------- implicit none double precision pivot, coeff, lhs dimension lhs(5,5) double precision c(5,5), r(5) c--------------------------------------------------------------------- c c--------------------------------------------------------------------- pivot = 1.00d0/lhs(1,1) lhs(1,2) = lhs(1,2)*pivot lhs(1,3) = lhs(1,3)*pivot lhs(1,4) = lhs(1,4)*pivot lhs(1,5) = lhs(1,5)*pivot c(1,1) = c(1,1)*pivot c(1,2) = c(1,2)*pivot c(1,3) = c(1,3)*pivot c(1,4) = c(1,4)*pivot c(1,5) = c(1,5)*pivot r(1) = r(1) *pivot coeff = lhs(2,1) lhs(2,2)= lhs(2,2) - coeff*lhs(1,2) lhs(2,3)= lhs(2,3) - coeff*lhs(1,3) lhs(2,4)= lhs(2,4) - coeff*lhs(1,4) lhs(2,5)= lhs(2,5) - coeff*lhs(1,5) c(2,1) = c(2,1) - coeff*c(1,1) c(2,2) = c(2,2) - coeff*c(1,2) c(2,3) = c(2,3) - coeff*c(1,3) c(2,4) = c(2,4) - coeff*c(1,4) c(2,5) = c(2,5) - coeff*c(1,5) r(2) = r(2) - coeff*r(1) coeff = lhs(3,1) lhs(3,2)= lhs(3,2) - coeff*lhs(1,2) lhs(3,3)= lhs(3,3) - coeff*lhs(1,3) lhs(3,4)= lhs(3,4) - coeff*lhs(1,4) lhs(3,5)= lhs(3,5) - coeff*lhs(1,5) c(3,1) = c(3,1) - coeff*c(1,1) c(3,2) = c(3,2) - coeff*c(1,2) c(3,3) = c(3,3) - coeff*c(1,3) c(3,4) = c(3,4) - coeff*c(1,4) c(3,5) = c(3,5) - coeff*c(1,5) r(3) = r(3) - coeff*r(1) coeff = lhs(4,1) lhs(4,2)= lhs(4,2) - coeff*lhs(1,2) lhs(4,3)= lhs(4,3) - coeff*lhs(1,3) lhs(4,4)= lhs(4,4) - coeff*lhs(1,4) lhs(4,5)= lhs(4,5) - coeff*lhs(1,5) c(4,1) = c(4,1) - coeff*c(1,1) c(4,2) = c(4,2) - coeff*c(1,2) c(4,3) = c(4,3) - coeff*c(1,3) c(4,4) = c(4,4) - coeff*c(1,4) c(4,5) = c(4,5) - coeff*c(1,5) r(4) = r(4) - coeff*r(1) coeff = lhs(5,1) lhs(5,2)= lhs(5,2) - coeff*lhs(1,2) lhs(5,3)= lhs(5,3) - coeff*lhs(1,3) lhs(5,4)= lhs(5,4) - coeff*lhs(1,4) lhs(5,5)= lhs(5,5) - coeff*lhs(1,5) c(5,1) = c(5,1) - coeff*c(1,1) c(5,2) = c(5,2) - coeff*c(1,2) c(5,3) = c(5,3) - coeff*c(1,3) c(5,4) = c(5,4) - coeff*c(1,4) c(5,5) = c(5,5) - coeff*c(1,5) r(5) = r(5) - coeff*r(1) pivot = 1.00d0/lhs(2,2) lhs(2,3) = lhs(2,3)*pivot lhs(2,4) = lhs(2,4)*pivot lhs(2,5) = lhs(2,5)*pivot c(2,1) = c(2,1)*pivot c(2,2) = c(2,2)*pivot c(2,3) = c(2,3)*pivot c(2,4) = c(2,4)*pivot c(2,5) = c(2,5)*pivot r(2) = r(2) *pivot coeff = lhs(1,2) lhs(1,3)= lhs(1,3) - coeff*lhs(2,3) lhs(1,4)= lhs(1,4) - coeff*lhs(2,4) lhs(1,5)= lhs(1,5) - coeff*lhs(2,5) c(1,1) = c(1,1) - coeff*c(2,1) c(1,2) = c(1,2) - coeff*c(2,2) c(1,3) = c(1,3) - coeff*c(2,3) c(1,4) = c(1,4) - coeff*c(2,4) c(1,5) = c(1,5) - coeff*c(2,5) r(1) = r(1) - coeff*r(2) coeff = lhs(3,2) lhs(3,3)= lhs(3,3) - coeff*lhs(2,3) lhs(3,4)= lhs(3,4) - coeff*lhs(2,4) lhs(3,5)= lhs(3,5) - coeff*lhs(2,5) c(3,1) = c(3,1) - coeff*c(2,1) c(3,2) = c(3,2) - coeff*c(2,2) c(3,3) = c(3,3) - coeff*c(2,3) c(3,4) = c(3,4) - coeff*c(2,4) c(3,5) = c(3,5) - coeff*c(2,5) r(3) = r(3) - coeff*r(2) coeff = lhs(4,2) lhs(4,3)= lhs(4,3) - coeff*lhs(2,3) lhs(4,4)= lhs(4,4) - coeff*lhs(2,4) lhs(4,5)= lhs(4,5) - coeff*lhs(2,5) c(4,1) = c(4,1) - coeff*c(2,1) c(4,2) = c(4,2) - coeff*c(2,2) c(4,3) = c(4,3) - coeff*c(2,3) c(4,4) = c(4,4) - coeff*c(2,4) c(4,5) = c(4,5) - coeff*c(2,5) r(4) = r(4) - coeff*r(2) coeff = lhs(5,2) lhs(5,3)= lhs(5,3) - coeff*lhs(2,3) lhs(5,4)= lhs(5,4) - coeff*lhs(2,4) lhs(5,5)= lhs(5,5) - coeff*lhs(2,5) c(5,1) = c(5,1) - coeff*c(2,1) c(5,2) = c(5,2) - coeff*c(2,2) c(5,3) = c(5,3) - coeff*c(2,3) c(5,4) = c(5,4) - coeff*c(2,4) c(5,5) = c(5,5) - coeff*c(2,5) r(5) = r(5) - coeff*r(2) pivot = 1.00d0/lhs(3,3) lhs(3,4) = lhs(3,4)*pivot lhs(3,5) = lhs(3,5)*pivot c(3,1) = c(3,1)*pivot c(3,2) = c(3,2)*pivot c(3,3) = c(3,3)*pivot c(3,4) = c(3,4)*pivot c(3,5) = c(3,5)*pivot r(3) = r(3) *pivot coeff = lhs(1,3) lhs(1,4)= lhs(1,4) - coeff*lhs(3,4) lhs(1,5)= lhs(1,5) - coeff*lhs(3,5) c(1,1) = c(1,1) - coeff*c(3,1) c(1,2) = c(1,2) - coeff*c(3,2) c(1,3) = c(1,3) - coeff*c(3,3) c(1,4) = c(1,4) - coeff*c(3,4) c(1,5) = c(1,5) - coeff*c(3,5) r(1) = r(1) - coeff*r(3) coeff = lhs(2,3) lhs(2,4)= lhs(2,4) - coeff*lhs(3,4) lhs(2,5)= lhs(2,5) - coeff*lhs(3,5) c(2,1) = c(2,1) - coeff*c(3,1) c(2,2) = c(2,2) - coeff*c(3,2) c(2,3) = c(2,3) - coeff*c(3,3) c(2,4) = c(2,4) - coeff*c(3,4) c(2,5) = c(2,5) - coeff*c(3,5) r(2) = r(2) - coeff*r(3) coeff = lhs(4,3) lhs(4,4)= lhs(4,4) - coeff*lhs(3,4) lhs(4,5)= lhs(4,5) - coeff*lhs(3,5) c(4,1) = c(4,1) - coeff*c(3,1) c(4,2) = c(4,2) - coeff*c(3,2) c(4,3) = c(4,3) - coeff*c(3,3) c(4,4) = c(4,4) - coeff*c(3,4) c(4,5) = c(4,5) - coeff*c(3,5) r(4) = r(4) - coeff*r(3) coeff = lhs(5,3) lhs(5,4)= lhs(5,4) - coeff*lhs(3,4) lhs(5,5)= lhs(5,5) - coeff*lhs(3,5) c(5,1) = c(5,1) - coeff*c(3,1) c(5,2) = c(5,2) - coeff*c(3,2) c(5,3) = c(5,3) - coeff*c(3,3) c(5,4) = c(5,4) - coeff*c(3,4) c(5,5) = c(5,5) - coeff*c(3,5) r(5) = r(5) - coeff*r(3) pivot = 1.00d0/lhs(4,4) lhs(4,5) = lhs(4,5)*pivot c(4,1) = c(4,1)*pivot c(4,2) = c(4,2)*pivot c(4,3) = c(4,3)*pivot c(4,4) = c(4,4)*pivot c(4,5) = c(4,5)*pivot r(4) = r(4) *pivot coeff = lhs(1,4) lhs(1,5)= lhs(1,5) - coeff*lhs(4,5) c(1,1) = c(1,1) - coeff*c(4,1) c(1,2) = c(1,2) - coeff*c(4,2) c(1,3) = c(1,3) - coeff*c(4,3) c(1,4) = c(1,4) - coeff*c(4,4) c(1,5) = c(1,5) - coeff*c(4,5) r(1) = r(1) - coeff*r(4) coeff = lhs(2,4) lhs(2,5)= lhs(2,5) - coeff*lhs(4,5) c(2,1) = c(2,1) - coeff*c(4,1) c(2,2) = c(2,2) - coeff*c(4,2) c(2,3) = c(2,3) - coeff*c(4,3) c(2,4) = c(2,4) - coeff*c(4,4) c(2,5) = c(2,5) - coeff*c(4,5) r(2) = r(2) - coeff*r(4) coeff = lhs(3,4) lhs(3,5)= lhs(3,5) - coeff*lhs(4,5) c(3,1) = c(3,1) - coeff*c(4,1) c(3,2) = c(3,2) - coeff*c(4,2) c(3,3) = c(3,3) - coeff*c(4,3) c(3,4) = c(3,4) - coeff*c(4,4) c(3,5) = c(3,5) - coeff*c(4,5) r(3) = r(3) - coeff*r(4) coeff = lhs(5,4) lhs(5,5)= lhs(5,5) - coeff*lhs(4,5) c(5,1) = c(5,1) - coeff*c(4,1) c(5,2) = c(5,2) - coeff*c(4,2) c(5,3) = c(5,3) - coeff*c(4,3) c(5,4) = c(5,4) - coeff*c(4,4) c(5,5) = c(5,5) - coeff*c(4,5) r(5) = r(5) - coeff*r(4) pivot = 1.00d0/lhs(5,5) c(5,1) = c(5,1)*pivot c(5,2) = c(5,2)*pivot c(5,3) = c(5,3)*pivot c(5,4) = c(5,4)*pivot c(5,5) = c(5,5)*pivot r(5) = r(5) *pivot coeff = lhs(1,5) c(1,1) = c(1,1) - coeff*c(5,1) c(1,2) = c(1,2) - coeff*c(5,2) c(1,3) = c(1,3) - coeff*c(5,3) c(1,4) = c(1,4) - coeff*c(5,4) c(1,5) = c(1,5) - coeff*c(5,5) r(1) = r(1) - coeff*r(5) coeff = lhs(2,5) c(2,1) = c(2,1) - coeff*c(5,1) c(2,2) = c(2,2) - coeff*c(5,2) c(2,3) = c(2,3) - coeff*c(5,3) c(2,4) = c(2,4) - coeff*c(5,4) c(2,5) = c(2,5) - coeff*c(5,5) r(2) = r(2) - coeff*r(5) coeff = lhs(3,5) c(3,1) = c(3,1) - coeff*c(5,1) c(3,2) = c(3,2) - coeff*c(5,2) c(3,3) = c(3,3) - coeff*c(5,3) c(3,4) = c(3,4) - coeff*c(5,4) c(3,5) = c(3,5) - coeff*c(5,5) r(3) = r(3) - coeff*r(5) coeff = lhs(4,5) c(4,1) = c(4,1) - coeff*c(5,1) c(4,2) = c(4,2) - coeff*c(5,2) c(4,3) = c(4,3) - coeff*c(5,3) c(4,4) = c(4,4) - coeff*c(5,4) c(4,5) = c(4,5) - coeff*c(5,5) r(4) = r(4) - coeff*r(5) return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine binvrhs( lhs,r ) c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c c--------------------------------------------------------------------- implicit none double precision pivot, coeff, lhs dimension lhs(5,5) double precision r(5) c--------------------------------------------------------------------- c c--------------------------------------------------------------------- pivot = 1.00d0/lhs(1,1) lhs(1,2) = lhs(1,2)*pivot lhs(1,3) = lhs(1,3)*pivot lhs(1,4) = lhs(1,4)*pivot lhs(1,5) = lhs(1,5)*pivot r(1) = r(1) *pivot coeff = lhs(2,1) lhs(2,2)= lhs(2,2) - coeff*lhs(1,2) lhs(2,3)= lhs(2,3) - coeff*lhs(1,3) lhs(2,4)= lhs(2,4) - coeff*lhs(1,4) lhs(2,5)= lhs(2,5) - coeff*lhs(1,5) r(2) = r(2) - coeff*r(1) coeff = lhs(3,1) lhs(3,2)= lhs(3,2) - coeff*lhs(1,2) lhs(3,3)= lhs(3,3) - coeff*lhs(1,3) lhs(3,4)= lhs(3,4) - coeff*lhs(1,4) lhs(3,5)= lhs(3,5) - coeff*lhs(1,5) r(3) = r(3) - coeff*r(1) coeff = lhs(4,1) lhs(4,2)= lhs(4,2) - coeff*lhs(1,2) lhs(4,3)= lhs(4,3) - coeff*lhs(1,3) lhs(4,4)= lhs(4,4) - coeff*lhs(1,4) lhs(4,5)= lhs(4,5) - coeff*lhs(1,5) r(4) = r(4) - coeff*r(1) coeff = lhs(5,1) lhs(5,2)= lhs(5,2) - coeff*lhs(1,2) lhs(5,3)= lhs(5,3) - coeff*lhs(1,3) lhs(5,4)= lhs(5,4) - coeff*lhs(1,4) lhs(5,5)= lhs(5,5) - coeff*lhs(1,5) r(5) = r(5) - coeff*r(1) pivot = 1.00d0/lhs(2,2) lhs(2,3) = lhs(2,3)*pivot lhs(2,4) = lhs(2,4)*pivot lhs(2,5) = lhs(2,5)*pivot r(2) = r(2) *pivot coeff = lhs(1,2) lhs(1,3)= lhs(1,3) - coeff*lhs(2,3) lhs(1,4)= lhs(1,4) - coeff*lhs(2,4) lhs(1,5)= lhs(1,5) - coeff*lhs(2,5) r(1) = r(1) - coeff*r(2) coeff = lhs(3,2) lhs(3,3)= lhs(3,3) - coeff*lhs(2,3) lhs(3,4)= lhs(3,4) - coeff*lhs(2,4) lhs(3,5)= lhs(3,5) - coeff*lhs(2,5) r(3) = r(3) - coeff*r(2) coeff = lhs(4,2) lhs(4,3)= lhs(4,3) - coeff*lhs(2,3) lhs(4,4)= lhs(4,4) - coeff*lhs(2,4) lhs(4,5)= lhs(4,5) - coeff*lhs(2,5) r(4) = r(4) - coeff*r(2) coeff = lhs(5,2) lhs(5,3)= lhs(5,3) - coeff*lhs(2,3) lhs(5,4)= lhs(5,4) - coeff*lhs(2,4) lhs(5,5)= lhs(5,5) - coeff*lhs(2,5) r(5) = r(5) - coeff*r(2) pivot = 1.00d0/lhs(3,3) lhs(3,4) = lhs(3,4)*pivot lhs(3,5) = lhs(3,5)*pivot r(3) = r(3) *pivot coeff = lhs(1,3) lhs(1,4)= lhs(1,4) - coeff*lhs(3,4) lhs(1,5)= lhs(1,5) - coeff*lhs(3,5) r(1) = r(1) - coeff*r(3) coeff = lhs(2,3) lhs(2,4)= lhs(2,4) - coeff*lhs(3,4) lhs(2,5)= lhs(2,5) - coeff*lhs(3,5) r(2) = r(2) - coeff*r(3) coeff = lhs(4,3) lhs(4,4)= lhs(4,4) - coeff*lhs(3,4) lhs(4,5)= lhs(4,5) - coeff*lhs(3,5) r(4) = r(4) - coeff*r(3) coeff = lhs(5,3) lhs(5,4)= lhs(5,4) - coeff*lhs(3,4) lhs(5,5)= lhs(5,5) - coeff*lhs(3,5) r(5) = r(5) - coeff*r(3) pivot = 1.00d0/lhs(4,4) lhs(4,5) = lhs(4,5)*pivot r(4) = r(4) *pivot coeff = lhs(1,4) lhs(1,5)= lhs(1,5) - coeff*lhs(4,5) r(1) = r(1) - coeff*r(4) coeff = lhs(2,4) lhs(2,5)= lhs(2,5) - coeff*lhs(4,5) r(2) = r(2) - coeff*r(4) coeff = lhs(3,4) lhs(3,5)= lhs(3,5) - coeff*lhs(4,5) r(3) = r(3) - coeff*r(4) coeff = lhs(5,4) lhs(5,5)= lhs(5,5) - coeff*lhs(4,5) r(5) = r(5) - coeff*r(4) pivot = 1.00d0/lhs(5,5) r(5) = r(5) *pivot coeff = lhs(1,5) r(1) = r(1) - coeff*r(5) coeff = lhs(2,5) r(2) = r(2) - coeff*r(5) coeff = lhs(3,5) r(3) = r(3) - coeff*r(5) coeff = lhs(4,5) r(4) = r(4) - coeff*r(5) return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine y_solve c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c Performs line solves in Y direction by first factoring c the block-tridiagonal matrix into an upper triangular matrix, c and then performing back substitution to solve for the unknow c vectors of each line. c c Make sure we treat elements zero to cell_size in the direction c of the sweep. c--------------------------------------------------------------------- include 'header.h' call lhsy call y_solve_cell call y_backsubstitute return end subroutine y_backsubstitute c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c back solve: if last cell, then generate U(jsize)=rhs(jsize) c else assume U(jsize) is loaded in un pack backsub_info c so just use it c after call u(jstart) will be sent to next cell c--------------------------------------------------------------------- include 'header.h' integer i, j, k, m,n do k=1,grid_points(3)-2 do j=grid_points(2)-2,0,-1 do i=1,grid_points(1)-2 do m=1,BLOCK_SIZE do n=1,BLOCK_SIZE rhs(m,i,j,k) = rhs(m,i,j,k) > - lhs(m,n,cc,i,j,k)*rhs(n,i,j+1,k) enddo enddo enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine y_solve_cell c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c performs guaussian elimination on this cell. c c assumes that unpacking routines for non-first cells c preload C' and rhs' from previous cell. c c assumed send happens outside this routine, but that c c'(JMAX) and rhs'(JMAX) will be sent to next cell c--------------------------------------------------------------------- include 'header.h' integer i,j,k,jsize,jstart jstart = 0 jsize = grid_points(2)-1 do k=1,grid_points(3)-2 do i=1,grid_points(1)-2 c--------------------------------------------------------------------- c multiply c(i,0,k) by b_inverse and copy back to c c multiply rhs(0) by b_inverse(0) and copy to rhs c--------------------------------------------------------------------- call binvcrhs( lhs(1,1,bb,i,0,k), > lhs(1,1,cc,i,0,k), > rhs(1,i,0,k) ) enddo enddo c--------------------------------------------------------------------- c begin inner most do loop c do all the elements of the cell unless last c--------------------------------------------------------------------- do k=1,grid_points(3)-2 do j=1,jsize-1 do i=1,grid_points(1)-2 c--------------------------------------------------------------------- c subtract A*lhs_vector(j-1) from lhs_vector(j) c c rhs(j) = rhs(j) - A*rhs(j-1) c--------------------------------------------------------------------- call matvec_sub(lhs(1,1,aa,i,j,k), > rhs(1,i,j-1,k),rhs(1,i,j,k)) c--------------------------------------------------------------------- c B(j) = B(j) - C(j-1)*A(j) c--------------------------------------------------------------------- call matmul_sub(lhs(1,1,aa,i,j,k), > lhs(1,1,cc,i,j-1,k), > lhs(1,1,bb,i,j,k)) c--------------------------------------------------------------------- c multiply c(i,j,k) by b_inverse and copy back to c c multiply rhs(i,1,k) by b_inverse(i,1,k) and copy to rhs c--------------------------------------------------------------------- call binvcrhs( lhs(1,1,bb,i,j,k), > lhs(1,1,cc,i,j,k), > rhs(1,i,j,k) ) enddo enddo enddo do k=1,grid_points(3)-2 do i=1,grid_points(1)-2 c--------------------------------------------------------------------- c rhs(jsize) = rhs(jsize) - A*rhs(jsize-1) c--------------------------------------------------------------------- call matvec_sub(lhs(1,1,aa,i,jsize,k), > rhs(1,i,jsize-1,k),rhs(1,i,jsize,k)) c--------------------------------------------------------------------- c B(jsize) = B(jsize) - C(jsize-1)*A(jsize) c call matmul_sub(aa,i,jsize,k,c, c $ cc,i,jsize-1,k,c,bb,i,jsize,k) c--------------------------------------------------------------------- call matmul_sub(lhs(1,1,aa,i,jsize,k), > lhs(1,1,cc,i,jsize-1,k), > lhs(1,1,bb,i,jsize,k)) c--------------------------------------------------------------------- c multiply rhs(jsize) by b_inverse(jsize) and copy to rhs c--------------------------------------------------------------------- call binvrhs( lhs(1,1,bb,i,jsize,k), > rhs(1,i,jsize,k) ) enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine z_solve c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c Performs line solves in Z direction by first factoring c the block-tridiagonal matrix into an upper triangular matrix, c and then performing back substitution to solve for the unknow c vectors of each line. c c Make sure we treat elements zero to cell_size in the direction c of the sweep. c--------------------------------------------------------------------- include 'header.h' call lhsz call z_solve_cell call z_backsubstitute return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine z_backsubstitute c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c back solve: if last cell, then generate U(ksize)=rhs(ksize) c else assume U(ksize) is loaded in un pack backsub_info c so just use it c after call u(kstart) will be sent to next cell c--------------------------------------------------------------------- include 'header.h' integer i, j, k, m, n do k=grid_points(3)-2,0,-1 do j=1,grid_points(2)-2 do i=1,grid_points(1)-2 do m=1,BLOCK_SIZE do n=1,BLOCK_SIZE rhs(m,i,j,k) = rhs(m,i,j,k) > - lhs(m,n,cc,i,j,k)*rhs(n,i,j,k+1) enddo enddo enddo enddo enddo return end c--------------------------------------------------------------------- c--------------------------------------------------------------------- subroutine z_solve_cell c--------------------------------------------------------------------- c--------------------------------------------------------------------- c--------------------------------------------------------------------- c performs guaussian elimination on this cell. c c assumes that unpacking routines for non-first cells c preload C' and rhs' from previous cell. c c assumed send happens outside this routine, but that c c'(KMAX) and rhs'(KMAX) will be sent to next cell. c--------------------------------------------------------------------- include 'header.h' integer i,j,k,ksize ksize = grid_points(3)-1 c--------------------------------------------------------------------- c outer most do loops - sweeping in i direction c--------------------------------------------------------------------- do j=1,grid_points(2)-2 do i=1,grid_points(1)-2 c--------------------------------------------------------------------- c multiply c(i,j,0) by b_inverse and copy back to c c multiply rhs(0) by b_inverse(0) and copy to rhs c--------------------------------------------------------------------- call binvcrhs( lhs(1,1,bb,i,j,0), > lhs(1,1,cc,i,j,0), > rhs(1,i,j,0) ) enddo enddo c--------------------------------------------------------------------- c begin inner most do loop c do all the elements of the cell unless last c--------------------------------------------------------------------- do k=1,ksize-1 do j=1,grid_points(2)-2 do i=1,grid_points(1)-2 c--------------------------------------------------------------------- c subtract A*lhs_vector(k-1) from lhs_vector(k) c c rhs(k) = rhs(k) - A*rhs(k-1) c--------------------------------------------------------------------- call matvec_sub(lhs(1,1,aa,i,j,k), > rhs(1,i,j,k-1),rhs(1,i,j,k)) c--------------------------------------------------------------------- c B(k) = B(k) - C(k-1)*A(k) c call matmul_sub(aa,i,j,k,c,cc,i,j,k-1,c,bb,i,j,k) c--------------------------------------------------------------------- call matmul_sub(lhs(1,1,aa,i,j,k), > lhs(1,1,cc,i,j,k-1), > lhs(1,1,bb,i,j,k)) c--------------------------------------------------------------------- c multiply c(i,j,k) by b_inverse and copy back to c c multiply rhs(i,j,1) by b_inverse(i,j,1) and copy to rhs c--------------------------------------------------------------------- call binvcrhs( lhs(1,1,bb,i,j,k), > lhs(1,1,cc,i,j,k), > rhs(1,i,j,k) ) enddo enddo enddo c--------------------------------------------------------------------- c Now finish up special cases for last cell c--------------------------------------------------------------------- do j=1,grid_points(2)-2 do i=1,grid_points(1)-2 c--------------------------------------------------------------------- c rhs(ksize) = rhs(ksize) - A*rhs(ksize-1) c--------------------------------------------------------------------- call matvec_sub(lhs(1,1,aa,i,j,ksize), > rhs(1,i,j,ksize-1),rhs(1,i,j,ksize)) c--------------------------------------------------------------------- c B(ksize) = B(ksize) - C(ksize-1)*A(ksize) c call matmul_sub(aa,i,j,ksize,c, c $ cc,i,j,ksize-1,c,bb,i,j,ksize) c--------------------------------------------------------------------- call matmul_sub(lhs(1,1,aa,i,j,ksize), > lhs(1,1,cc,i,j,ksize-1), > lhs(1,1,bb,i,j,ksize)) c--------------------------------------------------------------------- c multiply rhs(ksize) by b_inverse(ksize) and copy to rhs c--------------------------------------------------------------------- call binvrhs( lhs(1,1,bb,i,j,ksize), > rhs(1,i,j,ksize) ) enddo enddo return end