!WRF+/AD:MODEL_LAYER:BOUNDARY
!Created by Ning Pan, 2010-08
!
MODULE a_module_bc 6
USE module_configure
USE module_wrf_error
USE module_model_constants
IMPLICIT NONE
! set the bdyzone. We are hardwiring this here and we'll
! decide later where it should be set and stored
INTEGER, PARAMETER :: bdyzone = 4
INTEGER, PARAMETER :: bdyzone_x = bdyzone
INTEGER, PARAMETER :: bdyzone_y = bdyzone
CONTAINS
!------------------------------------------------------------------------
SUBROUTINE a_set_physical_bc2d( a_dat, variable_in, & 17
config_flags, &
ids,ide, jds,jde, & ! domain dims
ims,ime, jms,jme, & ! memory dims
ips,ipe, jps,jpe, & ! patch dims
its,ite, jts,jte )
IMPLICIT NONE
INTEGER, INTENT(IN ) :: ids,ide, jds,jde
INTEGER, INTENT(IN ) :: ims,ime, jms,jme
INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe
INTEGER, INTENT(IN ) :: its,ite, jts,jte
CHARACTER, INTENT(IN ) :: variable_in
CHARACTER :: variable
REAL, DIMENSION( ims:ime , jms:jme ) :: a_dat
TYPE( grid_config_rec_type ) config_flags
INTEGER :: i, j, istag, jstag, itime
LOGICAL :: debug, open_bc_copy
real :: a_aux
!------------
a_aux = 0.0
debug = .false.
open_bc_copy = .false.
variable = variable_in
IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
ENDIF
IF ((variable == 'u') .or. (variable == 'v') .or. &
(variable == 'w') .or. (variable == 't') .or. &
(variable == 'x') .or. (variable == 'y') .or. &
(variable == 'r') .or. (variable == 'p') ) open_bc_copy = .true.
! begin, first set a staggering variable
istag = -1
jstag = -1
IF ((variable == 'u') .or. (variable == 'x')) istag = 0
IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
if(debug) then
write(6,*) ' in bc2d, var is ',variable, istag, jstag
write(6,*) ' b.cs are ', &
config_flags%periodic_x, &
config_flags%periodic_y
end if
IF ( variable == 'd' ) then !JDM
istag = 0
jstag = 0
ENDIF
IF ( variable == 'e' ) then !JDM
istag = 0
ENDIF
IF ( variable == 'f' ) then !JDM
jstag = 0
ENDIF
! fix corners for doubly periodic domains
IF ( config_flags%periodic_x .and. config_flags%periodic_y &
.and. (ids == ips) .and. (ide == ipe) &
.and. (jds == jps) .and. (jde == jpe) ) THEN
IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
DO j = bdyzone,1,-1
DO i = -(bdyzone-1),0,1
a_aux = a_dat(ids+i-1,jde+j+jstag)
a_dat(ids+i-1,jde+j+jstag) = 0.0
a_dat(ide+i-1,jds+j+jstag) = a_dat(ide+i-1,jds+j+jstag) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
DO j = bdyzone,1,-1
DO i = bdyzone,1,-1
a_aux = a_dat(ide+i+istag,jde+j+jstag)
a_dat(ide+i+istag,jde+j+jstag) = 0.0
a_dat(ids+i+istag,jds+j+jstag) = a_dat(ids+i+istag,jds+j+jstag) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
DO j = -(bdyzone-1),0,1
DO i = bdyzone,1,-1
a_aux = a_dat(ide+i+istag,jds+j-1)
a_dat(ide+i+istag,jds+j-1) = 0.0
a_dat(ids+i+istag,jde+j-1) = a_dat(ids+i+istag,jde+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill
DO j = -(bdyzone-1),0,1
DO i = -(bdyzone-1),0,1
a_aux = a_dat(ids+i-1,jds+j-1)
a_dat(ids+i-1,jds+j-1) = 0.0
a_dat(ide+i-1,jde+j-1) = a_dat(ide+i-1,jde+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
END IF
! same procedure in y
periodicity_y: IF( ( config_flags%periodic_y ) ) THEN
IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test of both north and south on processor
IF( jte == jde ) then
DO j = bdyzone,-jstag,-1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jde+j+jstag)
a_dat(i,jde+j+jstag) = 0.0
a_dat(i,jds+j+jstag) = a_dat(i,jds+j+jstag) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
IF( jts == jds ) then
DO j = -(bdyzone-1),0,1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jds+j-1)
a_dat(i,jds+j-1) = 0.0
a_dat(i,jde+j-1) = a_dat(i,jde+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
END IF
ELSE
! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
! now the open boundary copy at ye
open_ye: IF( ( config_flags%open_ye .or. &
config_flags%polar .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( jte == jde ) .and. open_bc_copy ) THEN
IF (variable /= 'v' .and. variable /= 'y' ) THEN
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jde )
a_dat(i,jde ) = 0.0
a_dat(i,jde-1) = a_dat(i,jde-1) + a_aux
a_aux = a_dat(i,jde+1)
a_dat(i,jde+1) = 0.0
a_dat(i,jde-1) = a_dat(i,jde-1) + a_aux
a_aux = a_dat(i,jde+2)
a_dat(i,jde+2) = 0.0
a_dat(i,jde-1) = a_dat(i,jde-1) + a_aux
a_aux = 0.0
ENDDO
ELSE
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jde+1)
a_dat(i,jde+1) = 0.0
a_dat(i,jde ) = a_dat(i,jde ) + a_aux
a_aux = a_dat(i,jde+2)
a_dat(i,jde+2) = 0.0
a_dat(i,jde ) = a_dat(i,jde ) + a_aux
a_aux = a_dat(i,jde+3)
a_dat(i,jde+3) = 0.0
a_dat(i,jde ) = a_dat(i,jde ) + a_aux
a_aux = 0.0
ENDDO
ENDIF
END IF open_ye
open_ys: IF( ( config_flags%open_ys .or. &
config_flags%polar .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( jts == jds) .and. open_bc_copy ) THEN
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jds-1)
a_dat(i,jds-1) = 0.0
a_dat(i,jds) = a_dat(i,jds) + a_aux
a_aux = a_dat(i,jds-2)
a_dat(i,jds-2) = 0.0
a_dat(i,jds) = a_dat(i,jds) + a_aux
a_aux = a_dat(i,jds-3)
a_dat(i,jds-3) = 0.0
a_dat(i,jds) = a_dat(i,jds) + a_aux
a_aux = 0.0
ENDDO
ENDIF open_ys
! now the symmetry boundary at ye
symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
( jte == jde ) ) THEN
IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
DO j = bdyzone,1,-1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jde+j-1)
a_dat(i,jde+j-1) = 0.0
a_dat(i,jde-j) = a_dat(i,jde-j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
IF (variable == 'v' ) THEN
DO j = bdyzone,1,-1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = - a_dat(i,jde+j)
a_dat(i,jde+j) = 0.0
a_dat(i,jde-j) = a_dat(i,jde-j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
DO j = bdyzone,1,-1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jde+j)
a_dat(i,jde+j) = 0.0
a_dat(i,jde-j) = a_dat(i,jde-j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
ENDIF
END IF symmetry_ye
symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
( jts == jds) ) THEN
IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
DO j = bdyzone,1,-1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jds-j)
a_dat(i,jds-j) = 0.0
a_dat(i,jds+j-1) = a_dat(i,jds+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
IF (variable == 'v') THEN
DO j = bdyzone,1,-1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = - a_dat(i,jds-j)
a_dat(i,jds-j) = 0.0
a_dat(i,jds+j) = a_dat(i,jds+j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
DO j = bdyzone,1,-1
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,jds-j)
a_dat(i,jds-j) = 0.0
a_dat(i,jds+j) = a_dat(i,jds+j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_ys
END IF periodicity_y
periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if east and west both on-processor
IF ( ite == ide ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = bdyzone,-istag,-1
a_aux = a_dat(ide+i+istag,j)
a_dat(ide+i+istag,j) = 0.0
a_dat(ids+i+istag,j) = a_dat(ids+i+istag,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDIF
IF ( its == ids ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = -(bdyzone-1),0,1
a_aux = a_dat(ids+i-1,j)
a_dat(ids+i-1,j) = 0.0
a_dat(ide+i-1,j) = a_dat(ide+i-1,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDIF
ENDIF
ELSE
! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
! now the open boundary copy at xe
open_xe: IF( ( config_flags%open_xe .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( ite == ide ) .and. open_bc_copy ) THEN
IF ( variable /= 'u' .and. variable /= 'x') THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
a_aux = a_dat(ide ,j)
a_dat(ide ,j) = 0.0
a_dat(ide-1,j) = a_dat(ide-1,j) + a_aux
a_aux = a_dat(ide+1,j)
a_dat(ide+1,j) = 0.0
a_dat(ide-1,j) = a_dat(ide-1,j) + a_aux
a_aux = a_dat(ide+2,j)
a_dat(ide+2,j) = 0.0
a_dat(ide-1,j) = a_dat(ide-1,j) + a_aux
a_aux = 0.0
ENDDO
ELSE
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
a_aux = a_dat(ide+1,j)
a_dat(ide+1,j) = 0.0
a_dat(ide,j) = a_dat(ide,j) + a_aux
a_aux = a_dat(ide+2,j)
a_dat(ide+2,j) = 0.0
a_dat(ide,j) = a_dat(ide,j) + a_aux
a_aux = a_dat(ide+3,j)
a_dat(ide+3,j) = 0.0
a_dat(ide,j) = a_dat(ide,j) + a_aux
a_aux = 0.0
ENDDO
END IF
END IF open_xe
open_xs: IF( ( config_flags%open_xs .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( its == ids ) .and. open_bc_copy ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
a_aux = a_dat(ids-1,j)
a_dat(ids-1,j) = 0.0
a_dat(ids,j) = a_dat(ids,j) + a_aux
a_aux = a_dat(ids-2,j)
a_dat(ids-2,j) = 0.0
a_dat(ids,j) = a_dat(ids,j) + a_aux
a_aux = a_dat(ids-3,j)
a_dat(ids-3,j) = 0.0
a_dat(ids,j) = a_dat(ids,j) + a_aux
a_aux = 0.0
ENDDO
ENDIF open_xs
! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
! now the symmetry boundary at xe
symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
( ite == ide ) ) THEN
IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = bdyzone,1,-1
a_aux = a_dat(ide+i-1,j)
a_dat(ide+i-1,j) = 0.0
a_dat(ide-i,j) = a_dat(ide-i,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
IF (variable == 'u' ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = bdyzone-1,0,-1
a_aux = - a_dat(ide+i,j)
a_dat(ide+i,j) = 0.0
a_dat(ide-i,j) = a_dat(ide-i,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = bdyzone-1,0,-1
a_aux = a_dat(ide+i,j)
a_dat(ide+i,j) = 0.0
a_dat(ide-i,j) = a_dat(ide-i,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
END IF
END IF symmetry_xe
symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
( its == ids ) ) THEN
IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = bdyzone,1,-1
a_aux = a_dat(ids-i,j)
a_dat(ids-i,j) = 0.0
a_dat(ide+i-1,j) = a_dat(ide+i-1,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
IF( variable == 'u' ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = bdyzone-1,0,-1
a_aux = - a_dat(ids-i,j)
a_dat(ids-i,j) = 0.0
a_dat(ids+i,j) = a_dat(ids+i,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO i = bdyzone-1,0,-1
a_aux = a_dat(ids-i,j)
a_dat(ids-i,j) = 0.0
a_dat(ids+i,j) = a_dat(ids+i,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_xs
END IF periodicity_x
END SUBROUTINE a_set_physical_bc2d
!-----------------------------------
SUBROUTINE a_set_physical_bc3d( a_dat, variable_in, & 98
config_flags, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
IMPLICIT NONE
INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
CHARACTER, INTENT(IN ) :: variable_in
CHARACTER :: variable
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: a_dat
TYPE( grid_config_rec_type ) config_flags
INTEGER :: i, j, k, istag, jstag, itime, k_end
LOGICAL :: debug, open_bc_copy
real :: a_aux
!------------
a_aux = 0.0
debug = .false.
open_bc_copy = .false.
variable = variable_in
IF ( variable_in .ge. 'A' .and. variable_in .le. 'Z' ) THEN
variable = CHAR( ICHAR(variable_in) - ICHAR('A') + ICHAR('a') )
ENDIF
IF ((variable == 'u') .or. (variable == 'v') .or. &
(variable == 'w') .or. (variable == 't') .or. &
(variable == 'd') .or. (variable == 'e') .or. &
(variable == 'x') .or. (variable == 'y') .or. &
(variable == 'f') .or. (variable == 'r') .or. &
(variable == 'p') ) open_bc_copy = .true.
! begin, first set a staggering variable
istag = -1
jstag = -1
k_end = max(1,min(kde-1,kte))
IF ((variable == 'u') .or. (variable == 'x')) istag = 0
IF ((variable == 'v') .or. (variable == 'y')) jstag = 0
IF ((variable == 'd') .or. (variable == 'xy')) then
istag = 0
jstag = 0
ENDIF
IF ((variable == 'e') ) then
istag = 0
k_end = min(kde,kte)
ENDIF
IF ((variable == 'f') ) then
jstag = 0
k_end = min(kde,kte)
ENDIF
IF ( variable == 'w') k_end = min(kde,kte)
! k_end = kte
if(debug) then
write(6,*) ' in bc, var is ',variable, istag, jstag, kte, k_end
write(6,*) ' b.cs are ', &
config_flags%periodic_x, &
config_flags%periodic_y
end if
! fix corners for doubly periodic domains
IF ( config_flags%periodic_x .and. config_flags%periodic_y &
.and. (ids == ips) .and. (ide == ipe) &
.and. (jds == jps) .and. (jde == jpe) ) THEN
IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = -(bdyzone-1),0,1
a_aux = a_dat(ids+i-1,k,jde+j+jstag)
a_dat(ids+i-1,k,jde+j+jstag) = 0.0
a_dat(ide+i-1,k,jds+j+jstag) = a_dat(ide+i-1,k,jds+j+jstag) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = a_dat(ide+i+istag,k,jde+j+jstag)
a_dat(ide+i+istag,k,jde+j+jstag) = 0.0
a_dat(ids+i+istag,k,jds+j+jstag) = a_dat(ids+i+istag,k,jds+j+jstag) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
DO j = -(bdyzone-1),0,1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = a_dat(ide+i+istag,k,jds+j-1)
a_dat(ide+i+istag,k,jds+j-1) = 0.0
a_dat(ids+i+istag,k,jde+j-1) = a_dat(ids+i+istag,k,jde+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
IF ( (its == ids) .and. (jts == jds) ) THEN ! lower left corner fill
DO j = -(bdyzone-1),0,1
DO k = kts, k_end
DO i = -(bdyzone-1),0,1
a_aux = a_dat(ids+i-1,k,jds+j-1)
a_dat(ids+i-1,k,jds+j-1) = 0.0
a_dat(ide+i-1,k,jde+j-1) = a_dat(ide+i-1,k,jde+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
END IF
! same procedure in y
periodicity_y: IF( ( config_flags%periodic_y ) ) THEN
IF ( ( jds == jps ) .and. ( jde == jpe ) ) THEN ! test if both north and south on processor
IF( jte == jde ) then
DO j = bdyzone,-jstag,-1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jde+j+jstag)
a_dat(i,k,jde+j+jstag) = 0.0
a_dat(i,k,jds+j+jstag) = a_dat(i,k,jds+j+jstag) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
IF( jts == jds ) then
DO j = -(bdyzone-1),0,1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jds+j-1)
a_dat(i,k,jds+j-1) = 0.0
a_dat(i,k,jde+j-1) = a_dat(i,k,jde+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
END IF
ELSE
! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
! now the open boundary copy at ye
open_ye: IF( ( config_flags%open_ye .or. &
config_flags%polar .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( jte == jde ) .and. open_bc_copy ) THEN
IF (variable /= 'v' .and. variable /= 'y' ) THEN
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jde )
a_dat(i,k,jde ) = 0.0
a_dat(i,k,jde-1) = a_dat(i,k,jde-1) + a_aux
a_aux = a_dat(i,k,jde+1)
a_dat(i,k,jde+1) = 0.0
a_dat(i,k,jde-1) = a_dat(i,k,jde-1) + a_aux
a_aux = a_dat(i,k,jde+2)
a_dat(i,k,jde+2) = 0.0
a_dat(i,k,jde-1) = a_dat(i,k,jde-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jde+1)
a_dat(i,k,jde+1) = 0.0
a_dat(i,k,jde) = a_dat(i,k,jde) + a_aux
a_aux = a_dat(i,k,jde+2)
a_dat(i,k,jde+2) = 0.0
a_dat(i,k,jde) = a_dat(i,k,jde) + a_aux
a_aux = a_dat(i,k,jde+3)
a_dat(i,k,jde+3) = 0.0
a_dat(i,k,jde) = a_dat(i,k,jde) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDIF
END IF open_ye
open_ys: IF( ( config_flags%open_ys .or. &
config_flags%polar .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( jts == jds) .and. open_bc_copy ) THEN
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jds-1)
a_dat(i,k,jds-1) = 0.0
a_dat(i,k,jds) = a_dat(i,k,jds) + a_aux
a_aux = a_dat(i,k,jds-2)
a_dat(i,k,jds-2) = 0.0
a_dat(i,k,jds) = a_dat(i,k,jds) + a_aux
a_aux = a_dat(i,k,jds-3)
a_dat(i,k,jds-3) = 0.0
a_dat(i,k,jds) = a_dat(i,k,jds) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDIF open_ys
! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
! now the symmetry boundary at ye
symmetry_ye: IF( ( config_flags%symmetric_ye ) .and. &
( jte == jde ) ) THEN
IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jde+j-1)
a_dat(i,k,jde+j-1) = 0.0
a_dat(i,k,jde-j) = a_dat(i,k,jde-j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
IF ( variable == 'v' ) THEN
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = - a_dat(i,k,jde+j)
a_dat(i,k,jde+j) = 0.0
a_dat(i,k,jde-j) = a_dat(i,k,jde-j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jde+j)
a_dat(i,k,jde+j) = 0.0
a_dat(i,k,jde-j) = a_dat(i,k,jde-j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
ENDIF
END IF symmetry_ye
symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
( jts == jds) ) THEN
IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jds-j)
a_dat(i,k,jds-j) = 0.0
a_dat(i,k,jds+j-1) = a_dat(i,k,jds+j-1) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
IF (variable == 'v') THEN
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = - a_dat(i,k,jds-j)
a_dat(i,k,jds-j) = 0.0
a_dat(i,k,jds+j) = a_dat(i,k,jds+j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j = bdyzone,1,-1
DO k = kts, k_end
DO i = MIN(ite+1,ide+istag),MAX(ids,its-1),-1
a_aux = a_dat(i,k,jds-j)
a_dat(i,k,jds-j) = 0.0
a_dat(i,k,jds+j) = a_dat(i,k,jds+j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_ys
END IF periodicity_y
periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if both east and west on-processor
IF ( ite == ide ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = bdyzone,-istag,-1
a_aux = a_dat(ide+i+istag,k,j)
a_dat(ide+i+istag,k,j) = 0.0
a_dat(ids+i+istag,k,j) = a_dat(ids+i+istag,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ENDIF
IF ( its == ids ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = -(bdyzone-1),0,1
a_aux = a_dat(ids+i-1,k,j)
a_dat(ids+i-1,k,j) = 0.0
a_dat(ide+i-1,k,j) = a_dat(ide+i-1,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
ELSE
! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
! now the open_xe boundary copy
open_xe: IF( ( config_flags%open_xe .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( ite == ide ) .and. open_bc_copy ) THEN
IF (variable /= 'u' .and. variable /= 'x' ) THEN
DO j = MIN(jte,jde+jstag)+bdyzone,jts-bdyzone,-1
DO k = kts, k_end
a_aux = a_dat(ide ,k,j)
a_dat(ide ,k,j) = 0.0
a_dat(ide-1,k,j) = a_dat(ide-1,k,j) + a_aux
a_aux = a_dat(ide+1,k,j)
a_dat(ide+1,k,j) = 0.0
a_dat(ide-1,k,j) = a_dat(ide-1,k,j) + a_aux
a_aux = a_dat(ide+2,k,j)
a_dat(ide+2,k,j) = 0.0
a_dat(ide-1,k,j) = a_dat(ide-1,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ELSE
!!!!!!! I am not sure about this one! JM 20020402
DO j = MIN(jte+1,jde+jstag)+bdyzone,MAX(jds,jts-1)-bdyzone,-1
DO k = kts, k_end
a_aux = a_dat(ide+1,k,j)
a_dat(ide+1,k,j) = 0.0
a_dat(ide,k,j) = a_dat(ide,k,j) + a_aux
a_aux = a_dat(ide+2,k,j)
a_dat(ide+2,k,j) = 0.0
a_dat(ide,k,j) = a_dat(ide,k,j) + a_aux
a_aux = a_dat(ide+3,k,j)
a_dat(ide+3,k,j) = 0.0
a_dat(ide,k,j) = a_dat(ide,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
END IF
END IF open_xe
open_xs: IF( ( config_flags%open_xs .or. &
config_flags%specified .or. &
config_flags%nested ) .and. &
( its == ids ) .and. open_bc_copy ) THEN
DO j = MIN(jte,jde+jstag)+bdyzone,jts-bdyzone,-1
DO k = kts, k_end
a_aux = a_dat(ids-1,k,j)
a_dat(ids-1,k,j) = 0.0
a_dat(ids,k,j) = a_dat(ids,k,j) + a_aux
a_aux = a_dat(ids-2,k,j)
a_dat(ids-2,k,j) = 0.0
a_dat(ids,k,j) = a_dat(ids,k,j) + a_aux
a_aux = a_dat(ids-3,k,j)
a_dat(ids-3,k,j) = 0.0
a_dat(ids,k,j) = a_dat(ids,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDIF open_xs
! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
! now the symmetry boundary at xe
symmetry_xe: IF( ( config_flags%symmetric_xe ) .and. &
( ite == ide ) ) THEN
IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = a_dat(ide+i-1,k,j)
a_dat(ide+i-1,k,j) = 0.0
a_dat(ide-i,k,j) = a_dat(ide-i,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
IF (variable == 'u') THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = - a_dat(ide+i,k,j)
a_dat(ide+i,k,j) = 0.0
a_dat(ide-i,k,j) = a_dat(ide-i,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = a_dat(ide+i,k,j)
a_dat(ide+i,k,j) = 0.0
a_dat(ide-i,k,j) = a_dat(ide-i,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
END IF
END IF symmetry_xe
symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
( its == ids ) ) THEN
IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = a_dat(ids-i,k,j)
a_dat(ids-i,k,j) = 0.0
a_dat(ids+i-1,k,j) = a_dat(ids+i-1,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
IF ( variable == 'u' ) THEN
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = - a_dat(ids-i,k,j)
a_dat(ids-i,k,j) = 0.0
a_dat(ids+i,k,j) = a_dat(ids+i,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
ELSE
DO j = MIN(jte+1,jde+jstag),MAX(jds,jts-1),-1
DO k = kts, k_end
DO i = bdyzone,1,-1
a_aux = a_dat(ids-i,k,j)
a_dat(ids-i,k,j) = 0.0
a_dat(ids+i,k,j) = a_dat(ids+i,k,j) + a_aux
a_aux = 0.0
ENDDO
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_xs
END IF periodicity_x
END SUBROUTINE a_set_physical_bc3d
!------------------------------------------------------------------------
SUBROUTINE a_init_module_bc
END SUBROUTINE a_init_module_bc
!------------------------------------------------------------------------
! a couple versions of this call to allow a smaller-than-memory dimensioned field (e.g. tile sized) ! to be passed in as the first argument. Both of these call the _core version defined below.
SUBROUTINE a_relax_bdytend ( a_field, a_field_tend, & 4,1
a_field_bdy_xs, a_field_bdy_xe, &
a_field_bdy_ys, a_field_bdy_ye, &
a_field_bdy_tend_xs, a_field_bdy_tend_xe, &
a_field_bdy_tend_ys, a_field_bdy_tend_ye, &
variable_in, config_flags, &
spec_bdy_width, spec_zone, relax_zone, &
dtbc, fcx, gcx, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN) :: spec_bdy_width, spec_zone, relax_zone
REAL, INTENT(IN) :: dtbc
CHARACTER, INTENT(IN) :: variable_in
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: a_field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: a_field_tend
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_xs, a_field_bdy_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_ys, a_field_bdy_ye
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_tend_xs, a_field_bdy_tend_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_tend_ys, a_field_bdy_tend_ye
REAL, DIMENSION(spec_bdy_width), INTENT(IN) :: fcx, gcx
TYPE(grid_config_rec_type), INTENT(IN) :: config_flags
CALL a_relax_bdytend_core ( a_field, a_field_tend, &
a_field_bdy_xs, a_field_bdy_xe, &
a_field_bdy_ys, a_field_bdy_ye, &
a_field_bdy_tend_xs, a_field_bdy_tend_xe, &
a_field_bdy_tend_ys, a_field_bdy_tend_ye, &
variable_in, config_flags, &
spec_bdy_width, spec_zone, relax_zone, &
dtbc, fcx, gcx, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte, & ! patch dims
ims,ime, jms,jme, kms,kme ) ! dimension of the field argument
END SUBROUTINE a_relax_bdytend
! version that allows tile-sized version of field. Note, caller should define the
! field to be -+1 of tile size in each dimension because routine is going off onto halo
! for example, see relax_bdytend in dyn_em/module_bc_em.F
SUBROUTINE a_relax_bdytend_tile ( a_field, a_field_tend, & 3,1
a_field_bdy_xs, a_field_bdy_xe, &
a_field_bdy_ys, a_field_bdy_ye, &
a_field_bdy_tend_xs, a_field_bdy_tend_xe, &
a_field_bdy_tend_ys, a_field_bdy_tend_ye, &
variable_in, config_flags, &
spec_bdy_width, spec_zone, relax_zone, &
dtbc, fcx, gcx, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte, &
iXs,iXe, jXs,jXe, kXs,kXe & ! dims of first argument
)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN) :: iXs,iXe, jXs,jXe, kXs,kXe
INTEGER, INTENT(IN) :: spec_bdy_width, spec_zone, relax_zone
REAL, INTENT(IN) :: dtbc
CHARACTER, INTENT(IN) :: variable_in
REAL, DIMENSION(iXs:iXe, kXs:kXe, jXs:jXe), INTENT(INOUT) :: a_field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: a_field_tend
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_xs, a_field_bdy_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_ys, a_field_bdy_ye
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_tend_xs, a_field_bdy_tend_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_tend_ys, a_field_bdy_tend_ye
REAL, DIMENSION(spec_bdy_width), INTENT(IN) :: fcx, gcx
TYPE(grid_config_rec_type), INTENT(IN) :: config_flags
CALL a_relax_bdytend_core ( a_field, a_field_tend, &
a_field_bdy_xs, a_field_bdy_xe, &
a_field_bdy_ys, a_field_bdy_ye, &
a_field_bdy_tend_xs, a_field_bdy_tend_xe, &
a_field_bdy_tend_ys, a_field_bdy_tend_ye, &
variable_in, config_flags, &
spec_bdy_width, spec_zone, relax_zone, &
dtbc, fcx, gcx, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte, &
iXs,iXe, jXs,jXe, kXs,kXe ) ! dimension of the field argument
END SUBROUTINE a_relax_bdytend_tile
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of relax_bdytend_core in reverse (adjoint) mode:
! gradient of useful results: field field_bdy_xe field_bdy_tend_xe
! field_tend field_bdy_xs field_bdy_tend_xs field_bdy_ye
! field_bdy_tend_ye field_bdy_ys field_bdy_tend_ys
! with respect to varying inputs: field field_bdy_xe field_bdy_tend_xe
! field_tend field_bdy_xs field_bdy_tend_xs field_bdy_ye
! field_bdy_tend_ye field_bdy_ys field_bdy_tend_ys
! RW status of diff variables: field:incr field_bdy_xe:incr field_bdy_tend_xe:incr
! field_tend:in-out field_bdy_xs:incr field_bdy_tend_xs:incr
! field_bdy_ye:incr field_bdy_tend_ye:incr field_bdy_ys:incr
! field_bdy_tend_ys:incr
! domain dims
! memory dims
! patch dims
! patch dims
! field (1st arg) dims; might be tile or patch
SUBROUTINE A_RELAX_BDYTEND_CORE(fieldb, field_tendb, & 2,61
& field_bdy_xsb, field_bdy_xeb&
& , field_bdy_ysb, field_bdy_yeb, &
& field_bdy_tend_xsb, field_bdy_tend_xeb, &
& field_bdy_tend_ysb, &
& field_bdy_tend_yeb, variable_in, config_flags, spec_bdy_width, &
& spec_zone, relax_zone, dtbc, fcx, gcx, ids, ide, jds, jde, kds, kde, &
& ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe, its, ite, &
& jts, jte, kts, kte, ixs, ixe, jxs, jxe, kxs, kxe)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
INTEGER, INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe
INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
INTEGER, INTENT(IN) :: ixs, ixe, jxs, jxe, kxs, kxe
INTEGER, INTENT(IN) :: spec_bdy_width, spec_zone, relax_zone
REAL, INTENT(IN) :: dtbc
CHARACTER, INTENT(IN) :: variable_in
REAL, DIMENSION(ixs:ixe, kxs:kxe, jxs:jxe) :: fieldb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme) :: field_tendb
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width) :: field_bdy_xsb, &
& field_bdy_xeb
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width) :: field_bdy_ysb, &
& field_bdy_yeb
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width) :: &
& field_bdy_tend_xsb, field_bdy_tend_xeb
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width) :: &
& field_bdy_tend_ysb, field_bdy_tend_yeb
REAL, DIMENSION(spec_bdy_width), INTENT(IN) :: fcx, gcx
TYPE(GRID_CONFIG_REC_TYPE) :: config_flags
CHARACTER :: variable
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, im1, ip1
INTEGER :: b_dist, b_limit
REAL :: fls0, fls1, fls2, fls3, fls4
REAL :: fls0b, fls1b, fls2b, fls3b, fls4b
LOGICAL :: periodic_x
INTEGER :: branch
INTEGER :: ad_from
INTEGER :: ad_to
INTEGER :: ad_from0
INTEGER :: ad_to0
INTEGER :: ad_from1
INTEGER :: ad_to1
INTEGER :: ad_from2
INTEGER :: ad_to2
INTEGER :: min8
INTEGER :: min7
INTEGER :: min6
INTEGER :: min5
INTEGER :: min4
INTEGER :: min3
INTEGER :: min2
INTEGER :: min1
REAL :: tempb2
REAL :: tempb1
REAL :: tempb0
REAL :: tempb
INTEGER :: max8
INTEGER :: max7
INTEGER :: max6
INTEGER :: max5
INTEGER :: max4
INTEGER :: max3
INTEGER :: max2
INTEGER :: max1
periodic_x = config_flags%periodic_x
variable = variable_in
IF (variable .EQ. 'U') variable = 'u'
IF (variable .EQ. 'V') variable = 'v'
IF (variable .EQ. 'M') variable = 'm'
IF (variable .EQ. 'H') variable = 'h'
ibs = ids
ibe = ide - 1
IF (ite .GT. ide - 1) THEN
itf = ide - 1
ELSE
itf = ite
END IF
jbs = jds
jbe = jde - 1
IF (jte .GT. jde - 1) THEN
jtf = jde - 1
ELSE
jtf = jte
END IF
ktf = kde - 1
IF (variable .EQ. 'u') ibe = ide
IF (variable .EQ. 'u') THEN
IF (ite .GT. ide) THEN
itf = ide
ELSE
itf = ite
END IF
END IF
IF (variable .EQ. 'v') jbe = jde
IF (variable .EQ. 'v') THEN
IF (jte .GT. jde) THEN
jtf = jde
ELSE
jtf = jte
END IF
END IF
IF (variable .EQ. 'm') ktf = kte
IF (variable .EQ. 'h') ktf = kte
IF (jts - jbs .LT. relax_zone) THEN
IF (jts .LT. jbs + spec_zone) THEN
max1 = jbs + spec_zone
ELSE
max1 = jts
END IF
IF (jtf .GT. jbs + relax_zone - 1) THEN
min1 = jbs + relax_zone - 1
ELSE
min1 = jtf
END IF
! Y-start boundary
DO j=max1,min1
CALL PUSHINTEGER4(b_dist)
b_dist = j - jbs
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k=kts,ktf
IF (its .LT. b_limit + ibs) THEN
max2 = b_limit + ibs
ELSE
max2 = its
END IF
IF (itf .GT. ibe - b_limit) THEN
min2 = ibe - b_limit
ELSE
min2 = itf
END IF
ad_from = max2
DO i=ad_from,min2
IF (i - 1 .LT. ibs) THEN
CALL PUSHINTEGER4(im1)
im1 = ibs
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(im1)
im1 = i - 1
CALL PUSHCONTROL1B(1)
END IF
IF (i + 1 .GT. ibe) THEN
CALL PUSHINTEGER4(ip1)
ip1 = ibe
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(ip1)
ip1 = i + 1
CALL PUSHCONTROL1B(1)
END IF
END DO
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (jbe - jtf .LT. relax_zone) THEN
IF (jts .LT. jbe - relax_zone + 1) THEN
max3 = jbe - relax_zone + 1
ELSE
max3 = jts
END IF
IF (jtf .GT. jbe - spec_zone) THEN
min3 = jbe - spec_zone
ELSE
min3 = jtf
END IF
! Y-end boundary
DO j=max3,min3
CALL PUSHINTEGER4(b_dist)
b_dist = jbe - j
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k=kts,ktf
IF (its .LT. b_limit + ibs) THEN
max4 = b_limit + ibs
ELSE
max4 = its
END IF
IF (itf .GT. ibe - b_limit) THEN
min4 = ibe - b_limit
ELSE
min4 = itf
END IF
ad_from0 = max4
DO i=ad_from0,min4
IF (i - 1 .LT. ibs) THEN
CALL PUSHINTEGER4(im1)
im1 = ibs
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(im1)
im1 = i - 1
CALL PUSHCONTROL1B(1)
END IF
IF (i + 1 .GT. ibe) THEN
CALL PUSHINTEGER4(ip1)
ip1 = ibe
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(ip1)
ip1 = i + 1
CALL PUSHCONTROL1B(1)
END IF
END DO
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from0)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (.NOT.periodic_x) THEN
IF (its - ibs .LT. relax_zone) THEN
IF (its .LT. ibs + spec_zone) THEN
max5 = ibs + spec_zone
ELSE
max5 = its
END IF
IF (itf .GT. ibs + relax_zone - 1) THEN
min5 = ibs + relax_zone - 1
ELSE
min5 = itf
END IF
! X-start boundary
DO i=max5,min5
CALL PUSHINTEGER4(b_dist)
b_dist = i - ibs
DO k=kts,ktf
IF (jts .LT. b_dist + jbs + 1) THEN
max6 = b_dist + jbs + 1
ELSE
max6 = jts
END IF
IF (jtf .GT. jbe - b_dist - 1) THEN
min6 = jbe - b_dist - 1
ELSE
min6 = jtf
END IF
ad_from1 = max6
j = min6 + 1
CALL PUSHINTEGER4(j - 1)
CALL PUSHINTEGER4(ad_from1)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (ibe - itf .LT. relax_zone) THEN
IF (its .LT. ibe - relax_zone + 1) THEN
max7 = ibe - relax_zone + 1
ELSE
max7 = its
END IF
IF (itf .GT. ibe - spec_zone) THEN
min7 = ibe - spec_zone
ELSE
min7 = itf
END IF
! X-end boundary
DO i=max7,min7
CALL PUSHINTEGER4(b_dist)
b_dist = ibe - i
DO k=kts,ktf
IF (jts .LT. b_dist + jbs + 1) THEN
max8 = b_dist + jbs + 1
ELSE
max8 = jts
END IF
IF (jtf .GT. jbe - b_dist - 1) THEN
min8 = jbe - b_dist - 1
ELSE
min8 = jtf
END IF
ad_from2 = max8
j = min8 + 1
CALL PUSHINTEGER4(j - 1)
CALL PUSHINTEGER4(ad_from2)
END DO
END DO
DO i=min7,max7,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from2)
CALL POPINTEGER4(ad_to2)
DO j=ad_to2,ad_from2,-1
tempb2 = -(gcx(b_dist+1)*field_tendb(i, k, j))
fls0b = fcx(b_dist+1)*field_tendb(i, k, j) - 4.*tempb2
fls1b = tempb2
fls2b = tempb2
fls3b = tempb2
fls4b = tempb2
field_bdy_xeb(j, k, b_dist+2) = field_bdy_xeb(j, k, b_dist+2&
& ) + fls4b
field_bdy_tend_xeb(j, k, b_dist+2) = field_bdy_tend_xeb(j, k&
& , b_dist+2) + dtbc*fls4b
fieldb(i-1, k, j) = fieldb(i-1, k, j) - fls4b
field_bdy_xeb(j, k, b_dist) = field_bdy_xeb(j, k, b_dist) + &
& fls3b
field_bdy_tend_xeb(j, k, b_dist) = field_bdy_tend_xeb(j, k, &
& b_dist) + dtbc*fls3b
fieldb(i+1, k, j) = fieldb(i+1, k, j) - fls3b
field_bdy_xeb(j+1, k, b_dist+1) = field_bdy_xeb(j+1, k, &
& b_dist+1) + fls2b
field_bdy_tend_xeb(j+1, k, b_dist+1) = field_bdy_tend_xeb(j+&
& 1, k, b_dist+1) + dtbc*fls2b
fieldb(i, k, j+1) = fieldb(i, k, j+1) - fls2b
field_bdy_xeb(j-1, k, b_dist+1) = field_bdy_xeb(j-1, k, &
& b_dist+1) + fls1b
field_bdy_tend_xeb(j-1, k, b_dist+1) = field_bdy_tend_xeb(j-&
& 1, k, b_dist+1) + dtbc*fls1b
fieldb(i, k, j-1) = fieldb(i, k, j-1) - fls1b
field_bdy_xeb(j, k, b_dist+1) = field_bdy_xeb(j, k, b_dist+1&
& ) + fls0b
field_bdy_tend_xeb(j, k, b_dist+1) = field_bdy_tend_xeb(j, k&
& , b_dist+1) + dtbc*fls0b
fieldb(i, k, j) = fieldb(i, k, j) - fls0b
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO i=min5,max5,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from1)
CALL POPINTEGER4(ad_to1)
DO j=ad_to1,ad_from1,-1
tempb1 = -(gcx(b_dist+1)*field_tendb(i, k, j))
fls0b = fcx(b_dist+1)*field_tendb(i, k, j) - 4.*tempb1
fls1b = tempb1
fls2b = tempb1
fls3b = tempb1
fls4b = tempb1
field_bdy_xsb(j, k, b_dist+2) = field_bdy_xsb(j, k, b_dist+2&
& ) + fls4b
field_bdy_tend_xsb(j, k, b_dist+2) = field_bdy_tend_xsb(j, k&
& , b_dist+2) + dtbc*fls4b
fieldb(i+1, k, j) = fieldb(i+1, k, j) - fls4b
field_bdy_xsb(j, k, b_dist) = field_bdy_xsb(j, k, b_dist) + &
& fls3b
field_bdy_tend_xsb(j, k, b_dist) = field_bdy_tend_xsb(j, k, &
& b_dist) + dtbc*fls3b
fieldb(i-1, k, j) = fieldb(i-1, k, j) - fls3b
field_bdy_xsb(j+1, k, b_dist+1) = field_bdy_xsb(j+1, k, &
& b_dist+1) + fls2b
field_bdy_tend_xsb(j+1, k, b_dist+1) = field_bdy_tend_xsb(j+&
& 1, k, b_dist+1) + dtbc*fls2b
fieldb(i, k, j+1) = fieldb(i, k, j+1) - fls2b
field_bdy_xsb(j-1, k, b_dist+1) = field_bdy_xsb(j-1, k, &
& b_dist+1) + fls1b
field_bdy_tend_xsb(j-1, k, b_dist+1) = field_bdy_tend_xsb(j-&
& 1, k, b_dist+1) + dtbc*fls1b
fieldb(i, k, j-1) = fieldb(i, k, j-1) - fls1b
field_bdy_xsb(j, k, b_dist+1) = field_bdy_xsb(j, k, b_dist+1&
& ) + fls0b
field_bdy_tend_xsb(j, k, b_dist+1) = field_bdy_tend_xsb(j, k&
& , b_dist+1) + dtbc*fls0b
fieldb(i, k, j) = fieldb(i, k, j) - fls0b
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
END IF
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=min3,max3,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from0)
CALL POPINTEGER4(ad_to0)
DO i=ad_to0,ad_from0,-1
tempb0 = -(gcx(b_dist+1)*field_tendb(i, k, j))
fls0b = fcx(b_dist+1)*field_tendb(i, k, j) - 4.*tempb0
fls1b = tempb0
fls2b = tempb0
fls3b = tempb0
fls4b = tempb0
field_bdy_yeb(i, k, b_dist+2) = field_bdy_yeb(i, k, b_dist+2) &
& + fls4b
field_bdy_tend_yeb(i, k, b_dist+2) = field_bdy_tend_yeb(i, k, &
& b_dist+2) + dtbc*fls4b
fieldb(i, k, j-1) = fieldb(i, k, j-1) - fls4b
field_bdy_yeb(i, k, b_dist) = field_bdy_yeb(i, k, b_dist) + &
& fls3b
field_bdy_tend_yeb(i, k, b_dist) = field_bdy_tend_yeb(i, k, &
& b_dist) + dtbc*fls3b
fieldb(i, k, j+1) = fieldb(i, k, j+1) - fls3b
field_bdy_yeb(ip1, k, b_dist+1) = field_bdy_yeb(ip1, k, b_dist&
& +1) + fls2b
field_bdy_tend_yeb(ip1, k, b_dist+1) = field_bdy_tend_yeb(ip1&
& , k, b_dist+1) + dtbc*fls2b
fieldb(ip1, k, j) = fieldb(ip1, k, j) - fls2b
field_bdy_yeb(im1, k, b_dist+1) = field_bdy_yeb(im1, k, b_dist&
& +1) + fls1b
field_bdy_tend_yeb(im1, k, b_dist+1) = field_bdy_tend_yeb(im1&
& , k, b_dist+1) + dtbc*fls1b
fieldb(im1, k, j) = fieldb(im1, k, j) - fls1b
field_bdy_yeb(i, k, b_dist+1) = field_bdy_yeb(i, k, b_dist+1) &
& + fls0b
field_bdy_tend_yeb(i, k, b_dist+1) = field_bdy_tend_yeb(i, k, &
& b_dist+1) + dtbc*fls0b
fieldb(i, k, j) = fieldb(i, k, j) - fls0b
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(ip1)
ELSE
CALL POPINTEGER4(ip1)
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(im1)
ELSE
CALL POPINTEGER4(im1)
END IF
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=min1,max1,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from)
CALL POPINTEGER4(ad_to)
DO i=ad_to,ad_from,-1
tempb = -(gcx(b_dist+1)*field_tendb(i, k, j))
fls0b = fcx(b_dist+1)*field_tendb(i, k, j) - 4.*tempb
fls1b = tempb
fls2b = tempb
fls3b = tempb
fls4b = tempb
field_bdy_ysb(i, k, b_dist+2) = field_bdy_ysb(i, k, b_dist+2) &
& + fls4b
field_bdy_tend_ysb(i, k, b_dist+2) = field_bdy_tend_ysb(i, k, &
& b_dist+2) + dtbc*fls4b
fieldb(i, k, j+1) = fieldb(i, k, j+1) - fls4b
field_bdy_ysb(i, k, b_dist) = field_bdy_ysb(i, k, b_dist) + &
& fls3b
field_bdy_tend_ysb(i, k, b_dist) = field_bdy_tend_ysb(i, k, &
& b_dist) + dtbc*fls3b
fieldb(i, k, j-1) = fieldb(i, k, j-1) - fls3b
field_bdy_ysb(ip1, k, b_dist+1) = field_bdy_ysb(ip1, k, b_dist&
& +1) + fls2b
field_bdy_tend_ysb(ip1, k, b_dist+1) = field_bdy_tend_ysb(ip1&
& , k, b_dist+1) + dtbc*fls2b
fieldb(ip1, k, j) = fieldb(ip1, k, j) - fls2b
field_bdy_ysb(im1, k, b_dist+1) = field_bdy_ysb(im1, k, b_dist&
& +1) + fls1b
field_bdy_tend_ysb(im1, k, b_dist+1) = field_bdy_tend_ysb(im1&
& , k, b_dist+1) + dtbc*fls1b
fieldb(im1, k, j) = fieldb(im1, k, j) - fls1b
field_bdy_ysb(i, k, b_dist+1) = field_bdy_ysb(i, k, b_dist+1) &
& + fls0b
field_bdy_tend_ysb(i, k, b_dist+1) = field_bdy_tend_ysb(i, k, &
& b_dist+1) + dtbc*fls0b
fieldb(i, k, j) = fieldb(i, k, j) - fls0b
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(ip1)
ELSE
CALL POPINTEGER4(ip1)
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(im1)
ELSE
CALL POPINTEGER4(im1)
END IF
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
END IF
END SUBROUTINE A_RELAX_BDYTEND_CORE
!------------------------------------------------------------------------
SUBROUTINE a_spec_bdytend ( a_field_tend, & 7
a_field_bdy_tend_xs, a_field_bdy_tend_xe, &
a_field_bdy_tend_ys, a_field_bdy_tend_ye, &
variable_in, config_flags, &
spec_bdy_width, spec_zone, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
! spec_bdy_width is only used to dimension the boundary arrays.
! spec_zone is the width of the outer specified b.c.s that are set here.
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN) :: spec_bdy_width, spec_zone
CHARACTER, INTENT(IN) :: variable_in
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: a_field_tend
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_tend_xs, a_field_bdy_tend_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(INOUT) :: a_field_bdy_tend_ys, a_field_bdy_tend_ye
TYPE( grid_config_rec_type ) config_flags
CHARACTER :: variable
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
INTEGER :: b_dist, b_limit
LOGICAL :: periodic_x
periodic_x = config_flags%periodic_x
variable = variable_in
IF (variable == 'U') variable = 'u'
IF (variable == 'V') variable = 'v'
IF (variable == 'M') variable = 'm'
IF (variable == 'H') variable = 'h'
ibs = ids
ibe = ide-1
itf = min(ite,ide-1)
jbs = jds
jbe = jde-1
jtf = min(jte,jde-1)
ktf = kde-1
IF (variable == 'u') ibe = ide
IF (variable == 'u') itf = min(ite,ide)
IF (variable == 'v') jbe = jde
IF (variable == 'v') jtf = min(jte,jde)
IF (variable == 'm') ktf = kte
IF (variable == 'h') ktf = kte
IF(.NOT.periodic_x)THEN
IF (ibe - itf .lt. spec_zone) THEN
! X-end boundary
DO i = itf, max(its,ibe-spec_zone+1), -1
b_dist = ibe - i
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
a_field_bdy_tend_xe(j, k, b_dist+1) = a_field_bdy_tend_xe(j, k, b_dist+1) &
+ a_field_tend(i,k,j)
a_field_tend(i,k,j) = 0.
ENDDO
ENDDO
ENDDO
ENDIF
IF (its - ibs .lt. spec_zone) THEN
! X-start boundary
DO i = min(itf,ibs+spec_zone-1), its, -1
b_dist = i - ibs
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
a_field_bdy_tend_xs(j, k, b_dist+1) = a_field_bdy_tend_xs(j, k, b_dist+1) &
+ a_field_tend(i,k,j)
a_field_tend(i,k,j) = 0.
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF (jbe - jtf .lt. spec_zone) THEN
! Y-end boundary
DO j = jtf, max(jts,jbe-spec_zone+1), -1
b_dist = jbe - j
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
a_field_bdy_tend_ye(i, k, b_dist+1) = a_field_bdy_tend_ye(i, k, b_dist+1) &
+ a_field_tend(i,k,j)
a_field_tend(i,k,j) = 0.
ENDDO
ENDDO
ENDDO
ENDIF
IF (jts - jbs .lt. spec_zone) THEN
! Y-start boundary
DO j = min(jtf,jbs+spec_zone-1), jts, -1
b_dist = j - jbs
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
a_field_bdy_tend_ys(i, k, b_dist+1) = a_field_bdy_tend_ys(i, k, b_dist+1) &
+ a_field_tend(i,k,j)
a_field_tend(i,k,j) = 0.
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE a_spec_bdytend
!------------------------------------------------------------------------
SUBROUTINE a_spec_bdyupdate( a_field, & 6
a_field_tend, dt, &
variable_in, config_flags, &
spec_zone, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
! This subroutine adds the tendencies in the boundary specified region.
! spec_zone is the width of the outer specified b.c.s that are set here.
! (JD August 2000)
IMPLICIT NONE
INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN ) :: spec_zone
CHARACTER, INTENT(IN ) :: variable_in
REAL, INTENT(IN ) :: dt
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: a_field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: a_field_tend
TYPE( grid_config_rec_type ) config_flags
CHARACTER :: variable
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
INTEGER :: b_dist, b_limit
LOGICAL :: periodic_x
periodic_x = config_flags%periodic_x
variable = variable_in
IF (variable == 'U') variable = 'u'
IF (variable == 'V') variable = 'v'
IF (variable == 'M') variable = 'm'
IF (variable == 'H') variable = 'h'
ibs = ids
ibe = ide-1
itf = min(ite,ide-1)
jbs = jds
jbe = jde-1
jtf = min(jte,jde-1)
ktf = kde-1
IF (variable == 'u') ibe = ide
IF (variable == 'u') itf = min(ite,ide)
IF (variable == 'v') jbe = jde
IF (variable == 'v') jtf = min(jte,jde)
IF (variable == 'm') ktf = kte
IF (variable == 'h') ktf = kte
IF(.NOT.periodic_x)THEN
IF (ibe - itf .lt. spec_zone) THEN
! X-end boundary
DO i = max(its,ibe-spec_zone+1), itf
b_dist = ibe - i
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
a_field_tend(i,k,j) = a_field_tend(i,k,j) + dt * a_field(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
IF (its - ibs .lt. spec_zone) THEN
! X-start boundary
DO i = its, min(itf,ibs+spec_zone-1)
b_dist = i - ibs
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
a_field_tend(i,k,j) = a_field_tend(i,k,j) + dt * a_field(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF (jbe - jtf .lt. spec_zone) THEN
! Y-end boundary
DO j = max(jts,jbe-spec_zone+1), jtf
b_dist = jbe - j
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
a_field_tend(i,k,j) = a_field_tend(i,k,j) + dt * a_field(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
IF (jts - jbs .lt. spec_zone) THEN
! Y-start boundary
DO j = jts, min(jtf,jbs+spec_zone-1)
b_dist = j - jbs
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
a_field_tend(i,k,j) = a_field_tend(i,k,j) + dt * a_field(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE a_spec_bdyupdate
!------------------------------------------------------------------------
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.10 (r5498) - 20 Jan 2015 09:48
!
! Differentiation of spec_bdy_final in reverse (adjoint) mode:
! gradient of useful results: field field_bdy_xe field_bdy_tend_xe
! field_bdy_xs field_bdy_tend_xs field_bdy_ye field_bdy_tend_ye
! field_bdy_ys field_bdy_tend_ys mu
! with respect to varying inputs: field field_bdy_xe field_bdy_tend_xe
! field_bdy_xs field_bdy_tend_xs field_bdy_ye field_bdy_tend_ye
! field_bdy_ys field_bdy_tend_ys mu
! RW status of diff variables: field:in-out field_bdy_xe:incr
! field_bdy_tend_xe:incr field_bdy_xs:incr field_bdy_tend_xs:incr
! field_bdy_ye:incr field_bdy_tend_ye:incr field_bdy_ys:incr
! field_bdy_tend_ys:incr mu:incr
! domain dims
! memory dims
! patch dims
SUBROUTINE a_SPEC_BDY_FINAL(field, fieldb, mu, mub, msf, field_bdy_xs, & 10,73
& field_bdy_xsb, field_bdy_xe, field_bdy_xeb, field_bdy_ys, &
& field_bdy_ysb, field_bdy_ye, field_bdy_yeb, field_bdy_tend_xs, &
& field_bdy_tend_xsb, field_bdy_tend_xe, field_bdy_tend_xeb, &
& field_bdy_tend_ys, field_bdy_tend_ysb, field_bdy_tend_ye, &
& field_bdy_tend_yeb, variable_in, config_flags, spec_bdy_width, &
& spec_zone, dtbc, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms&
& , kme, ips, ipe, jps, jpe, kps, kpe, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
INTEGER, INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe
INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
INTEGER, INTENT(IN) :: spec_bdy_width, spec_zone
REAL, INTENT(IN) :: dtbc
CHARACTER, INTENT(IN) :: variable_in
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: fieldb
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, msf
REAL, DIMENSION(ims:ime, jms:jme) :: mub
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: &
& field_bdy_xs, field_bdy_xe
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width) :: field_bdy_xsb, &
& field_bdy_xeb
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: &
& field_bdy_ys, field_bdy_ye
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width) :: field_bdy_ysb, &
& field_bdy_yeb
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: &
& field_bdy_tend_xs, field_bdy_tend_xe
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width) :: &
& field_bdy_tend_xsb, field_bdy_tend_xeb
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: &
& field_bdy_tend_ys, field_bdy_tend_ye
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width) :: &
& field_bdy_tend_ysb, field_bdy_tend_yeb
TYPE(GRID_CONFIG_REC_TYPE) :: config_flags
CHARACTER :: variable
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, im1, ip1
INTEGER :: b_dist, b_limit
REAL :: bfield, xmsf, xmu
REAL :: bfieldb, xmub
LOGICAL :: periodic_x, msfcouple, mucouple
INTEGER :: branch
INTEGER :: ad_from
INTEGER :: ad_to
INTEGER :: ad_from0
INTEGER :: ad_to0
INTEGER :: ad_from1
INTEGER :: ad_to1
INTEGER :: ad_from2
INTEGER :: ad_to2
INTEGER :: min6
INTEGER :: min5
INTEGER :: min4
INTEGER :: min3
INTEGER :: min2
INTEGER :: min1
REAL :: tempb2
REAL :: tempb1
REAL :: tempb0
REAL :: tempb
INTEGER :: max6
INTEGER :: max5
INTEGER :: max4
INTEGER :: max3
INTEGER :: max2
INTEGER :: max1
periodic_x = config_flags%periodic_x
variable = variable_in
IF (variable .EQ. 'U') variable = 'u'
IF (variable .EQ. 'V') variable = 'v'
IF (variable .EQ. 'W') variable = 'w'
IF (variable .EQ. 'M') variable = 'm'
IF (variable .EQ. 'T') variable = 't'
IF (variable .EQ. 'H') variable = 'h'
ibs = ids
ibe = ide - 1
IF (ite .GT. ide - 1) THEN
itf = ide - 1
ELSE
itf = ite
END IF
jbs = jds
jbe = jde - 1
IF (jte .GT. jde - 1) THEN
jtf = jde - 1
ELSE
jtf = jte
END IF
ktf = kde - 1
IF (variable .EQ. 'u') ibe = ide
IF (variable .EQ. 'u') THEN
IF (ite .GT. ide) THEN
itf = ide
ELSE
itf = ite
END IF
END IF
IF (variable .EQ. 'v') jbe = jde
IF (variable .EQ. 'v') THEN
IF (jte .GT. jde) THEN
jtf = jde
ELSE
jtf = jte
END IF
END IF
IF (variable .EQ. 'm') ktf = kde
IF (variable .EQ. 'h') ktf = kde
IF (variable .EQ. 'w') ktf = kde
msfcouple = .false.
mucouple = .true.
IF ((variable .EQ. 'u' .OR. variable .EQ. 'v') .OR. variable .EQ. 'w'&
& ) msfcouple = .true.
IF (variable .EQ. 'm') mucouple = .false.
xmsf = 1.
xmu = 1.
IF (jts - jbs .LT. spec_zone) THEN
IF (jtf .GT. jbs + spec_zone - 1) THEN
min1 = jbs + spec_zone - 1
ELSE
min1 = jtf
END IF
! Y-start boundary
DO j=jts,min1
CALL PUSHINTEGER4(b_dist)
b_dist = j - jbs
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k=kts,ktf
IF (its .LT. b_limit + ibs) THEN
max1 = b_limit + ibs
ELSE
max1 = its
END IF
IF (itf .GT. ibe - b_limit) THEN
min3 = ibe - b_limit
ELSE
min3 = itf
END IF
ad_from = max1
DO i=ad_from,min3
IF (msfcouple) THEN
CALL PUSHREAL8(xmsf)
xmsf = msf(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (mucouple) THEN
CALL PUSHREAL8(xmu)
xmu = mu(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
END DO
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (jbe - jtf .LT. spec_zone) THEN
IF (jts .LT. jbe - spec_zone + 1) THEN
max2 = jbe - spec_zone + 1
ELSE
max2 = jts
END IF
! Y-end boundary
DO j=max2,jtf
CALL PUSHINTEGER4(b_dist)
b_dist = jbe - j
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k=kts,ktf
IF (its .LT. b_limit + ibs) THEN
max3 = b_limit + ibs
ELSE
max3 = its
END IF
IF (itf .GT. ibe - b_limit) THEN
min4 = ibe - b_limit
ELSE
min4 = itf
END IF
ad_from0 = max3
DO i=ad_from0,min4
IF (msfcouple) THEN
CALL PUSHREAL8(xmsf)
xmsf = msf(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (mucouple) THEN
CALL PUSHREAL8(xmu)
xmu = mu(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
END DO
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from0)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (.NOT.periodic_x) THEN
IF (its - ibs .LT. spec_zone) THEN
IF (itf .GT. ibs + spec_zone - 1) THEN
min2 = ibs + spec_zone - 1
ELSE
min2 = itf
END IF
! X-start boundary
DO i=its,min2
CALL PUSHINTEGER4(b_dist)
b_dist = i - ibs
DO k=kts,ktf
IF (jts .LT. b_dist + jbs + 1) THEN
max4 = b_dist + jbs + 1
ELSE
max4 = jts
END IF
IF (jtf .GT. jbe - b_dist - 1) THEN
min5 = jbe - b_dist - 1
ELSE
min5 = jtf
END IF
ad_from1 = max4
DO j=ad_from1,min5
IF (msfcouple) THEN
CALL PUSHREAL8(xmsf)
xmsf = msf(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (mucouple) THEN
CALL PUSHREAL8(xmu)
xmu = mu(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
END DO
CALL PUSHINTEGER4(j - 1)
CALL PUSHINTEGER4(ad_from1)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (ibe - itf .LT. spec_zone) THEN
IF (its .LT. ibe - spec_zone + 1) THEN
max5 = ibe - spec_zone + 1
ELSE
max5 = its
END IF
! X-end boundary
DO i=max5,itf
CALL PUSHINTEGER4(b_dist)
b_dist = ibe - i
DO k=kts,ktf
IF (jts .LT. b_dist + jbs + 1) THEN
max6 = b_dist + jbs + 1
ELSE
max6 = jts
END IF
IF (jtf .GT. jbe - b_dist - 1) THEN
min6 = jbe - b_dist - 1
ELSE
min6 = jtf
END IF
ad_from2 = max6
DO j=ad_from2,min6
IF (msfcouple) THEN
CALL PUSHREAL8(xmsf)
xmsf = msf(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (mucouple) THEN
CALL PUSHREAL8(xmu)
xmu = mu(i, j)
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
END DO
CALL PUSHINTEGER4(j - 1)
CALL PUSHINTEGER4(ad_from2)
END DO
END DO
xmub = 0.0
DO i=itf,max5,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from2)
CALL POPINTEGER4(ad_to2)
DO j=ad_to2,ad_from2,-1
bfield = field_bdy_xe(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xe(j, k, b_dist+1)
tempb2 = xmsf*fieldb(i, k, j)/xmu
bfieldb = tempb2
xmub = xmub - bfield*tempb2/xmu
fieldb(i, k, j) = 0.0
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(xmu)
mub(i, j) = mub(i, j) + xmub
xmub = 0.0
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) CALL POPREAL8(xmsf)
field_bdy_xeb(j, k, b_dist+1) = field_bdy_xeb(j, k, b_dist+1&
& ) + bfieldb
field_bdy_tend_xeb(j, k, b_dist+1) = field_bdy_tend_xeb(j, k&
& , b_dist+1) + dtbc*bfieldb
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
ELSE
xmub = 0.0
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO i=min2,its,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from1)
CALL POPINTEGER4(ad_to1)
DO j=ad_to1,ad_from1,-1
bfield = field_bdy_xs(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xs(j, k, b_dist+1)
tempb1 = xmsf*fieldb(i, k, j)/xmu
bfieldb = tempb1
xmub = xmub - bfield*tempb1/xmu
fieldb(i, k, j) = 0.0
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(xmu)
mub(i, j) = mub(i, j) + xmub
xmub = 0.0
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) CALL POPREAL8(xmsf)
field_bdy_xsb(j, k, b_dist+1) = field_bdy_xsb(j, k, b_dist+1&
& ) + bfieldb
field_bdy_tend_xsb(j, k, b_dist+1) = field_bdy_tend_xsb(j, k&
& , b_dist+1) + dtbc*bfieldb
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
END IF
ELSE
xmub = 0.0
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=jtf,max2,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from0)
CALL POPINTEGER4(ad_to0)
DO i=ad_to0,ad_from0,-1
bfield = field_bdy_ye(i, k, b_dist+1) + dtbc*field_bdy_tend_ye&
& (i, k, b_dist+1)
tempb0 = xmsf*fieldb(i, k, j)/xmu
bfieldb = tempb0
xmub = xmub - bfield*tempb0/xmu
fieldb(i, k, j) = 0.0
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(xmu)
mub(i, j) = mub(i, j) + xmub
xmub = 0.0
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) CALL POPREAL8(xmsf)
field_bdy_yeb(i, k, b_dist+1) = field_bdy_yeb(i, k, b_dist+1) &
& + bfieldb
field_bdy_tend_yeb(i, k, b_dist+1) = field_bdy_tend_yeb(i, k, &
& b_dist+1) + dtbc*bfieldb
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=min1,jts,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from)
CALL POPINTEGER4(ad_to)
DO i=ad_to,ad_from,-1
bfield = field_bdy_ys(i, k, b_dist+1) + dtbc*field_bdy_tend_ys&
& (i, k, b_dist+1)
tempb = xmsf*fieldb(i, k, j)/xmu
bfieldb = tempb
xmub = xmub - bfield*tempb/xmu
fieldb(i, k, j) = 0.0
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPREAL8(xmu)
mub(i, j) = mub(i, j) + xmub
xmub = 0.0
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) CALL POPREAL8(xmsf)
field_bdy_ysb(i, k, b_dist+1) = field_bdy_ysb(i, k, b_dist+1) &
& + bfieldb
field_bdy_tend_ysb(i, k, b_dist+1) = field_bdy_tend_ysb(i, k, &
& b_dist+1) + dtbc*bfieldb
END DO
END DO
CALL POPINTEGER4(b_dist)
END DO
END IF
END SUBROUTINE a_SPEC_BDY_FINAL
!------------------------------------------------------------------------
SUBROUTINE a_zero_grad_bdy ( a_field, & 1
variable_in, config_flags, &
spec_zone, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
! This subroutine sets zero gradient conditions in the boundary specified region.
! spec_zone is the width of the outer specified b.c.s that are set here.
! (JD August 2000)
IMPLICIT NONE
INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN ) :: spec_zone
CHARACTER, INTENT(IN ) :: variable_in
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: a_field
TYPE( grid_config_rec_type ) config_flags
CHARACTER :: variable
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
INTEGER :: b_dist, b_limit
LOGICAL :: periodic_x
REAL :: a_aux
a_aux = 0.
periodic_x = config_flags%periodic_x
variable = variable_in
IF (variable == 'U') variable = 'u'
IF (variable == 'V') variable = 'v'
ibs = ids
ibe = ide-1
itf = min(ite,ide-1)
jbs = jds
jbe = jde-1
jtf = min(jte,jde-1)
ktf = kde-1
IF (variable == 'u') ibe = ide
IF (variable == 'u') itf = min(ite,ide)
IF (variable == 'v') jbe = jde
IF (variable == 'v') jtf = min(jte,jde)
IF (variable == 'w') ktf = kde
IF(.NOT.periodic_x)THEN
IF (ibe - itf .lt. spec_zone) THEN
! X-end boundary
DO i = itf, max(its,ibe-spec_zone+1), -1
b_dist = ibe - i
DO k = kts, ktf
DO j = min(jtf,jbe-b_dist-1), max(jts,b_dist+jbs+1), -1
j_inner = max(j,jbs+spec_zone)
j_inner = min(j_inner,jbe-spec_zone)
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(ibe-spec_zone,k,j_inner) = a_field(ibe-spec_zone,k,j_inner) + a_aux
a_aux = 0.
ENDDO
ENDDO
ENDDO
ENDIF
IF (its - ibs .lt. spec_zone) THEN
! X-start boundary
DO i = min(itf,ibs+spec_zone-1), its, -1
b_dist = i - ibs
DO k = kts, ktf
DO j = min(jtf,jbe-b_dist-1), max(jts,b_dist+jbs+1), -1
j_inner = max(j,jbs+spec_zone)
j_inner = min(j_inner,jbe-spec_zone)
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(ibs+spec_zone,k,j_inner) = a_field(ibs+spec_zone,k,j_inner) + a_aux
a_aux = 0.
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF (jbe - jtf .lt. spec_zone) THEN
! Y-end boundary
DO j = jtf, max(jts,jbe-spec_zone+1), -1
b_dist = jbe - j
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = min(itf,ibe-b_limit), max(its,b_limit+ibs), -1
i_inner = max(i,ibs+spec_zone)
i_inner = min(i_inner,ibe-spec_zone)
IF(periodic_x)i_inner = i
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(i_inner,k,jbe-spec_zone) = a_field(i_inner,k,jbe-spec_zone) + a_aux
a_aux = 0.
ENDDO
ENDDO
ENDDO
ENDIF
IF (jts - jbs .lt. spec_zone) THEN
! Y-start boundary
DO j = min(jtf,jbs+spec_zone-1), jts, -1
b_dist = j - jbs
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = min(itf,ibe-b_limit), max(its,b_limit+ibs), -1
i_inner = max(i,ibs+spec_zone)
i_inner = min(i_inner,ibe-spec_zone)
IF(periodic_x)i_inner = i
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(i_inner,k,jbs+spec_zone) = a_field(i_inner,k,jbs+spec_zone) + a_aux
a_aux = 0.
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE a_zero_grad_bdy
!------------------------------------------------------------------------
SUBROUTINE a_couple_bdy ( field, a_field, &
variable_in, config_flags, &
spec_zone, &
mu, a_mu, msf, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
! This subroutine adds the tendencies in the boundary specified region.
! spec_zone is the width of the outer specified b.c.s that are set here.
! (JD August 2000)
IMPLICIT NONE
INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN ) :: spec_zone
CHARACTER, INTENT(IN ) :: variable_in
REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: a_mu
REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu
REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msf
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: a_field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field
TYPE( grid_config_rec_type ) config_flags
CHARACTER :: variable
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
INTEGER :: b_dist, b_limit
LOGICAL :: periodic_x
periodic_x = config_flags%periodic_x
variable = variable_in
IF (variable == 'U') variable = 'u'
IF (variable == 'V') variable = 'v'
IF (variable == 'T') variable = 't'
IF (variable == 'H') variable = 'h'
IF (variable == 'W') variable = 'w'
ibs = ids
ibe = ide-1
itf = min(ite,ide-1)
jbs = jds
jbe = jde-1
jtf = min(jte,jde-1)
ktf = kde-1
IF (variable == 'u') ibe = ide
IF (variable == 'u') itf = min(ite,ide)
IF (variable == 'v') jbe = jde
IF (variable == 'v') jtf = min(jte,jde)
IF (variable == 'h') ktf = kte
IF (variable == 'w') ktf = kte
IF(.NOT.periodic_x)THEN
IF (ibe - itf .lt. spec_zone) THEN
! X-end boundary
DO i = max(its,ibe-spec_zone+1), itf
b_dist = ibe - i
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)
else
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)/msf(i,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
IF (its - ibs .lt. spec_zone) THEN
! X-start boundary
DO i = its, min(itf,ibs+spec_zone-1)
b_dist = i - ibs
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)
else
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)/msf(i,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF (jbe - jtf .lt. spec_zone) THEN
! Y-end boundary
DO j = max(jts,jbe-spec_zone+1), jtf
b_dist = jbe - j
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)
else
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)/msf(i,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
IF (jts - jbs .lt. spec_zone) THEN
! Y-start boundary
DO j = jts, min(jtf,jbs+spec_zone-1)
b_dist = j - jbs
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)
else
a_mu(i,j) = a_mu(i,j) + field(i,k,j)*a_field(i,k,j)/msf(i,j)
a_field(i,k,j) = a_field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE a_couple_bdy
!------------------------------------------------------------------------
SUBROUTINE a_uncouple_bdy( field, a_field, &
variable_in, config_flags, &
spec_zone, &
mu, a_mu, msf, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
! This subroutine adds the tendencies in the boundary specified region.
! spec_zone is the width of the outer specified b.c.s that are set here.
! (JD August 2000)
IMPLICIT NONE
INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN ) :: spec_zone
CHARACTER, INTENT(IN ) :: variable_in
REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: a_mu
REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu
REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msf
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: a_field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field
TYPE( grid_config_rec_type ) config_flags
CHARACTER :: variable
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf
INTEGER :: b_dist, b_limit
LOGICAL :: periodic_x
periodic_x = config_flags%periodic_x
variable = variable_in
IF (variable == 'U') variable = 'u'
IF (variable == 'V') variable = 'v'
IF (variable == 'T') variable = 't'
IF (variable == 'H') variable = 'h'
IF (variable == 'W') variable = 'w'
ibs = ids
ibe = ide-1
itf = min(ite,ide-1)
jbs = jds
jbe = jde-1
jtf = min(jte,jde-1)
ktf = kde-1
IF (variable == 'u') ibe = ide
IF (variable == 'u') itf = min(ite,ide)
IF (variable == 'v') jbe = jde
IF (variable == 'v') jtf = min(jte,jde)
IF (variable == 'h') ktf = kte
IF (variable == 'w') ktf = kte
IF(.NOT.periodic_x)THEN
IF (ibe - itf .lt. spec_zone) THEN
! X-end boundary
DO i = max(its,ibe-spec_zone+1), itf
b_dist = ibe - i
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j)) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)
else
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j))*msf(i,j) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
IF (its - ibs .lt. spec_zone) THEN
! X-start boundary
DO i = its, min(itf,ibs+spec_zone-1)
b_dist = i - ibs
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j)) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)
else
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j))*msf(i,j) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF (jbe - jtf .lt. spec_zone) THEN
! Y-end boundary
DO j = max(jts,jbe-spec_zone+1), jtf
b_dist = jbe - j
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j)) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)
else
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j))*msf(i,j) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
IF (jts - jbs .lt. spec_zone) THEN
! Y-start boundary
DO j = jts, min(jtf,jbs+spec_zone-1)
b_dist = j - jbs
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
if (variable == 't' .or. variable == 'h') then
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j)) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)
else
a_mu(i,j) = a_mu(i,j) &
- field(i,k,j)/(mu(i,j)*mu(i,j))*msf(i,j) * a_field(i,k,j)
a_field(i,k,j) = a_field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE a_uncouple_bdy
!------------------------------------------------------------------------
SUBROUTINE a_flow_dep_bdy ( a_field, & 4
u, v, config_flags, &
spec_zone, &
ids,ide, jds,jde, kds,kde, & ! domain dims
ims,ime, jms,jme, kms,kme, & ! memory dims
ips,ipe, jps,jpe, kps,kpe, & ! patch dims
its,ite, jts,jte, kts,kte )
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde
INTEGER, INTENT(IN) :: ims,ime, jms,jme, kms,kme
INTEGER, INTENT(IN) :: ips,ipe, jps,jpe, kps,kpe
INTEGER, INTENT(IN) :: its,ite, jts,jte, kts,kte
INTEGER, INTENT(IN) :: spec_zone
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: a_field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: u
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN ) :: v
TYPE(grid_config_rec_type),INTENT(IN) :: config_flags
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, j_inner
INTEGER :: b_dist, b_limit
LOGICAL :: periodic_x
REAL :: a_aux
a_aux = 0.0
periodic_x = config_flags%periodic_x
ibs = ids
ibe = ide-1
itf = min(ite,ide-1)
jbs = jds
jbe = jde-1
jtf = min(jte,jde-1)
ktf = kde-1
IF(.NOT.periodic_x)THEN
IF (ibe - itf .lt. spec_zone) THEN
! X-end boundary
DO i = max(its,ibe-spec_zone+1), itf
b_dist = ibe - i
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
j_inner = max(j,jbs+spec_zone)
j_inner = min(j_inner,jbe-spec_zone)
IF(u(i+1,k,j) .gt. 0.)THEN
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(ibe-spec_zone,k,j_inner) = a_field(ibe-spec_zone,k,j_inner) + a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
IF (its - ibs .lt. spec_zone) THEN
! X-start boundary
DO i = its, min(itf,ibs+spec_zone-1)
b_dist = i - ibs
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
j_inner = max(j,jbs+spec_zone)
j_inner = min(j_inner,jbe-spec_zone)
IF(u(i,k,j) .lt. 0.)THEN
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(ibs+spec_zone,k,j_inner) = a_field(ibs+spec_zone,k,j_inner) + a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF (jbe - jtf .lt. spec_zone) THEN
! Y-end boundary
DO j = max(jts,jbe-spec_zone+1), jtf
b_dist = jbe - j
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
i_inner = max(i,ibs+spec_zone)
i_inner = min(i_inner,ibe-spec_zone)
IF(periodic_x)i_inner = i
IF(v(i,k,j+1) .gt. 0.)THEN
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(i_inner,k,jbe-spec_zone) = a_field(i_inner,k,jbe-spec_zone) + a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
IF (jts - jbs .lt. spec_zone) THEN
! Y-start boundary
DO j = jts, min(jtf,jbs+spec_zone-1)
b_dist = j - jbs
b_limit = b_dist
IF(periodic_x)b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
i_inner = max(i,ibs+spec_zone)
i_inner = min(i_inner,ibe-spec_zone)
IF(periodic_x)i_inner = i
IF(v(i,k,j) .lt. 0.)THEN
a_aux = a_aux + a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(i_inner,k,jbs+spec_zone) = a_field(i_inner,k,jbs+spec_zone) + a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE a_flow_dep_bdy
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.6 (r4165) - 21 sep 2011 20:54
!
! Differentiation of flow_dep_bdy_qnn in reverse (adjoint) mode:
! gradient of useful results: field
! with respect to varying inputs: field
! RW status of diff variables: field:in-out
! domain dims
! memory dims
! patch dims
SUBROUTINE A_FLOW_DEP_BDY_QNN(field, fieldb, u, v, config_flags, & 1,65
& spec_zone, ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme&
& , ips, ipe, jps, jpe, kps, kpe, its, ite, jts, jte, kts, kte)
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde
INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
INTEGER, INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe
INTEGER, INTENT(IN) :: its, ite, jts, jte, kts, kte
INTEGER, INTENT(IN) :: spec_zone
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: fieldb
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: u
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: v
TYPE(GRID_CONFIG_REC_TYPE) :: config_flags
INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, i_inner, &
& j_inner
INTEGER :: b_dist, b_limit
LOGICAL :: periodic_x
REAL :: tmp
REAL :: tmp0
REAL :: tmp1
REAL :: tmp2
INTEGER :: branch
INTEGER :: ad_from
INTEGER :: ad_to
INTEGER :: ad_from0
INTEGER :: ad_to0
INTEGER :: ad_from1
INTEGER :: ad_to1
INTEGER :: ad_from2
INTEGER :: ad_to2
INTEGER :: min6
INTEGER :: min5
INTEGER :: min4
INTEGER :: min3
INTEGER :: min2
INTEGER :: min1
INTRINSIC MAX
REAL :: tmpb
REAL :: tmp0b
REAL :: tmp2b
INTRINSIC MIN
INTEGER :: max6
INTEGER :: max5
INTEGER :: max4
INTEGER :: max3
INTEGER :: max2
INTEGER :: max1
REAL :: tmp1b
periodic_x = config_flags%periodic_x
ibs = ids
ibe = ide - 1
IF (ite .GT. ide - 1) THEN
itf = ide - 1
ELSE
itf = ite
END IF
jbs = jds
jbe = jde - 1
IF (jte .GT. jde - 1) THEN
jtf = jde - 1
ELSE
jtf = jte
END IF
ktf = kde - 1
IF (jts - jbs .LT. spec_zone) THEN
IF (jtf .GT. jbs + spec_zone - 1) THEN
min1 = jbs + spec_zone - 1
ELSE
min1 = jtf
END IF
! Y-start boundary
DO j=jts,min1
b_dist = j - jbs
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k=kts,ktf
IF (its .LT. b_limit + ibs) THEN
max1 = b_limit + ibs
ELSE
max1 = its
END IF
IF (itf .GT. ibe - b_limit) THEN
min3 = ibe - b_limit
ELSE
min3 = itf
END IF
ad_from = max1
DO i=ad_from,min3
IF (i .LT. ibs + spec_zone) THEN
CALL PUSHINTEGER4(i_inner)
i_inner = ibs + spec_zone
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(i_inner)
i_inner = i
CALL PUSHCONTROL1B(1)
END IF
IF (i_inner .GT. ibe - spec_zone) THEN
i_inner = ibe - spec_zone
ELSE
i_inner = i_inner
END IF
IF (periodic_x) i_inner = i
IF (v(i, k, j) .LT. 0.) THEN
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHCONTROL1B(0)
END IF
END DO
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (jbe - jtf .LT. spec_zone) THEN
IF (jts .LT. jbe - spec_zone + 1) THEN
max2 = jbe - spec_zone + 1
ELSE
max2 = jts
END IF
! Y-end boundary
DO j=max2,jtf
b_dist = jbe - j
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k=kts,ktf
IF (its .LT. b_limit + ibs) THEN
max3 = b_limit + ibs
ELSE
max3 = its
END IF
IF (itf .GT. ibe - b_limit) THEN
min4 = ibe - b_limit
ELSE
min4 = itf
END IF
ad_from0 = max3
DO i=ad_from0,min4
IF (i .LT. ibs + spec_zone) THEN
CALL PUSHINTEGER4(i_inner)
i_inner = ibs + spec_zone
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(i_inner)
i_inner = i
CALL PUSHCONTROL1B(1)
END IF
IF (i_inner .GT. ibe - spec_zone) THEN
i_inner = ibe - spec_zone
ELSE
i_inner = i_inner
END IF
IF (periodic_x) i_inner = i
IF (v(i, k, j+1) .GT. 0.) THEN
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHCONTROL1B(0)
END IF
END DO
CALL PUSHINTEGER4(i - 1)
CALL PUSHINTEGER4(ad_from0)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (.NOT.periodic_x) THEN
IF (its - ibs .LT. spec_zone) THEN
IF (itf .GT. ibs + spec_zone - 1) THEN
min2 = ibs + spec_zone - 1
ELSE
min2 = itf
END IF
! X-start boundary
DO i=its,min2
b_dist = i - ibs
DO k=kts,ktf
IF (jts .LT. b_dist + jbs + 1) THEN
max4 = b_dist + jbs + 1
ELSE
max4 = jts
END IF
IF (jtf .GT. jbe - b_dist - 1) THEN
min5 = jbe - b_dist - 1
ELSE
min5 = jtf
END IF
ad_from1 = max4
DO j=ad_from1,min5
IF (j .LT. jbs + spec_zone) THEN
CALL PUSHINTEGER4(j_inner)
j_inner = jbs + spec_zone
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(j_inner)
j_inner = j
CALL PUSHCONTROL1B(1)
END IF
IF (j_inner .GT. jbe - spec_zone) THEN
j_inner = jbe - spec_zone
ELSE
j_inner = j_inner
END IF
IF (u(i, k, j) .LT. 0.) THEN
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHCONTROL1B(0)
END IF
END DO
CALL PUSHINTEGER4(j - 1)
CALL PUSHINTEGER4(ad_from1)
END DO
END DO
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHCONTROL1B(1)
END IF
IF (ibe - itf .LT. spec_zone) THEN
IF (its .LT. ibe - spec_zone + 1) THEN
max5 = ibe - spec_zone + 1
ELSE
max5 = its
END IF
! X-end boundary
DO i=max5,itf
b_dist = ibe - i
DO k=kts,ktf
IF (jts .LT. b_dist + jbs + 1) THEN
max6 = b_dist + jbs + 1
ELSE
max6 = jts
END IF
IF (jtf .GT. jbe - b_dist - 1) THEN
min6 = jbe - b_dist - 1
ELSE
min6 = jtf
END IF
ad_from2 = max6
DO j=ad_from2,min6
IF (j .LT. jbs + spec_zone) THEN
CALL PUSHINTEGER4(j_inner)
j_inner = jbs + spec_zone
CALL PUSHCONTROL1B(0)
ELSE
CALL PUSHINTEGER4(j_inner)
j_inner = j
CALL PUSHCONTROL1B(1)
END IF
IF (j_inner .GT. jbe - spec_zone) THEN
j_inner = jbe - spec_zone
ELSE
j_inner = j_inner
END IF
IF (u(i+1, k, j) .GT. 0.) THEN
CALL PUSHCONTROL1B(1)
ELSE
CALL PUSHCONTROL1B(0)
END IF
END DO
CALL PUSHINTEGER4(j - 1)
CALL PUSHINTEGER4(ad_from2)
END DO
END DO
DO i=itf,max5,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from2)
CALL POPINTEGER4(ad_to2)
DO j=ad_to2,ad_from2,-1
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
fieldb(i, k, j) = 0.0
ELSE
tmp2b = fieldb(i, k, j)
fieldb(i, k, j) = 0.0
fieldb(ibe-spec_zone, k, j_inner) = fieldb(ibe-spec_zone, &
& k, j_inner) + tmp2b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(j_inner)
ELSE
CALL POPINTEGER4(j_inner)
END IF
END DO
END DO
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO i=min2,its,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from1)
CALL POPINTEGER4(ad_to1)
DO j=ad_to1,ad_from1,-1
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
fieldb(i, k, j) = 0.0
ELSE
tmp1b = fieldb(i, k, j)
fieldb(i, k, j) = 0.0
fieldb(ibs+spec_zone, k, j_inner) = fieldb(ibs+spec_zone, &
& k, j_inner) + tmp1b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(j_inner)
ELSE
CALL POPINTEGER4(j_inner)
END IF
END DO
END DO
END DO
END IF
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=jtf,max2,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from0)
CALL POPINTEGER4(ad_to0)
DO i=ad_to0,ad_from0,-1
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
fieldb(i, k, j) = 0.0
ELSE
tmp0b = fieldb(i, k, j)
fieldb(i, k, j) = 0.0
fieldb(i_inner, k, jbe-spec_zone) = fieldb(i_inner, k, jbe-&
& spec_zone) + tmp0b
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(i_inner)
ELSE
CALL POPINTEGER4(i_inner)
END IF
END DO
END DO
END DO
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
DO j=min1,jts,-1
DO k=ktf,kts,-1
CALL POPINTEGER4(ad_from)
CALL POPINTEGER4(ad_to)
DO i=ad_to,ad_from,-1
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
fieldb(i, k, j) = 0.0
ELSE
tmpb = fieldb(i, k, j)
fieldb(i, k, j) = 0.0
fieldb(i_inner, k, jbs+spec_zone) = fieldb(i_inner, k, jbs+&
& spec_zone) + tmpb
END IF
CALL POPCONTROL1B(branch)
IF (branch .EQ. 0) THEN
CALL POPINTEGER4(i_inner)
ELSE
CALL POPINTEGER4(i_inner)
END IF
END DO
END DO
END DO
END IF
END SUBROUTINE A_FLOW_DEP_BDY_QNN
!---------------------------------------ntu3m-------------------------
SUBROUTINE a_flow_dep_bdy_fixed_inflow(a_field,u,v,config_flags, &
spec_zone,ids,ide,jds,jde,kds,kde, &
ims,ime,jms,jme,kms,kme,ips,ipe,jps,&
jpe,kps,kpe,its,ite,jts,jte,kts,kte)
!---------------------------------------------------------------------
IMPLICIT NONE
INTEGER, INTENT(IN) :: ids,ide,jds,jde,kds,kde,ims,ime,jms,jme, &
kms,kme,ips,ipe,jps,jpe,kps,kpe,its,ite, &
jts,jte,kts,kte,spec_zone
REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: &
a_field
REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: u,v
TYPE(grid_config_rec_type),INTENT(IN) :: config_flags
INTEGER :: i,j,k,ibs,ibe,jbs,jbe,itf,jtf,ktf,i_inner,j_inner, &
b_dist,b_limit
LOGICAL :: periodic_x
REAL :: a_aux
a_aux = 0.0
periodic_x = config_flags%periodic_x
ibs = ids
ibe = ide-1
itf = min(ite,ide-1)
jbs = jds
jbe = jde-1
jtf = min(jte,jde-1)
ktf = kde-1
IF (.NOT.periodic_x) THEN
IF (ibe - itf .lt. spec_zone) THEN
! X-end boundary
DO i = max(its,ibe-spec_zone+1), itf
b_dist = ibe - i
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
j_inner = max(j,jbs+spec_zone)
j_inner = min(j_inner,jbe-spec_zone)
IF (u(i+1,k,j) .gt. 0.) THEN
a_aux = a_aux+a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(ibe-spec_zone,k,j_inner) = &
a_field(ibe-spec_zone,k,j_inner)+a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = a_field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
IF (its - ibs .lt. spec_zone) THEN
! X-start boundary
DO i = its,min(itf,ibs+spec_zone-1)
b_dist = i - ibs
DO k = kts, ktf
DO j = max(jts,b_dist+jbs+1),min(jtf,jbe-b_dist-1)
j_inner = max(j,jbs+spec_zone)
j_inner = min(j_inner,jbe-spec_zone)
IF (u(i,k,j) .lt. 0.) THEN
a_aux = a_aux+a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(ibs+spec_zone,k,j_inner) = &
a_field(ibs+spec_zone,k,j_inner)+a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = a_field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
IF (jbe - jtf .lt. spec_zone) THEN
! Y-end boundary
DO j = max(jts,jbe-spec_zone+1), jtf
b_dist = jbe - j
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs),min(itf,ibe-b_limit)
i_inner = max(i,ibs+spec_zone)
i_inner = min(i_inner,ibe-spec_zone)
IF (periodic_x) i_inner = i
IF (v(i,k,j+1).gt.0.) THEN
a_aux = a_aux+a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(i_inner,k,jbe-spec_zone) = &
a_field(i_inner,k,jbe-spec_zone)+a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = a_field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
IF (jts - jbs .lt. spec_zone) THEN
! Y-start boundary
DO j = jts, min(jtf,jbs+spec_zone-1)
b_dist = j - jbs
b_limit = b_dist
IF (periodic_x) b_limit = 0
DO k = kts, ktf
DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
i_inner = max(i,ibs+spec_zone)
i_inner = min(i_inner,ibe-spec_zone)
IF (periodic_x) i_inner = i
IF (v(i,k,j) .lt. 0.) THEN
a_aux = a_aux+a_field(i,k,j)
a_field(i,k,j) = 0.
a_field(i_inner,k,jbs+spec_zone) = &
a_field(i_inner,k,jbs+spec_zone)+a_aux
a_aux = 0.
ELSE
a_field(i,k,j) = a_field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
END SUBROUTINE a_flow_dep_bdy_fixed_inflow
!--------------------------------------------------ntu3m-------------------------
END MODULE a_module_bc