[cig-commits] [commit] devel: moved Seismic Unix reader to subroutine (9b5755d)

[cig_noreply at geodynamics.org]

Repository : https://github.com/geodynamics/specfem2d

On branch  : devel
Link       : https://github.com/geodynamics/specfem2d/compare/5d9c6086eb1fd7747d58089e11875116d45b4277...9b5755d28b601d380cb365841af5f95863815e3d

>---------------------------------------------------------------

commit 9b5755d28b601d380cb365841af5f95863815e3d
Author: rmodrak <rmodrak at princeton.edu>
Date:   Thu Dec 11 13:12:26 2014 -0500

    moved Seismic Unix reader to subroutine


>---------------------------------------------------------------

9b5755d28b601d380cb365841af5f95863815e3d
 src/specfem2D/setup_sources_receivers.F90 | 62 +++++++++++++++++++++++++++++++
 src/specfem2D/specfem2D.F90               | 42 +--------------------
 2 files changed, 64 insertions(+), 40 deletions(-)

diff --git a/src/specfem2D/setup_sources_receivers.F90 b/src/specfem2D/setup_sources_receivers.F90
index c28e50a..d68dafd 100644
--- a/src/specfem2D/setup_sources_receivers.F90
+++ b/src/specfem2D/setup_sources_receivers.F90
@@ -164,3 +164,65 @@
 
   end subroutine setup_sources_receivers
 
+
+
+! =====
+
+subroutine add_adjoint_sources_SU
+
+  use specfem_par, only: myrank, NSTEP, nrec, xi_receiver, gamma_receiver, which_proc_receiver, &
+                         xigll,zigll,hxir,hgammar,hpxir,hpgammar, &
+                         adj_sourcearray, adj_sourcearrays, &
+                         r4head, header2, filename
+
+  include "constants.h"
+
+  integer :: i, k, irec, irec_local
+
+  real(kind=CUSTOM_REAL), allocatable, dimension(:,:) :: adj_src_s
+
+  integer :: ios
+
+   irec_local = 0
+   write(filename, "('./SEM/Ux_file_single.bin.adj')")
+   open(111,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ios)
+           if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
+   write(filename, "('./SEM/Uy_file_single.bin.adj')")
+   open(112,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ios)
+           if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
+   write(filename, "('./SEM/Uz_file_single.bin.adj')")
+   open(113,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ios)
+           if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
+
+   allocate(adj_src_s(NSTEP,3))
+   adj_src_s(:,:) = 0.
+
+   do irec = 1, nrec
+     if(myrank == which_proc_receiver(irec)) then
+      irec_local = irec_local + 1
+      adj_sourcearray(:,:,:,:) = 0.0
+      read(111,rec=irec,iostat=ios) r4head, adj_src_s(:,1)
+           if (ios /= 0) call exit_MPI(' file '//trim(filename)//' read error')
+      read(112,rec=irec,iostat=ios) r4head, adj_src_s(:,2)
+           if (ios /= 0) call exit_MPI(' file '//trim(filename)//' read error')
+      read(113,rec=irec,iostat=ios) r4head, adj_src_s(:,3)
+           if (ios /= 0) call exit_MPI(' file '//trim(filename)//' read error')
+      header2=int(r4head(29), kind=2)
+      if (irec==1) print*, r4head(1),r4head(19),r4head(20),r4head(21),r4head(22),header2(2)
+      call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+      call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+      do k = 1, NGLLZ
+          do i = 1, NGLLX
+            adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
+          enddo
+      enddo
+      adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
+     endif !  if(myrank == which_proc_receiver(irec))
+   enddo ! irec
+   close(111)
+   close(112)
+   close(113)
+   deallocate(adj_src_s)
+
+end subroutine
+
diff --git a/src/specfem2D/specfem2D.F90 b/src/specfem2D/specfem2D.F90
index 01722c0..4fd96ae 100644
--- a/src/specfem2D/specfem2D.F90
+++ b/src/specfem2D/specfem2D.F90
@@ -1582,46 +1582,8 @@
            adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
          endif
        enddo
-    else
-       irec_local = 0
-       write(filename, "('./SEM/Ux_file_single.bin.adj')")
-       open(111,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ios)
-               if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
-       write(filename, "('./SEM/Uy_file_single.bin.adj')")
-       open(112,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ios)
-               if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
-       write(filename, "('./SEM/Uz_file_single.bin.adj')")
-       open(113,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ios)
-               if (ios /= 0) call exit_MPI(' file '//trim(filename)//'does not exist')
-
-       allocate(adj_src_s(NSTEP,3))
-
-       do irec = 1, nrec
-         if(myrank == which_proc_receiver(irec))then
-          irec_local = irec_local + 1
-          adj_sourcearray(:,:,:,:) = 0.0
-          read(111,rec=irec,iostat=ios) r4head, adj_src_s(:,1)
-               if (ios /= 0) call exit_MPI(' file '//trim(filename)//' read error')
-          read(112,rec=irec,iostat=ios) r4head, adj_src_s(:,2)
-               if (ios /= 0) call exit_MPI(' file '//trim(filename)//' read error')
-          read(113,rec=irec,iostat=ios) r4head, adj_src_s(:,3)
-               if (ios /= 0) call exit_MPI(' file '//trim(filename)//' read error')
-          header2=int(r4head(29), kind=2)
-          if (irec==1) print*, r4head(1),r4head(19),r4head(20),r4head(21),r4head(22),header2(2)
-          call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
-          call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
-          do k = 1, NGLLZ
-              do i = 1, NGLLX
-                adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
-              enddo
-          enddo
-          adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
-         endif !  if(myrank == which_proc_receiver(irec))
-       enddo ! irec
-       close(111)
-       close(112)
-       close(113)
-       deallocate(adj_src_s)
+    else ! (SU_FORMAT)
+        call add_adjoint_sources_SU()
     endif
   else
      allocate(adj_sourcearrays(1,1,1,1,1))