[cig-commits] r20851 - seismo/3D/FAULT_SOURCE/branches/new_fault_db/src

[surendra at geodynamics.org]

Author: surendra
Date: 2012-10-18 12:40:57 -0700 (Thu, 18 Oct 2012)
New Revision: 20851

Modified:
   seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90
   seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90
Log:
Fixed issue with assembling routines.  Order matters while adding floating point numbers

Modified: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90	2012-10-18 17:09:45 UTC (rev 20850)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90	2012-10-18 19:40:57 UTC (rev 20851)
@@ -244,3 +244,104 @@
   endif
 
   end subroutine assemble_MPI_vector_ext_mesh_w
+!-------------------------------------------------------------------------------------------------
+!
+
+  subroutine assemble_MPI_vector_ext_mesh_w_ordered(NPROC,NGLOB_AB,array_val, &
+            buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+            nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+            request_send_vector_ext_mesh,request_recv_vector_ext_mesh,my_neighbours_ext_mesh,myrank)
+
+! waits for data to receive and assembles
+
+  implicit none
+
+  include "constants.h"
+
+! array to assemble
+  real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
+
+  integer :: NPROC
+  integer :: NGLOB_AB
+
+  real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+       buffer_recv_vector_ext_mesh
+
+  integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+  integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+  integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+  integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+
+  integer ipoin,iinterface
+
+ !Surendra : for storing values in this processor
+  real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: mybuffer
+  integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+  logical :: ADDED_mycontri
+  integer :: myrank,iglob,my_iinterface,my_ipoin
+
+
+! here we have to assemble all the contributions between partitions using MPI
+
+! assemble only if more than one partition
+  if(NPROC > 1) then
+
+! wait for communications completion (recv)
+  do iinterface = 1, num_interfaces_ext_mesh
+    call wait_req(request_recv_vector_ext_mesh(iinterface))
+  enddo
+
+! save array_val & equate to zero
+  do iinterface = 1, num_interfaces_ext_mesh
+    do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+      mybuffer(:,ipoin,iinterface) = array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface))
+      array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) = 0._CUSTOM_REAL
+    enddo
+  enddo
+
+
+  ADDED_mycontri = .false.
+! adding contributions of neighbours
+  do iinterface = 1, num_interfaces_ext_mesh
+
+    if(myrank < my_neighbours_ext_mesh(iinterface) .and. .NOT.ADDED_mycontri) then
+      do my_iinterface = 1, num_interfaces_ext_mesh
+        do my_ipoin = 1, nibool_interfaces_ext_mesh(my_iinterface)
+          iglob = ibool_interfaces_ext_mesh(my_ipoin,my_iinterface)
+          array_val(:,iglob) = array_val(:,iglob) + mybuffer(:,my_ipoin,my_iinterface)
+        enddo
+      enddo
+      ADDED_mycontri = .true.
+    endif
+
+    do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+       iglob = ibool_interfaces_ext_mesh(ipoin,iinterface)
+      array_val(:,iglob) = array_val(:,iglob) + buffer_recv_vector_ext_mesh(:,ipoin,iinterface)
+    enddo
+  enddo
+
+  if(.NOT.ADDED_mycontri) then
+    do my_iinterface = 1, num_interfaces_ext_mesh
+      do my_ipoin = 1, nibool_interfaces_ext_mesh(my_iinterface)
+        iglob = ibool_interfaces_ext_mesh(my_ipoin,my_iinterface)
+        array_val(:,iglob) = array_val(:,iglob) + mybuffer(:,my_ipoin,my_iinterface)
+      enddo
+    enddo
+  ADDED_mycontri = .true.
+  endif 
+
+
+! wait for communications completion (send)
+  do iinterface = 1, num_interfaces_ext_mesh
+    call wait_req(request_send_vector_ext_mesh(iinterface))
+  enddo
+
+  endif
+
+  end subroutine assemble_MPI_vector_ext_mesh_w_ordered
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+

Modified: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90	2012-10-18 17:09:45 UTC (rev 20850)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90	2012-10-18 19:40:57 UTC (rev 20851)
@@ -181,19 +181,21 @@
                         
     else
       ! waits for send/receive requests to be completed and assembles values
-      call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
+      call assemble_MPI_vector_ext_mesh_w_ordered(NPROC,NGLOB_AB,accel, &
                         buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,&
                         max_nibool_interfaces_ext_mesh, &
                         nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
-                        request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+                        request_send_vector_ext_mesh,request_recv_vector_ext_mesh, &
+                        max_nibool_interfaces_ext_mesh,myrank)
 
       ! adjoint simulations
       if( SIMULATION_TYPE == 3 ) then  
-        call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_ADJOINT,b_accel, &
+        call assemble_MPI_vector_ext_mesh_w_ordered(NPROC,NGLOB_ADJOINT,b_accel, &
                         b_buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,&
                         max_nibool_interfaces_ext_mesh, &
                         nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
-                        b_request_send_vector_ext_mesh,b_request_recv_vector_ext_mesh)      
+                        b_request_send_vector_ext_mesh,b_request_recv_vector_ext_mesh, &      
+                        max_nibool_interfaces_ext_mesh,myrank)
       endif !adjoint
       
     endif