boundary_absorbing.f90

Go to the documentation of this file.

!#############################################################################
!#                                                                           #
!# fosite - 3D hydrodynamical simulation program                             #
!# module: boundary_absorbing.f90                                            #
!#                                                                           #
!# Copyright (C) 2009-2014                                                   #
!# Tobias Illenseer <tillense@astrophysik.uni-kiel.de>                       #
!#                                                                           #
!# This program is free software; you can redistribute it and/or modify      #
!# it under the terms of the GNU General Public License as published by      #
!# the Free Software Foundation; either version 2 of the License, or (at     #
!# your option) any later version.                                           #
!#                                                                           #
!# This program is distributed in the hope that it will be useful, but       #
!# WITHOUT ANY WARRANTY; without even the implied warranty of                #
!# MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, GOOD TITLE or        #
!# NON INFRINGEMENT.  See the GNU General Public License for more            #
!# details.                                                                  #
!#                                                                           #
!# You should have received a copy of the GNU General Public License         #
!# along with this program; if not, write to the Free Software               #
!# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.                 #
!#                                                                           #
!#############################################################################

!----------------------------------------------------------------------------!
!----------------------------------------------------------------------------!
MODULE boundary_absorbing_mod
  USE marray_compound_mod
  USE mesh_base_mod
  USE boundary_base_mod
  USE physics_base_mod
  USE common_dict
  IMPLICIT NONE
  !--------------------------------------------------------------------------!
  PRIVATE
  TYPE, EXTENDS(boundary_base) :: boundary_absorbing
    REAL, DIMENSION(:,:,:), ALLOCATABLE :: xvar, & !< characteristic variables for absorbing bc
                                         lambda
  CONTAINS
    PROCEDURE :: initboundary_absorbing
    PROCEDURE :: setboundarydata
    PROCEDURE :: finalize
  END TYPE boundary_absorbing
  CHARACTER(LEN=32), PARAMETER  :: boundcond_name = "absorbing"
  !--------------------------------------------------------------------------!
  PUBLIC :: &
    boundary_absorbing
    !--------------------------------------------------------------------------!

CONTAINS

  SUBROUTINE initboundary_absorbing(this,Mesh,Physics,dir,config)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(Boundary_absorbing), INTENT(INOUT) :: this
    CLASS(Mesh_base),          INTENT(IN)    :: Mesh
    CLASS(Physics_base),       INTENT(IN)    :: Physics
    TYPE(Dict_TYP), POINTER,   INTENT(IN)    :: config
    INTEGER,                   INTENT(IN)    :: dir
    !------------------------------------------------------------------------!
    INTEGER                                  :: err
    !------------------------------------------------------------------------!
    CALL this%InitBoundary(mesh,physics,absorbing,boundcond_name,dir,config)
    ! check if physics supports absorbing boundary conditions
    IF (.NOT.physics%supports_absorbing) &
       CALL this%Error("InitBoundary_absorbing", &
                  "boundary condition not supported for this type of physics")
    SELECT CASE(this%direction%GetType())
    CASE(west,east)
       ALLOCATE(this%xvar(mesh%JMIN:mesh%JMAX,mesh%KMIN:mesh%KMAX,physics%VNUM), &
            this%lambda(mesh%JMIN:mesh%JMAX,mesh%KMIN:mesh%KMAX,physics%VNUM), &
            stat=err)
    CASE(south,north)
       ALLOCATE(this%xvar(mesh%IMIN:mesh%IMAX,mesh%KMIN:mesh%KMAX,physics%VNUM), &
            this%lambda(mesh%IMIN:mesh%IMAX,mesh%KMIN:mesh%KMAX,physics%VNUM), &
            stat=err)
    CASE(bottom,top)
       ALLOCATE(this%xvar(mesh%IMIN:mesh%IMAX,mesh%JMIN:mesh%JMAX,physics%VNUM), &
            this%lambda(mesh%IMIN:mesh%IMAX,mesh%JMIN:mesh%JMAX,physics%VNUM), &
            stat=err)
    END SELECT
    IF (err.NE.0) &
         CALL this%Error("InitBoundary_absorbing", "Unable to allocate memory.")
    ! initialize the data
    this%xvar(:,:,:) = 0.0
    this%lambda(:,:,:) = 0.0
  END SUBROUTINE initboundary_absorbing


  PURE SUBROUTINE setboundarydata(this,Mesh,Physics,time,pvar)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(boundary_absorbing),INTENT(INOUT) :: this
    CLASS(mesh_base),         INTENT(IN) :: mesh
    CLASS(physics_base),      INTENT(IN) :: physics
    REAL,                     INTENT(IN) :: time
    CLASS(marray_compound), INTENT(INOUT) :: pvar
    !------------------------------------------------------------------------!
    INTEGER       :: i,j,k
    !------------------------------------------------------------------------!
    SELECT CASE(this%direction%GetType())
    CASE(west)
      ! get characteristic variables
      CALL physics%CalculateCharSystemX(mesh,mesh%IMIN,mesh%IMIN+1,pvar,this%lambda,this%xvar)
      ! set characteristic variables to zero for all incomming waves
      WHERE (this%lambda(:,:,:).GE.0.0)
        this%xvar(:,:,:) = 0.0
      END WHERE
      ! transform back to primitive variables at the boundary
      CALL physics%CalculateBoundaryDataX(mesh,mesh%IMIN,mesh%IMIN-1,this%xvar,pvar)
      ! copy data to outer ghost cells
      DO i=2,mesh%GINUM
        pvar%data4d(mesh%IMIN-i,mesh%JMIN:mesh%JMAX,mesh%KMIN:mesh%KMAX,:) &
          = pvar%data4d(mesh%IMIN-1,mesh%JMIN:mesh%JMAX,mesh%KMIN:mesh%KMAX,:)
      END DO
    CASE(east)
      ! get characteristic variables
      CALL physics%CalculateCharSystemX(mesh,mesh%IMAX,mesh%IMAX-1,pvar,this%lambda,this%xvar)
      ! set characteristic variables to zero for all incomming waves
      WHERE (this%lambda(:,:,:).LE.0.0)
        this%xvar(:,:,:) = 0.0
      END WHERE
      ! transform back to primitive variables at the boundary
      CALL physics%CalculateBoundaryDataX(mesh,mesh%IMAX,mesh%IMAX+1,this%xvar,pvar)
      ! copy data to outer ghost cells
      DO i=2,mesh%GINUM
        pvar%data4d(mesh%IMAX+i,mesh%JMIN:mesh%JMAX,mesh%KMIN:mesh%KMAX,:) &
          = pvar%data4d(mesh%IMAX+1,mesh%JMIN:mesh%JMAX,mesh%KMIN:mesh%KMAX,:)
      END DO
    CASE(south)
      ! get characteristic variables
      CALL physics%CalculateCharSystemY(mesh,mesh%JMIN,mesh%JMIN+1,pvar,this%lambda,this%xvar)
      ! set characteristic variables to zero for all incomming waves
      WHERE (this%lambda(:,:,:).GE.0.0)
        this%xvar(:,:,:) = 0.0
      END WHERE
      ! transform back to primitive variables at the boundary
      CALL physics%CalculateBoundaryDataY(mesh,mesh%JMIN,mesh%JMIN-1,this%xvar,pvar)
      ! copy data to outer ghost cells
      DO j=2,mesh%GJNUM
        pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMIN-j,mesh%KMIN:mesh%KMAX,:) &
          = pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMIN-1,mesh%KMIN:mesh%KMAX,:)
      END DO
    CASE(north)
      ! get characteristic variables
      CALL physics%CalculateCharSystemY(mesh,mesh%JMAX,mesh%JMAX-1,pvar,this%lambda,this%xvar)
      ! set characteristic variables to zero for all incomming waves
      WHERE (this%lambda(:,:,:).LE.0.0)
        this%xvar(:,:,:) = 0.0
      END WHERE
      ! transform back to primitive variables at the boundary
      CALL physics%CalculateBoundaryDataY(mesh,mesh%JMAX,mesh%JMAX+1,this%xvar,pvar)
      ! copy data to outer ghost cells
      DO j=2,mesh%GJNUM
        pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMAX+j,mesh%KMIN:mesh%KMAX,:) &
          = pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMAX+1,mesh%KMIN:mesh%KMAX,:)
      END DO
    CASE(bottom)
      ! get characteristic variables
      CALL physics%CalculateCharSystemZ(mesh,mesh%KMIN,mesh%KMIN+1,pvar,this%lambda,this%xvar)
      ! set characteristic variables to zero for all incomming waves
      WHERE (this%lambda(:,:,:).GE.0.0)
        this%xvar(:,:,:) = 0.0
      END WHERE
      ! transform back to primitive variables at the boundary
      CALL physics%CalculateBoundaryDataZ(mesh,mesh%KMIN,mesh%KMIN-1,this%xvar,pvar)
      ! copy data to outer ghost cells
      DO k=2,mesh%GKNUM
        pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMIN:mesh%JMAX,mesh%KMIN-k,:) &
          = pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMIN:mesh%JMAX,mesh%KMIN-1,:)
      END DO
    CASE(top)
      ! get characteristic variables
      CALL physics%CalculateCharSystemZ(mesh,mesh%KMAX,mesh%KMAX-1,pvar,this%lambda,this%xvar)
      ! set characteristic variables to zero for all incomming waves
      WHERE (this%lambda(:,:,:).LE.0.0)
        this%xvar(:,:,:) = 0.0
      END WHERE
      ! transform back to primitive variables at the boundary
      CALL physics%CalculateBoundaryDataZ(mesh,mesh%KMAX,mesh%KMAX+1,this%xvar,pvar)
      ! copy data to outer ghost cells
      DO k=2,mesh%GKNUM
        pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMIN:mesh%JMAX,mesh%KMAX+k,:) &
          = pvar%data4d(mesh%IMIN:mesh%IMAX,mesh%JMIN:mesh%JMAX,mesh%KMAX+1,:)
      END DO
    END SELECT
  END SUBROUTINE setboundarydata


  SUBROUTINE finalize(this)
    IMPLICIT NONE
    !------------------------------------------------------------------------!
    CLASS(Boundary_absorbing), INTENT(INOUT) :: this
    !------------------------------------------------------------------------!
    DEALLOCATE(this%xvar,this%lambda)
    CALL this%Finalize_base()
  END SUBROUTINE finalize

END MODULE boundary_absorbing_mod