<p><b>duda</b> 2012-08-20 16:50:08 -0600 (Mon, 20 Aug 2012)</p><p>BRANCH COMMIT<br>
<br>
First cut at parallelizing block loops in the SW model.<br>
<br>
<br>
M src/core_sw_blocks/mpas_sw_time_integration.F<br>
</p><hr noshade><pre><font color="gray">Modified: branches/omp_blocks/openmp_test/src/core_sw_blocks/mpas_sw_time_integration.F
===================================================================
--- branches/omp_blocks/openmp_test/src/core_sw_blocks/mpas_sw_time_integration.F 2012-08-16 21:10:05 UTC (rev 2108)
+++ branches/omp_blocks/openmp_test/src/core_sw_blocks/mpas_sw_time_integration.F 2012-08-20 22:50:08 UTC (rev 2109)
@@ -63,6 +63,7 @@
integer :: iCell, k
type (block_type), pointer :: block
+ type (block_type) :: block_d
type (state_type), target :: provis
type (state_type), pointer :: provis_ptr
@@ -71,6 +72,8 @@
real (kind=RKIND), dimension(4) :: rk_weights, rk_substep_weights
call mpas_setup_provis_states(domain % blocklist)
+
+!$OMP PARALLEL DEFAULT(SHARED)
!
! Initialize time_levs(2) with state at current time
@@ -78,23 +81,29 @@
! Couple tracers time_levs(2) with h in time-levels
! Initialize RK weights
!
+!$OMP SINGLE PRIVATE(block)
block => domain % blocklist
do while (associated(block))
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
- block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
- do iCell=1,block % mesh % nCells ! couple tracers to h
- do k=1,block % mesh % nVertLevels
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) = block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
- * block % state % time_levs(1) % state % h % array(k,iCell)
+ block_d = block
+!$OMP TASK FIRSTPRIVATE(block_d) PRIVATE(iCell,k)
+ block_d % state % time_levs(2) % state % u % array(:,:) = block_d % state % time_levs(1) % state % u % array(:,:)
+ block_d % state % time_levs(2) % state % h % array(:,:) = block_d % state % time_levs(1) % state % h % array(:,:)
+ do iCell=1,block_d % mesh % nCells ! couple tracers to h
+ do k=1,block_d % mesh % nVertLevels
+ block_d % state % time_levs(2) % state % tracers % array(:,k,iCell) = block_d % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ * block_d % state % time_levs(1) % state % h % array(k,iCell)
end do
end do
- call mpas_copy_state(block % provis, block % state % time_levs(1) % state)
+ call mpas_copy_state(block_d % provis, block_d % state % time_levs(1) % state)
+!$OMP END TASK
block => block % next
end do
+!$OMP TASKWAIT
+
rk_weights(1) = dt/6.
rk_weights(2) = dt/3.
rk_weights(3) = dt/3.
@@ -124,11 +133,15 @@
block => domain % blocklist
do while (associated(block))
- call sw_compute_tend(block % tend, block % provis, block % mesh)
- call sw_compute_scalar_tend(block % tend, block % provis, block % mesh)
- call sw_enforce_boundary_edge(block % tend, block % mesh)
+ block_d = block
+!$OMP TASK FIRSTPRIVATE(block_d)
+ call sw_compute_tend(block_d % tend, block_d % provis, block_d % mesh)
+ call sw_compute_scalar_tend(block_d % tend, block_d % provis, block_d % mesh)
+ call sw_enforce_boundary_edge(block_d % tend, block_d % mesh)
+!$OMP END TASK
block => block % next
end do
+!$OMP TASKWAIT
! --- update halos for prognostic variables
@@ -141,43 +154,51 @@
if (rk_step < 4) then
block => domain % blocklist
do while (associated(block))
- block % provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:) &
- + rk_substep_weights(rk_step) * block % tend % u % array(:,:)
- block % provis % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:) &
- + rk_substep_weights(rk_step) * block % tend % h % array(:,:)
- do iCell=1,block % mesh % nCells
- do k=1,block % mesh % nVertLevels
- block % provis % tracers % array(:,k,iCell) = ( block % state % time_levs(1) % state % h % array(k,iCell) * &
- block % state % time_levs(1) % state % tracers % array(:,k,iCell) &
- + rk_substep_weights(rk_step) * block % tend % tracers % array(:,k,iCell) &
- ) / block % provis % h % array(k,iCell)
+ block_d = block
+!$OMP TASK FIRSTPRIVATE(block_d) PRIVATE(iCell,k)
+ block_d % provis % u % array(:,:) = block_d % state % time_levs(1) % state % u % array(:,:) &
+ + rk_substep_weights(rk_step) * block_d % tend % u % array(:,:)
+ block_d % provis % h % array(:,:) = block_d % state % time_levs(1) % state % h % array(:,:) &
+ + rk_substep_weights(rk_step) * block_d % tend % h % array(:,:)
+ do iCell=1,block_d % mesh % nCells
+ do k=1,block_d % mesh % nVertLevels
+ block_d % provis % tracers % array(:,k,iCell) = ( block_d % state % time_levs(1) % state % h % array(k,iCell) * &
+ block_d % state % time_levs(1) % state % tracers % array(:,k,iCell) &
+ + rk_substep_weights(rk_step) * block_d % tend % tracers % array(:,k,iCell) &
+ ) / block_d % provis % h % array(k,iCell)
end do
end do
if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ block_d % provis % u % array(:,:) = block_d % state % time_levs(1) % state % u % array(:,:)
end if
- call sw_compute_solve_diagnostics(dt, block % provis, block % mesh)
+ call sw_compute_solve_diagnostics(dt, block_d % provis, block_d % mesh)
+!$OMP END TASK
block => block % next
end do
end if
+!$OMP TASKWAIT
!--- accumulate update (for RK4)
block => domain % blocklist
do while (associated(block))
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % u % array(:,:) &
- + rk_weights(rk_step) * block % tend % u % array(:,:)
- block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(2) % state % h % array(:,:) &
- + rk_weights(rk_step) * block % tend % h % array(:,:)
- do iCell=1,block % mesh % nCells
- do k=1,block % mesh % nVertLevels
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
- + rk_weights(rk_step) * block % tend % tracers % array(:,k,iCell)
+ block_d = block
+!$OMP TASK FIRSTPRIVATE(block_d) PRIVATE(iCell,k)
+ block_d % state % time_levs(2) % state % u % array(:,:) = block_d % state % time_levs(2) % state % u % array(:,:) &
+ + rk_weights(rk_step) * block_d % tend % u % array(:,:)
+ block_d % state % time_levs(2) % state % h % array(:,:) = block_d % state % time_levs(2) % state % h % array(:,:) &
+ + rk_weights(rk_step) * block_d % tend % h % array(:,:)
+ do iCell=1,block_d % mesh % nCells
+ do k=1,block_d % mesh % nVertLevels
+ block_d % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block_d % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ + rk_weights(rk_step) * block_d % tend % tracers % array(:,k,iCell)
end do
end do
+!$OMP END TASK
block => block % next
end do
+!$OMP TASKWAIT
end do
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -190,31 +211,39 @@
!
block => domain % blocklist
do while (associated(block))
- do iCell=1,block % mesh % nCells
- do k=1,block % mesh % nVertLevels
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
- / block % state % time_levs(2) % state % h % array(k,iCell)
+ block_d = block
+!$OMP TASK FIRSTPRIVATE(block_d) PRIVATE(iCell,k)
+ do iCell=1,block_d % mesh % nCells
+ do k=1,block_d % mesh % nVertLevels
+ block_d % state % time_levs(2) % state % tracers % array(:,k,iCell) = &
+ block_d % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ / block_d % state % time_levs(2) % state % h % array(k,iCell)
end do
end do
if (config_test_case == 1) then ! For case 1, wind field should be fixed
- block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ block_d % state % time_levs(2) % state % u % array(:,:) = block_d % state % time_levs(1) % state % u % array(:,:)
end if
- call sw_compute_solve_diagnostics(dt, block % state % time_levs(2) % state, block % mesh)
+ call sw_compute_solve_diagnostics(dt, block_d % state % time_levs(2) % state, block_d % mesh)
- call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
- block % state % time_levs(2) % state % uReconstructX % array, &
- block % state % time_levs(2) % state % uReconstructY % array, &
- block % state % time_levs(2) % state % uReconstructZ % array, &
- block % state % time_levs(2) % state % uReconstructZonal % array, &
- block % state % time_levs(2) % state % uReconstructMeridional % array &
+ call mpas_reconstruct(block_d % mesh, block_d % state % time_levs(2) % state % u % array, &
+ block_d % state % time_levs(2) % state % uReconstructX % array, &
+ block_d % state % time_levs(2) % state % uReconstructY % array, &
+ block_d % state % time_levs(2) % state % uReconstructZ % array, &
+ block_d % state % time_levs(2) % state % uReconstructZonal % array, &
+ block_d % state % time_levs(2) % state % uReconstructMeridional % array &
)
+!$OMP END TASK
block => block % next
end do
+!$OMP TASKWAIT
+!$OMP END SINGLE
+
+!$OMP END PARALLEL
+
call mpas_deallocate_provis_states(domain % blocklist)
end subroutine sw_rk4
</font>
</pre>