MAKE_NH_Enhanced_ASSIGN_PROP.f90 File Reference

Go to the source code of this file.

Functions/Subroutines
subroutine	make_nh_enhanced_assign_prop (nn_loc, nmat, prop_mat, sdeg_mat, ne_loc, cs_nnz_loc, cs_loc, node_nhe_flag, count, nn_src_ind_loc, qs, qp, lambda_nhe, mu_nhe, rho_nhe, qs_nhe_el, qp_nhe_el, mpi_id, mpi_comm)
	...Not-Honoring Enhanced (NHE) Implementation

Function/Subroutine Documentation

make_nh_enhanced_assign_prop()

subroutine make_nh_enhanced_assign_prop	(	integer*4	nn_loc,
		integer*4	nmat,
		real*8, dimension(nmat,4)	prop_mat,
		integer*4, dimension(nmat)	sdeg_mat,
		integer*4	ne_loc,
		integer*4	cs_nnz_loc,
		integer*4, dimension(0:cs_nnz_loc)	cs_loc,
		integer*4, dimension(nn_loc)	node_nhe_flag,
		integer*4	count,
		integer*4, dimension(count)	nn_src_ind_loc,
		real*8, dimension(nmat)	qs,
		real*8, dimension(nmat)	qp,
		real*8, dimension(nn_loc), intent(inout)	lambda_nhe,
		real*8, dimension(nn_loc), intent(inout)	mu_nhe,
		real*8, dimension(nn_loc), intent(inout)	rho_nhe,
		real*4, dimension(ne_loc)	qs_nhe_el,
		real*4, dimension(ne_loc)	qp_nhe_el,
		integer*4	mpi_id,
		integer*4	mpi_comm
	)

...Not-Honoring Enhanced (NHE) Implementation

Author

Srihari Sangaraju

Date

August, 2020

Version

1.0 @ Detailed Explanation

1. User Can specify that a single block/multiple blocks in mesh has to use material properties as per provided Tomography text file
2. For the each GLL node in NHE-specified blocks, this subroutine assigns Mechanical properties of the corresponding nearest point it can find in "Tomography text file"
3. For the nodes in other blocks It assigns Mechanical properties specified in *.mate file Note: In this version, This subroutine will be run, only if atleast 1 block is specified to use NHE in *.mate file

Parameters

[in]	loc_n_num.	Global node number of 'i'th local node is loc_n_num(i)
[in]	nn_loc.	No. of nodes in Local/Current Partition
[in]	nmat_nhe	No. of Blocks specified with NHE case
[in]	nhe_mat	Tag/Labels of Blocks where NHE has to be implemented
[in]	xs_loc	x-coordinate of spectral nodes
[in]	ys_loc	y-coordinate of spectral nodes
[in]	zs_loc	z-coordinate of spectral nodes
[out]	lambda_nhe	Lame coefficient lambda
[out]	mu_nhe	Lame coefficient mu
[out]	rho_nhe	material density
[out]	Qs_nhe	quality factor for S-waves (Standard Linear Solid damping)
[out]	Qp_nhe	quality factor for P-waves (Standard Linear Solid damping)
[out]	gamma_dmp_nhe	damping coefficient gamma (Kosloff&Kosloff)

Definition at line 53 of file MAKE_NH_Enhanced_ASSIGN_PROP.f90.

 
     !use speed_par
 
     implicit none
 
     include 'SPEED.MPI'
    
     integer*4 :: nn_loc, mpi_id, nmat, count, mpi_comm, mpi_ierr
     integer*4, dimension(nmat) :: sdeg_mat
     integer*4, dimension(nn_loc) :: node_nhe_flag
     integer*4, dimension(count) ::  NN_src_ind_loc
     
     real*8, dimension(nmat) :: QS, QP
     real*8, dimension(nn_loc), intent(inout) :: lambda_nhe, mu_nhe, rho_nhe
     real*4, dimension(nn_loc) :: Qs_nhe, Qp_nhe !gamma_dmp_nhe
 
     integer*4 :: ne_loc, cs_nnz_loc
     integer*4, dimension(0:cs_nnz_loc) :: cs_loc
     real*4, dimension(ne_loc) :: Qs_nhe_el, Qp_nhe_el !gamma_dmp_nhe_el
 
     character*70 :: file_tomo
     integer*4 :: npts_tomo, stat, error
     real*4, dimension(:), allocatable :: tomo_rho, tomo_vs, tomo_vp, tomo_qs, tomo_qp
     real*8, dimension(nmat,4) :: prop_mat
 
     real*8 :: t0, t1, time_elapsed, dummy, vs_dum, vp_dum
     integer*4 :: i, j, ipt, inode, ie
     integer*4 :: im, istart, iend, nn
 
     rho_nhe = 0.d0; mu_nhe = 0.d0; lambda_nhe = 0.d0;
     qs_nhe_el = 0.d0; qp_nhe_el = 0.d0;
     qs_nhe = 0.d0; qp_nhe = 0.d0;
 
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     ! reading tomography grid points data
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     ! tomo_xyz_mech.in = text file with tomography data
     ! 1st line = no. of tomo points(npts_tomo)
     ! 2nd to(npts_tomo+1)th line contains 8 columns:
     ! x_cord y_cord z_cord rho vs vp qs qp(units must be same as given in *.mate file)
     file_tomo = 'tomo_xyz_mech.in'
 
     if(mpi_id .eq.0) then
      open(124,file=file_tomo)
      read(124,*) 
      read(124,*) npts_tomo
     endif
     call mpi_bcast(npts_tomo,1,speed_integer,0,mpi_comm,mpi_ierr)
 
     if(mpi_id.eq.0) then
        allocate(tomo_rho(npts_tomo),tomo_vs(npts_tomo),tomo_vp(npts_tomo),tomo_qs(npts_tomo),tomo_qp(npts_tomo))
        do ipt = 1, npts_tomo
          read(124,*)dummy, dummy, dummy, tomo_rho(ipt), tomo_vs(ipt), tomo_vp(ipt), tomo_qs(ipt), tomo_qp(ipt)
        enddo
        close(124)
     endif
 
 
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     ! assigning properties to each node based on their nearest neighbor
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      !!!!!!!!!!!!!!! Rho !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      if (mpi_id.ne.0) then
        allocate(tomo_rho(npts_tomo))
      endif
 
      call mpi_barrier(mpi_comm, mpi_ierr)
      call mpi_bcast(tomo_rho, npts_tomo, speed_integer, 0, mpi_comm, mpi_ierr)
 
      i = 0
      do inode=1,nn_loc
          if ((node_nhe_flag(inode).eq.999)) then
            i = i + 1
            rho_nhe(inode) = tomo_rho(nn_src_ind_loc(i))
          else
            rho_nhe(inode) = prop_mat(node_nhe_flag(inode),1)
          endif
      enddo
      deallocate(tomo_rho)
 
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!  Mu !!!!!!!!!!!!!!!!!!!!!!!
      if (mpi_id.ne.0) then
        allocate(tomo_vs(npts_tomo))
      endif
 
      call mpi_barrier(mpi_comm, mpi_ierr)
      call mpi_bcast(tomo_vs, npts_tomo, speed_integer, 0, mpi_comm, mpi_ierr)
 
      i = 0
      do inode=1,nn_loc
          if ((node_nhe_flag(inode).eq.999)) then 
            i = i + 1
            vs_dum = tomo_vs(nn_src_ind_loc(i))
            mu_nhe(inode) = rho_nhe(inode) * vs_dum**2
          else
            mu_nhe(inode) = prop_mat(node_nhe_flag(inode),3)
          endif
      enddo
      deallocate(tomo_vs)
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!  Lambda !!!!!!!!!!!!!!!!!!!!!!!
      if (mpi_id.ne.0) then
        allocate(tomo_vp(npts_tomo))
      endif
 
      call mpi_barrier(mpi_comm, mpi_ierr)
      call mpi_bcast(tomo_vp, npts_tomo, speed_integer, 0, mpi_comm, mpi_ierr)
 
      i = 0
      do inode=1,nn_loc
          if ((node_nhe_flag(inode).eq.999)) then
            i = i + 1
            vp_dum = tomo_vp(nn_src_ind_loc(i))
            vs_dum = mu_nhe(inode)/rho_nhe(inode)
            lambda_nhe(inode) = rho_nhe(inode) * (vp_dum**2 - 2*vs_dum) 
          else
            lambda_nhe(inode) = prop_mat(node_nhe_flag(inode),2)
          endif
      enddo
      deallocate(tomo_vp)
 
 
      !!!!!!!!!!!!!!!!!!!!!!!!!! Qs !!!!!!!!!!!!!!!!!!!!!!!
      if (mpi_id.ne.0) then
        allocate(tomo_qs(npts_tomo))
      endif
 
      call mpi_barrier(mpi_comm, mpi_ierr)
      call mpi_bcast(tomo_qs, npts_tomo, speed_integer, 0, mpi_comm, mpi_ierr)
 
      i = 0
      do inode=1,nn_loc
          if ((node_nhe_flag(inode).eq.999)) then
            i = i + 1
            qs_nhe(inode) = tomo_qs(nn_src_ind_loc(i))
          else
            qs_nhe(inode) = qs(node_nhe_flag(inode))
          endif
      enddo
      deallocate(tomo_qs)
 
      !!!!!!!!!!!!!!!!!!!!!!!!!! Qp !!!!!!!!!!!!!!!!!!!!!!!
      if (mpi_id.ne.0) then
        allocate(tomo_qp(npts_tomo))
      endif
 
      call mpi_barrier(mpi_comm, mpi_ierr)
      call mpi_bcast(tomo_qp, npts_tomo, speed_integer, 0, mpi_comm, mpi_ierr)
 
      i = 0
      do inode=1,nn_loc
          if ((node_nhe_flag(inode).eq.999)) then
            i = i + 1
            qp_nhe(inode) = tomo_qp(nn_src_ind_loc(i))
          else
            qp_nhe(inode) = qp(node_nhe_flag(inode))
          endif
      enddo
      deallocate(tomo_qp)
 
     call mpi_barrier(mpi_comm, mpi_ierr)
 
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
     !!!!! Making Qs, Qp for Element instead of Each node (To save Memory)
 
     qs_nhe_el = 0;
     qp_nhe_el = 0;
 
     do ie = 1,ne_loc
        im = cs_loc(cs_loc(ie -1))
        nn = sdeg_mat(im) + 1
        istart = cs_loc(ie-1) + 1
        iend = cs_loc(ie) - 1
 
        do j = istart,iend
            qs_nhe_el(ie) = qs_nhe_el(ie) + qs_nhe(cs_loc(j))
            qp_nhe_el(ie) = qp_nhe_el(ie) + qp_nhe(cs_loc(j))
        enddo
        qs_nhe_el(ie) = qs_nhe_el(ie)/(nn**3)
        qp_nhe_el(ie) = qp_nhe_el(ie)/(nn**3)
      enddo !ie=1,ne_loc
 

Referenced by make_nh_enhanced().

Here is the caller graph for this function: