! *** generated by SAPFOR with version 2415 and build date: May 4 2025 14:48:40 ! *** Enabled options ***: ! *** maximum shadow width is 50 percent ! *** generated by SAPFOR !--------------------------------------------------------------------- !--------------------------------------------------------------------- subroutine exact_rhs_sp () include 'header_sp.h' double precision :: dtemp(5),xi,eta,zeta,dtpp integer :: m,i,j,k,ip1,im1,jp1,p,p1,jm1,km1,kp1,z double precision :: ue_((-(2)):2,5),buf_((-(2)):2,5),cuf_((-(2)): &2),q_((-(2)):2) ! DVM$ PARALLEL (K,J,I) ON FORCING(*,I,J,K), PRIVATE (M) ! DVM$ REGION do k = 0,problem_size - 1 do j = 0,problem_size - 1 do i = 0,problem_size - 1 do m = 1,5 forcing(m,i,j,k) = 0.0d0 enddo enddo enddo enddo ! DVM$ PARALLEL (K,J,I) ON FORCING(*,I,J,K), PRIVATE (ZETA,ETA,XI,M,DTEMP ! DVM$&,BUF_,CUF_,Q_,DTPP,Z,UE_) !--------------------------------------------------------------------- ! xi-direction flux differences !--------------------------------------------------------------------- do k = 1,problem_size - 2 do j = 1,problem_size - 2 do i = 1,problem_size - 2 zeta = dble (k) * dnzm1 eta = dble (j) * dnym1 do z = (-(2)),2 xi = dble (i + z) * dnxm1 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 do m = 1,5 ue_(z,m) = dtemp(m) enddo dtpp = 1.0d0 / dtemp(1) do m = 2,5 buf_(z,m) = dtpp * dtemp(m) enddo cuf_(z) = buf_(z,2) * buf_(z,2) buf_(z,1) = cuf_(z) + buf_(z,3) * buf_(z,3) + buf_(z,4 &) * buf_(z,4) q_(z) = 0.5d0 * (buf_(z,2) * ue_(z,2) + buf_(z,3) * ue &_(z,3) + buf_(z,4) * ue_(z,4)) enddo forcing(1,i,j,k) = forcing(1,i,j,k) - tx2 * (ue_(1,2) - u &e_((-(1)),2)) + dx1tx1 * (ue_(1,1) - 2.0d0 * ue_(0,1) + ue_((-(1)) &,1)) forcing(2,i,j,k) = forcing(2,i,j,k) - tx2 * (ue_(1,2) * b &uf_(1,2) + c2 * (ue_(1,5) - q_(1)) - (ue_((-(1)),2) * buf_((-(1)), &2) + c2 * (ue_((-(1)),5) - q_((-(1)))))) + xxcon1 * (buf_(1,2) - 2 &.0d0 * buf_(0,2) + buf_((-(1)),2)) + dx2tx1 * (ue_(1,2) - 2.0d0 * &ue_(0,2) + ue_((-(1)),2)) forcing(3,i,j,k) = forcing(3,i,j,k) - tx2 * (ue_(1,3) * b &uf_(1,2) - ue_((-(1)),3) * buf_((-(1)),2)) + xxcon2 * (buf_(1,3) - & 2.0d0 * buf_(0,3) + buf_((-(1)),3)) + dx3tx1 * (ue_(1,3) - 2.0d0 &* ue_(0,3) + ue_((-(1)),3)) forcing(4,i,j,k) = forcing(4,i,j,k) - tx2 * (ue_(1,4) * b &uf_(1,2) - ue_((-(1)),4) * buf_((-(1)),2)) + xxcon2 * (buf_(1,4) - & 2.0d0 * buf_(0,4) + buf_((-(1)),4)) + dx4tx1 * (ue_(1,4) - 2.0d0 &* ue_(0,4) + ue_((-(1)),4)) forcing(5,i,j,k) = forcing(5,i,j,k) - tx2 * (buf_(1,2) * &(c1 * ue_(1,5) - c2 * q_(1)) - buf_((-(1)),2) * (c1 * ue_((-(1)),5 &) - c2 * q_((-(1))))) + 0.5d0 * xxcon3 * (buf_(1,1) - 2.0d0 * buf_ &(0,1) + buf_((-(1)),1)) + xxcon4 * (cuf_(1) - 2.0d0 * cuf_(0) + cu &f_((-(1)))) + xxcon5 * (buf_(1,5) - 2.0d0 * buf_(0,5) + buf_((-(1) &),5)) + dx5tx1 * (ue_(1,5) - 2.0d0 * ue_(0,5) + ue_((-(1)),5)) do m = 1,5 if (i .eq. 1) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (5.0d0 & * ue_(0,m) - 4.0d0 * ue_(1,m) + ue_(2,m)) else if (i .eq. 2) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * ((-(4. &0d0)) * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_(1,m) + ue_( &2,m)) else if (i .eq. problem_size - 3) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_( &1,m)) else if (i .eq. problem_size - 2) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 5.0d0 * ue_(0,m)) else forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_( &1,m) + ue_(2,m)) endif enddo enddo enddo enddo ! DVM$ PARALLEL (K,J,I) ON FORCING(*,I,J,K), PRIVATE (ZETA,ETA,XI,M,DTEMP ! DVM$&,BUF_,CUF_,Q_,DTPP,Z,UE_) !--------------------------------------------------------------------- ! eta-direction flux differences !--------------------------------------------------------------------- do k = 1,problem_size - 2 do j = 1,problem_size - 2 do i = 1,problem_size - 2 zeta = dble (k) * dnzm1 xi = dble (i) * dnxm1 do z = (-(2)),2 eta = dble (j + z) * dnym1 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 do m = 1,5 ue_(z,m) = dtemp(m) enddo dtpp = 1.0d0 / dtemp(1) do m = 2,5 buf_(z,m) = dtpp * dtemp(m) enddo cuf_(z) = buf_(z,3) * buf_(z,3) buf_(z,1) = cuf_(z) + buf_(z,2) * buf_(z,2) + buf_(z,4 &) * buf_(z,4) q_(z) = 0.5d0 * (buf_(z,2) * ue_(z,2) + buf_(z,3) * ue &_(z,3) + buf_(z,4) * ue_(z,4)) enddo forcing(1,i,j,k) = forcing(1,i,j,k) - ty2 * (ue_(1,3) - u &e_((-(1)),3)) + dy1ty1 * (ue_(1,1) - 2.0d0 * ue_(0,1) + ue_((-(1)) &,1)) forcing(2,i,j,k) = forcing(2,i,j,k) - ty2 * (ue_(1,2) * b &uf_(1,3) - ue_((-(1)),2) * buf_((-(1)),3)) + yycon2 * (buf_(1,2) - & 2.0d0 * buf_(0,2) + buf_((-(1)),2)) + dy2ty1 * (ue_(1,2) - 2.0 * &ue_(0,2) + ue_((-(1)),2)) forcing(3,i,j,k) = forcing(3,i,j,k) - ty2 * (ue_(1,3) * b &uf_(1,3) + c2 * (ue_(1,5) - q_(1)) - (ue_((-(1)),3) * buf_((-(1)), &3) + c2 * (ue_((-(1)),5) - q_((-(1)))))) + yycon1 * (buf_(1,3) - 2 &.0d0 * buf_(0,3) + buf_((-(1)),3)) + dy3ty1 * (ue_(1,3) - 2.0d0 * &ue_(0,3) + ue_((-(1)),3)) forcing(4,i,j,k) = forcing(4,i,j,k) - ty2 * (ue_(1,4) * b &uf_(1,3) - ue_((-(1)),4) * buf_((-(1)),3)) + yycon2 * (buf_(1,4) - & 2.0d0 * buf_(0,4) + buf_((-(1)),4)) + dy4ty1 * (ue_(1,4) - 2.0d0 &* ue_(0,4) + ue_((-(1)),4)) forcing(5,i,j,k) = forcing(5,i,j,k) - ty2 * (buf_(1,3) * &(c1 * ue_(1,5) - c2 * q_(1)) - buf_((-(1)),3) * (c1 * ue_((-(1)),5 &) - c2 * q_((-(1))))) + 0.5d0 * yycon3 * (buf_(1,1) - 2.0d0 * buf_ &(0,1) + buf_((-(1)),1)) + yycon4 * (cuf_(1) - 2.0d0 * cuf_(0) + cu &f_((-(1)))) + yycon5 * (buf_(1,5) - 2.0d0 * buf_(0,5) + buf_((-(1) &),5)) + dy5ty1 * (ue_(1,5) - 2.0d0 * ue_(0,5) + ue_((-(1)),5)) do m = 1,5 if (j .eq. 1) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (5.0d0 & * ue_(0,m) - 4.0d0 * ue_(1,m) + ue_(2,m)) else if (j .eq. 2) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * ((-(4. &0d0)) * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_(1,m) + ue_( &2,m)) else if (j .eq. problem_size - 3) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_( &1,m)) else if (j .eq. problem_size - 2) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 5.0d0 * ue_(0,m)) else forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_( &1,m) + ue_(2,m)) endif enddo enddo enddo enddo ! DVM$ PARALLEL (K,J,I) ON FORCING(*,I,J,K), PRIVATE (ZETA,ETA,XI,M,BUF_, ! DVM$&CUF_,Q_,UE_,DTPP,DTEMP,Z) !--------------------------------------------------------------------- ! zeta-direction flux differences !--------------------------------------------------------------------- do k = 1,problem_size - 2 do j = 1,problem_size - 2 do i = 1,problem_size - 2 xi = dble (i) * dnxm1 eta = dble (j) * dnym1 do z = (-(2)),2 zeta = dble (k + z) * dnzm1 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 do m = 1,5 ue_(z,m) = dtemp(m) enddo dtpp = 1.0d0 / dtemp(1) do m = 2,5 buf_(z,m) = dtpp * dtemp(m) enddo cuf_(z) = buf_(z,4) * buf_(z,4) buf_(z,1) = cuf_(z) + buf_(z,2) * buf_(z,2) + buf_(z,3 &) * buf_(z,3) q_(z) = 0.5d0 * (buf_(z,2) * ue_(z,2) + buf_(z,3) * ue &_(z,3) + buf_(z,4) * ue_(z,4)) enddo forcing(1,i,j,k) = forcing(1,i,j,k) - tz2 * (ue_(1,4) - u &e_((-(1)),4)) + dz1tz1 * (ue_(1,1) - 2.0d0 * ue_(0,1) + ue_((-(1)) &,1)) forcing(2,i,j,k) = forcing(2,i,j,k) - tz2 * (ue_(1,2) * b &uf_(1,4) - ue_((-(1)),2) * buf_((-(1)),4)) + zzcon2 * (buf_(1,2) - & 2.0d0 * buf_(0,2) + buf_((-(1)),2)) + dz2tz1 * (ue_(1,2) - 2.0d0 &* ue_(0,2) + ue_((-(1)),2)) forcing(3,i,j,k) = forcing(3,i,j,k) - tz2 * (ue_(1,3) * b &uf_(1,4) - ue_((-(1)),3) * buf_((-(1)),4)) + zzcon2 * (buf_(1,3) - & 2.0d0 * buf_(0,3) + buf_((-(1)),3)) + dz3tz1 * (ue_(1,3) - 2.0d0 &* ue_(0,3) + ue_((-(1)),3)) forcing(4,i,j,k) = forcing(4,i,j,k) - tz2 * (ue_(1,4) * b &uf_(1,4) + c2 * (ue_(1,5) - q_(1)) - (ue_((-(1)),4) * buf_((-(1)), &4) + c2 * (ue_((-(1)),5) - q_((-(1)))))) + zzcon1 * (buf_(1,4) - 2 &.0d0 * buf_(0,4) + buf_((-(1)),4)) + dz4tz1 * (ue_(1,4) - 2.0d0 * &ue_(0,4) + ue_((-(1)),4)) forcing(5,i,j,k) = forcing(5,i,j,k) - tz2 * (buf_(1,4) * &(c1 * ue_(1,5) - c2 * q_(1)) - buf_((-(1)),4) * (c1 * ue_((-(1)),5 &) - c2 * q_((-(1))))) + 0.5d0 * zzcon3 * (buf_(1,1) - 2.0d0 * buf_ &(0,1) + buf_((-(1)),1)) + zzcon4 * (cuf_(1) - 2.0d0 * cuf_(0) + cu &f_((-(1)))) + zzcon5 * (buf_(1,5) - 2.0d0 * buf_(0,5) + buf_((-(1) &),5)) + dz5tz1 * (ue_(1,5) - 2.0d0 * ue_(0,5) + ue_((-(1)),5)) do m = 1,5 if (k .eq. 1) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (5.0d0 & * ue_(0,m) - 4.0d0 * ue_(1,m) + ue_(2,m)) else if (k .eq. 2) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * ((-(4. &0d0)) * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_(1,m) + ue_( &2,m)) else if (k .eq. problem_size - 3) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_( &1,m)) else if (k .eq. problem_size - 2) then forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 5.0d0 * ue_(0,m)) else forcing(m,i,j,k) = forcing(m,i,j,k) - dssp * (ue_(( &-(2)),m) - 4.0d0 * ue_((-(1)),m) + 6.0d0 * ue_(0,m) - 4.0d0 * ue_( &1,m) + ue_(2,m)) endif enddo enddo enddo enddo ! DVM$ PARALLEL (K,J,I) ON FORCING(*,I,J,K), PRIVATE (M) !--------------------------------------------------------------------- ! now change the sign of the forcing function, !--------------------------------------------------------------------- do k = 1,problem_size - 2 do j = 1,problem_size - 2 do i = 1,problem_size - 2 do m = 1,5 forcing(m,i,j,k) = (-(1.d0)) * forcing(m,i,j,k) enddo enddo enddo enddo ! DVM$ END REGION return end