!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
!                                                                              |
!              ||===\\                                                         | 
!              ||    \\                                                        |
!              ||     ||   //==\\   ||  ||   //==||  ||/==\\                   |
!              ||     ||  ||    ||  ||  ||  ||   ||  ||    ||                  |
!              ||    //   ||    ||  ||  ||  ||   ||  ||                        |
!              ||===//     \\==//    \\==\\  \\==\\  ||                        |
!                                                                              |
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|
!                                                                              |
!              DEFINE_BC_SUBDUCTION    Apr. 2007                                   |
!                                                                              |
!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|

subroutine define_bc_subduction (nnode,kfix,kfixt,x,y,z,u,v,w,temp,vo) 

!------------------------------------------------------------------------------|
!(((((((((((((((( Purpose of the routine  ))))))))))))))))))))))))))))))))))))))
!------------------------------------------------------------------------------|
! this routine assigns the boundary condition for the Stokes sphere experiment 

!------------------------------------------------------------------------------|
!((((((((((((((((  declaration of the subroutine arguments  ))))))))))))))))))))
!------------------------------------------------------------------------------|

use definitions

implicit none

integer nnode
integer kfix(nnode*3)
integer kfixt(nnode)
double precision x(nnode),y(nnode),z(nnode)
double precision u(nnode),v(nnode),w(nnode)
double precision temp(nnode)
type (void) vo

!------------------------------------------------------------------------------|
!(((((((((((((((( declaration of the subroutine internal variables )))))))))))))
!------------------------------------------------------------------------------|

integer i
double precision eps

!------------------------------------------------------------------------------|
!------------------------------------------------------------------------------|

eps=1.d-10

   do i=1,nnode
      if (x(i).lt.eps) then
         kfix((i-1)*3+1)=1 ; u(i)=1.d0
      endif
      if (x(i).gt.1.d0-eps) then
         kfix((i-1)*3+1)=1 ; u(i)=1.d0
      endif
      if (y(i).lt.eps) then
         kfix((i-1)*3+2)=1 ; v(i)=0.d0
      endif
      if (y(i).gt.1.d0-eps) then
         kfix((i-1)*3+2)=1 ; v(i)=0.d0
      endif
      if (z(i).lt.eps) then
         kfix((i-1)*3+3)=1 ; w(i)=0.d0
         kfixt(i)=1
         temp(i)=1.d0
      endif
      if (z(i).gt.1.d0-eps) then
         kfix((i-1)*3+3)=1 ; w(i)=0.d0
           if ((x(i)-.4375d0+eps)*(x(i)-.5625d0-eps).le.0.d0 .and. &
               (y(i)-.4375d0+eps)*(y(i)-.5625d0-eps).le.0.d0) then
           kfix((i-1)*3+1)=1 ; u(i)=0.d0
           kfix((i-1)*3+2)=1 ; v(i)=0.d0
           endif
         kfixt(i)=1
         temp(i)=0.d0
      endif
      if (.not.vo%influid(i)) then
         kfixt(i)=1
         temp(i)=0.d0
      endif
   enddo


return
end

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------