!WRF+/TL:MODEL_LAYER:BOUNDARY
!Created by Ning Pan, 2010-08
!
MODULE g_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 g_set_physical_bc2d( dat,g_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 ) :: dat,g_dat
TYPE( grid_config_rec_type ) config_flags
INTEGER :: i, j, istag, jstag, itime
LOGICAL :: debug, open_bc_copy
!------------
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
periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if east and west both on-processor
IF ( its == ids ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO i = 0,-(bdyzone-1),-1
g_dat(ids+i-1,j) = g_dat(ide+i-1,j)
dat(ids+i-1,j) = dat(ide+i-1,j)
ENDDO
ENDDO
ENDIF
IF ( ite == ide ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
!! DO i = 1 , bdyzone
DO i = -istag , bdyzone
g_dat(ide+i+istag,j) = g_dat(ids+i+istag,j)
dat(ide+i+istag,j) = dat(ids+i+istag,j)
ENDDO
ENDDO
ENDIF
ENDIF
ELSE
symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
( its == ids ) ) THEN
IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO i = 1, bdyzone
g_dat(ids-i,j) = g_dat(ids+i-1,j)
dat(ids-i,j) = dat(ids+i-1,j)
ENDDO
ENDDO
ELSE
IF( variable == 'u' ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO i = 0, bdyzone-1
g_dat(ids-i,j) = - g_dat(ids+i,j)
dat(ids-i,j) = - dat(ids+i,j)
ENDDO
ENDDO
ELSE
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO i = 0, bdyzone-1
g_dat(ids-i,j) = g_dat(ids+i,j)
dat(ids-i,j) = dat(ids+i,j)
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_xs
! 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 = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO i = 1, bdyzone
g_dat(ide+i-1,j) = g_dat(ide-i,j)
dat(ide+i-1,j) = dat(ide-i,j)
ENDDO
ENDDO
ELSE
IF (variable == 'u' ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO i = 0, bdyzone-1
g_dat(ide+i,j) = - g_dat(ide-i,j)
dat(ide+i,j) = - dat(ide-i,j)
ENDDO
ENDDO
ELSE
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO i = 0, bdyzone-1
g_dat(ide+i,j) = g_dat(ide-i,j)
dat(ide+i,j) = dat(ide-i,j)
ENDDO
ENDDO
END IF
END IF
END IF symmetry_xe
! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
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 = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
g_dat(ids-1,j) = g_dat(ids,j)
dat(ids-1,j) = dat(ids,j)
g_dat(ids-2,j) = g_dat(ids,j)
dat(ids-2,j) = dat(ids,j)
g_dat(ids-3,j) = g_dat(ids,j)
dat(ids-3,j) = dat(ids,j)
ENDDO
ENDIF open_xs
! 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 = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
g_dat(ide ,j) = g_dat(ide-1,j)
dat(ide ,j) = dat(ide-1,j)
g_dat(ide+1,j) = g_dat(ide-1,j)
dat(ide+1,j) = dat(ide-1,j)
g_dat(ide+2,j) = g_dat(ide-1,j)
dat(ide+2,j) = dat(ide-1,j)
ENDDO
ELSE
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
g_dat(ide+1,j) = g_dat(ide,j)
dat(ide+1,j) = dat(ide,j)
g_dat(ide+2,j) = g_dat(ide,j)
dat(ide+2,j) = dat(ide,j)
g_dat(ide+3,j) = g_dat(ide,j)
dat(ide+3,j) = dat(ide,j)
ENDDO
END IF
END IF open_xe
! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
END IF periodicity_x
! 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( jts == jds ) then
DO j = 0, -(bdyzone-1), -1
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jds+j-1) = g_dat(i,jde+j-1)
dat(i,jds+j-1) = dat(i,jde+j-1)
ENDDO
ENDDO
END IF
IF( jte == jde ) then
DO j = -jstag, bdyzone
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jde+j+jstag) = g_dat(i,jds+j+jstag)
dat(i,jde+j+jstag) = dat(i,jds+j+jstag)
ENDDO
ENDDO
END IF
END IF
ELSE
symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
( jts == jds) ) THEN
IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
DO j = 1, bdyzone
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jds-j) = g_dat(i,jds+j-1)
dat(i,jds-j) = dat(i,jds+j-1)
ENDDO
ENDDO
ELSE
IF (variable == 'v') THEN
DO j = 1, bdyzone
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jds-j) = - g_dat(i,jds+j)
dat(i,jds-j) = - dat(i,jds+j)
ENDDO
ENDDO
ELSE
DO j = 1, bdyzone
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jds-j) = g_dat(i,jds+j)
dat(i,jds-j) = dat(i,jds+j)
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_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 = 1, bdyzone
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jde+j-1) = g_dat(i,jde-j)
dat(i,jde+j-1) = dat(i,jde-j)
ENDDO
ENDDO
ELSE
IF (variable == 'v' ) THEN
DO j = 1, bdyzone
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jde+j) = - g_dat(i,jde-j)
dat(i,jde+j) = - dat(i,jde-j)
ENDDO
ENDDO
ELSE
DO j = 1, bdyzone
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jde+j) = g_dat(i,jde-j)
dat(i,jde+j) = dat(i,jde-j)
ENDDO
ENDDO
END IF
ENDIF
END IF symmetry_ye
! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
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 = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jds-1) = g_dat(i,jds)
dat(i,jds-1) = dat(i,jds)
g_dat(i,jds-2) = g_dat(i,jds)
dat(i,jds-2) = dat(i,jds)
g_dat(i,jds-3) = g_dat(i,jds)
dat(i,jds-3) = dat(i,jds)
ENDDO
ENDIF open_ys
! 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 = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jde ) = g_dat(i,jde-1)
dat(i,jde ) = dat(i,jde-1)
g_dat(i,jde+1) = g_dat(i,jde-1)
dat(i,jde+1) = dat(i,jde-1)
g_dat(i,jde+2) = g_dat(i,jde-1)
dat(i,jde+2) = dat(i,jde-1)
ENDDO
ELSE
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,jde+1) = g_dat(i,jde)
dat(i,jde+1) = dat(i,jde)
g_dat(i,jde+2) = g_dat(i,jde)
dat(i,jde+2) = dat(i,jde)
g_dat(i,jde+3) = g_dat(i,jde)
dat(i,jde+3) = dat(i,jde)
ENDDO
ENDIF
END IF open_ye
! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
END IF periodicity_y
! 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. (jts == jds) ) THEN ! lower left corner fill
DO j = 0, -(bdyzone-1), -1
DO i = 0, -(bdyzone-1), -1
g_dat(ids+i-1,jds+j-1) = g_dat(ide+i-1,jde+j-1)
dat(ids+i-1,jds+j-1) = dat(ide+i-1,jde+j-1)
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
DO j = 0, -(bdyzone-1), -1
DO i = 1, bdyzone
g_dat(ide+i+istag,jds+j-1) = g_dat(ids+i+istag,jde+j-1)
dat(ide+i+istag,jds+j-1) = dat(ids+i+istag,jde+j-1)
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
DO j = 1, bdyzone
DO i = 1, bdyzone
g_dat(ide+i+istag,jde+j+jstag) = g_dat(ids+i+istag,jds+j+jstag)
dat(ide+i+istag,jde+j+jstag) = dat(ids+i+istag,jds+j+jstag)
ENDDO
ENDDO
END IF
IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
DO j = 1, bdyzone
DO i = 0, -(bdyzone-1), -1
g_dat(ids+i-1,jde+j+jstag) = g_dat(ide+i-1,jds+j+jstag)
dat(ids+i-1,jde+j+jstag) = dat(ide+i-1,jds+j+jstag)
ENDDO
ENDDO
END IF
END IF
END SUBROUTINE g_set_physical_bc2d
!-----------------------------------
SUBROUTINE g_set_physical_bc3d( dat,g_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 ) :: dat,g_dat
TYPE( grid_config_rec_type ) config_flags
INTEGER :: i, j, k, istag, jstag, itime, k_end
LOGICAL :: debug, open_bc_copy
!------------
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
periodicity_x: IF( ( config_flags%periodic_x ) ) THEN
IF ( ( ids == ips ) .and. ( ide == ipe ) ) THEN ! test if both east and west on-processor
IF ( its == ids ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = 0,-(bdyzone-1),-1
g_dat(ids+i-1,k,j) = g_dat(ide+i-1,k,j)
dat(ids+i-1,k,j) = dat(ide+i-1,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
IF ( ite == ide ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = -istag , bdyzone
g_dat(ide+i+istag,k,j) = g_dat(ids+i+istag,k,j)
dat(ide+i+istag,k,j) = dat(ids+i+istag,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
ELSE
symmetry_xs: IF( ( config_flags%symmetric_xs ) .and. &
( its == ids ) ) THEN
IF ( (variable /= 'u') .and. (variable /= 'x') ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ids-i,k,j) = g_dat(ids+i-1,k,j)
dat(ids-i,k,j) = dat(ids+i-1,k,j)
ENDDO
ENDDO
ENDDO
ELSE
IF ( variable == 'u' ) THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ids-i,k,j) = - g_dat(ids+i,k,j)
dat(ids-i,k,j) = - dat(ids+i,k,j)
ENDDO
ENDDO
ENDDO
ELSE
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ids-i,k,j) = g_dat(ids+i,k,j)
dat(ids-i,k,j) = dat(ids+i,k,j)
ENDDO
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_xs
! 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 = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ide+i-1,k,j) = g_dat(ide-i,k,j)
dat(ide+i-1,k,j) = dat(ide-i,k,j)
ENDDO
ENDDO
ENDDO
ELSE
IF (variable == 'u') THEN
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ide+i,k,j) = - g_dat(ide-i,k,j)
dat(ide+i,k,j) = - dat(ide-i,k,j)
ENDDO
ENDDO
ENDDO
ELSE
DO j = MAX(jds,jts-1), MIN(jte+1,jde+jstag)
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ide+i,k,j) = g_dat(ide-i,k,j)
dat(ide+i,k,j) = dat(ide-i,k,j)
ENDDO
ENDDO
ENDDO
END IF
END IF
END IF symmetry_xe
! set open b.c in X copy into boundary zone here. WCS, 19 March 2000
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 = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
DO k = kts, k_end
g_dat(ids-1,k,j) = g_dat(ids,k,j)
dat(ids-1,k,j) = dat(ids,k,j)
g_dat(ids-2,k,j) = g_dat(ids,k,j)
dat(ids-2,k,j) = dat(ids,k,j)
g_dat(ids-3,k,j) = g_dat(ids,k,j)
dat(ids-3,k,j) = dat(ids,k,j)
ENDDO
ENDDO
ENDIF open_xs
! 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 = jts-bdyzone, MIN(jte,jde+jstag)+bdyzone
DO k = kts, k_end
g_dat(ide ,k,j) = g_dat(ide-1,k,j)
dat(ide ,k,j) = dat(ide-1,k,j)
g_dat(ide+1,k,j) = g_dat(ide-1,k,j)
dat(ide+1,k,j) = dat(ide-1,k,j)
g_dat(ide+2,k,j) = g_dat(ide-1,k,j)
dat(ide+2,k,j) = dat(ide-1,k,j)
ENDDO
ENDDO
ELSE
!!!!!!! I am not sure about this one! JM 20020402
DO j = MAX(jds,jts-1)-bdyzone, MIN(jte+1,jde+jstag)+bdyzone
DO k = kts, k_end
g_dat(ide+1,k,j) = g_dat(ide,k,j)
dat(ide+1,k,j) = dat(ide,k,j)
g_dat(ide+2,k,j) = g_dat(ide,k,j)
dat(ide+2,k,j) = dat(ide,k,j)
g_dat(ide+3,k,j) = g_dat(ide,k,j)
dat(ide+3,k,j) = dat(ide,k,j)
ENDDO
ENDDO
END IF
END IF open_xe
! end open b.c in X copy into boundary zone addition. WCS, 19 March 2000
END IF periodicity_x
! 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( jts == jds ) then
DO j = 0, -(bdyzone-1), -1
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jds+j-1) = g_dat(i,k,jde+j-1)
dat(i,k,jds+j-1) = dat(i,k,jde+j-1)
ENDDO
ENDDO
ENDDO
END IF
IF( jte == jde ) then
DO j = -jstag, bdyzone
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jde+j+jstag) = g_dat(i,k,jds+j+jstag)
dat(i,k,jde+j+jstag) = dat(i,k,jds+j+jstag)
ENDDO
ENDDO
ENDDO
END IF
END IF
ELSE
symmetry_ys: IF( ( config_flags%symmetric_ys ) .and. &
( jts == jds) ) THEN
IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
DO j = 1, bdyzone
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jds-j) = g_dat(i,k,jds+j-1)
dat(i,k,jds-j) = dat(i,k,jds+j-1)
ENDDO
ENDDO
ENDDO
ELSE
IF (variable == 'v') THEN
DO j = 1, bdyzone
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jds-j) = - g_dat(i,k,jds+j)
dat(i,k,jds-j) = - dat(i,k,jds+j)
ENDDO
ENDDO
ENDDO
ELSE
DO j = 1, bdyzone
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jds-j) = g_dat(i,k,jds+j)
dat(i,k,jds-j) = dat(i,k,jds+j)
ENDDO
ENDDO
ENDDO
END IF
ENDIF
ENDIF symmetry_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 = 1, bdyzone
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jde+j-1) = g_dat(i,k,jde-j)
dat(i,k,jde+j-1) = dat(i,k,jde-j)
ENDDO
ENDDO
ENDDO
ELSE
IF ( variable == 'v' ) THEN
DO j = 1, bdyzone
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jde+j) = - g_dat(i,k,jde-j)
dat(i,k,jde+j) = - dat(i,k,jde-j)
ENDDO
ENDDO
ENDDO
ELSE
DO j = 1, bdyzone
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jde+j) = g_dat(i,k,jde-j)
dat(i,k,jde+j) = dat(i,k,jde-j)
ENDDO
ENDDO
ENDDO
END IF
ENDIF
END IF symmetry_ye
! set open b.c in Y copy into boundary zone here. WCS, 19 March 2000
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 = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jds-1) = g_dat(i,k,jds)
dat(i,k,jds-1) = dat(i,k,jds)
g_dat(i,k,jds-2) = g_dat(i,k,jds)
dat(i,k,jds-2) = dat(i,k,jds)
g_dat(i,k,jds-3) = g_dat(i,k,jds)
dat(i,k,jds-3) = dat(i,k,jds)
ENDDO
ENDDO
ENDIF open_ys
! 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 = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jde ) = g_dat(i,k,jde-1)
dat(i,k,jde ) = dat(i,k,jde-1)
g_dat(i,k,jde+1) = g_dat(i,k,jde-1)
dat(i,k,jde+1) = dat(i,k,jde-1)
g_dat(i,k,jde+2) = g_dat(i,k,jde-1)
dat(i,k,jde+2) = dat(i,k,jde-1)
ENDDO
ENDDO
ELSE
DO k = kts, k_end
DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
g_dat(i,k,jde+1) = g_dat(i,k,jde)
dat(i,k,jde+1) = dat(i,k,jde)
g_dat(i,k,jde+2) = g_dat(i,k,jde)
dat(i,k,jde+2) = dat(i,k,jde)
g_dat(i,k,jde+3) = g_dat(i,k,jde)
dat(i,k,jde+3) = dat(i,k,jde)
ENDDO
ENDDO
ENDIF
END IF open_ye
! end open b.c in Y copy into boundary zone addition. WCS, 19 March 2000
END IF periodicity_y
! 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. (jts == jds) ) THEN ! lower left corner fill
DO j = 0, -(bdyzone-1), -1
DO k = kts, k_end
DO i = 0, -(bdyzone-1), -1
g_dat(ids+i-1,k,jds+j-1) = g_dat(ide+i-1,k,jde+j-1)
dat(ids+i-1,k,jds+j-1) = dat(ide+i-1,k,jde+j-1)
ENDDO
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jts == jds) ) THEN ! lower right corner fill
DO j = 0, -(bdyzone-1), -1
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ide+i+istag,k,jds+j-1) = g_dat(ids+i+istag,k,jde+j-1)
dat(ide+i+istag,k,jds+j-1) = dat(ids+i+istag,k,jde+j-1)
ENDDO
ENDDO
ENDDO
END IF
IF ( (ite == ide) .and. (jte == jde) ) THEN ! upper right corner fill
DO j = 1, bdyzone
DO k = kts, k_end
DO i = 1, bdyzone
g_dat(ide+i+istag,k,jde+j+jstag) = g_dat(ids+i+istag,k,jds+j+jstag)
dat(ide+i+istag,k,jde+j+jstag) = dat(ids+i+istag,k,jds+j+jstag)
ENDDO
ENDDO
ENDDO
END IF
IF ( (its == ids) .and. (jte == jde) ) THEN ! upper left corner fill
DO j = 1, bdyzone
DO k = kts, k_end
DO i = 0, -(bdyzone-1), -1
g_dat(ids+i-1,k,jde+j+jstag) = g_dat(ide+i-1,k,jds+j+jstag)
dat(ids+i-1,k,jde+j+jstag) = dat(ide+i-1,k,jds+j+jstag)
ENDDO
ENDDO
ENDDO
END IF
END IF
END SUBROUTINE g_set_physical_bc3d
!------------------------------------------------------------------------
SUBROUTINE g_init_module_bc
END SUBROUTINE g_init_module_bc
!------------------------------------------------------------------------
SUBROUTINE g_relax_bdytend ( field, g_field, field_tend, g_field_tend, & 4,1
field_bdy_xs, g_field_bdy_xs, &
field_bdy_xe, g_field_bdy_xe, &
field_bdy_ys, g_field_bdy_ys, &
field_bdy_ye, g_field_bdy_ye, &
field_bdy_tend_xs, g_field_bdy_tend_xs, &
field_bdy_tend_xe, g_field_bdy_tend_xe, &
field_bdy_tend_ys, g_field_bdy_tend_ys, &
field_bdy_tend_ye, g_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(IN) :: g_field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: g_field_tend
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: field_tend
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_xs, g_field_bdy_xe
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_xs, field_bdy_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_ys, g_field_bdy_ye
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_ys, field_bdy_ye
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_tend_xs, g_field_bdy_tend_xe
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_tend_xs, field_bdy_tend_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_tend_ys, g_field_bdy_tend_ye
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_tend_ys, field_bdy_tend_ye
REAL, DIMENSION( spec_bdy_width ), INTENT(IN) :: fcx, gcx
TYPE(grid_config_rec_type), INTENT(IN) :: config_flags
CALL g_relax_bdytend_core ( field, g_field, field_tend, g_field_tend, &
field_bdy_xs, g_field_bdy_xs, &
field_bdy_xe, g_field_bdy_xe, &
field_bdy_ys, g_field_bdy_ys, &
field_bdy_ye, g_field_bdy_ye, &
field_bdy_tend_xs, g_field_bdy_tend_xs, &
field_bdy_tend_xe, g_field_bdy_tend_xe, &
field_bdy_tend_ys, g_field_bdy_tend_ys, &
field_bdy_tend_ye, g_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 g_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 g_relax_bdytend_tile ( field, g_field, field_tend, g_field_tend, & 3,1
field_bdy_xs, g_field_bdy_xs, &
field_bdy_xe, g_field_bdy_xe, &
field_bdy_ys, g_field_bdy_ys, &
field_bdy_ye, g_field_bdy_ye, &
field_bdy_tend_xs, g_field_bdy_tend_xs, &
field_bdy_tend_xe, g_field_bdy_tend_xe, &
field_bdy_tend_ys, g_field_bdy_tend_ys, &
field_bdy_tend_ye, g_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(IN ) :: g_field
REAL, DIMENSION(iXs:iXe, kXs:kXe, jXs:jXe ), INTENT(IN ) :: field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: g_field_tend
REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: field_tend
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_xs, g_field_bdy_xe
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_xs, field_bdy_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_ys, g_field_bdy_ye
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_ys, field_bdy_ye
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_tend_xs, g_field_bdy_tend_xe
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_tend_xs, field_bdy_tend_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_tend_ys, g_field_bdy_tend_ye
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_tend_ys, field_bdy_tend_ye
REAL, DIMENSION(spec_bdy_width), INTENT(IN) :: fcx, gcx
TYPE(grid_config_rec_type), INTENT(IN) :: config_flags
CALL g_relax_bdytend_core ( field, g_field, field_tend, g_field_tend, &
field_bdy_xs, g_field_bdy_xs, &
field_bdy_xe, g_field_bdy_xe, &
field_bdy_ys, g_field_bdy_ys, &
field_bdy_ye, g_field_bdy_ye, &
field_bdy_tend_xs, g_field_bdy_tend_xs, &
field_bdy_tend_xe, g_field_bdy_tend_xe, &
field_bdy_tend_ys, g_field_bdy_tend_ys, &
field_bdy_tend_ye, g_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 g_relax_bdytend_tile
! Tapenade 3.5 (r3785) - 22 Mar 2011 18:35
!
! Differentiation of relax_bdytend_core in forward (tangent) mode:
! variations of useful results: field_tend
! 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:in field_bdy_xe:in field_bdy_tend_xe:in
! field_tend:in-out field_bdy_xs:in field_bdy_tend_xs:in
! field_bdy_ye:in field_bdy_tend_ye:in field_bdy_ys:in
! field_bdy_tend_ys:in
! domain dims
! memory dims
! patch dims
! patch dims
! field (1st arg) dims; might be tile or patch
SUBROUTINE G_RELAX_BDYTEND_CORE(field, fieldd, field_tend, field_tendd, & 2
& field_bdy_xs, field_bdy_xsd, field_bdy_xe, field_bdy_xed, field_bdy_ys&
& , field_bdy_ysd, field_bdy_ye, field_bdy_yed, field_bdy_tend_xs, &
& field_bdy_tend_xsd, field_bdy_tend_xe, field_bdy_tend_xed, &
& field_bdy_tend_ys, field_bdy_tend_ysd, field_bdy_tend_ye, &
& field_bdy_tend_yed, 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), INTENT(IN) :: field
REAL, DIMENSION(ixs:ixe, kxs:kxe, jxs:jxe), INTENT(IN) :: fieldd
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
& field_tend
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
& field_tendd
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), INTENT(IN) :: &
& field_bdy_xsd, field_bdy_xed
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), INTENT(IN) :: &
& field_bdy_ysd, field_bdy_yed
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), INTENT(IN) :: &
& field_bdy_tend_xsd, field_bdy_tend_xed
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), INTENT(IN) :: &
& field_bdy_tend_ysd, field_bdy_tend_yed
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 :: fls0d, fls1d, fls2d, fls3d, fls4d
LOGICAL :: periodic_x
INTEGER :: min8
INTEGER :: min7
INTEGER :: min6
INTEGER :: min5
INTEGER :: min4
INTEGER :: min3
INTEGER :: min2
INTEGER :: min1
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
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
DO i=max2,min2
IF (i - 1 .LT. ibs) THEN
im1 = ibs
ELSE
im1 = i - 1
END IF
IF (i + 1 .GT. ibe) THEN
ip1 = ibe
ELSE
ip1 = i + 1
END IF
fls0d = field_bdy_ysd(i, k, b_dist+1) + dtbc*&
& field_bdy_tend_ysd(i, k, b_dist+1) - fieldd(i, k, j)
fls0 = field_bdy_ys(i, k, b_dist+1) + dtbc*field_bdy_tend_ys(i&
& , k, b_dist+1) - field(i, k, j)
fls1d = field_bdy_ysd(im1, k, b_dist+1) + dtbc*&
& field_bdy_tend_ysd(im1, k, b_dist+1) - fieldd(im1, k, j)
fls1 = field_bdy_ys(im1, k, b_dist+1) + dtbc*field_bdy_tend_ys&
& (im1, k, b_dist+1) - field(im1, k, j)
fls2d = field_bdy_ysd(ip1, k, b_dist+1) + dtbc*&
& field_bdy_tend_ysd(ip1, k, b_dist+1) - fieldd(ip1, k, j)
fls2 = field_bdy_ys(ip1, k, b_dist+1) + dtbc*field_bdy_tend_ys&
& (ip1, k, b_dist+1) - field(ip1, k, j)
fls3d = field_bdy_ysd(i, k, b_dist) + dtbc*field_bdy_tend_ysd(&
& i, k, b_dist) - fieldd(i, k, j-1)
fls3 = field_bdy_ys(i, k, b_dist) + dtbc*field_bdy_tend_ys(i, &
& k, b_dist) - field(i, k, j-1)
fls4d = field_bdy_ysd(i, k, b_dist+2) + dtbc*&
& field_bdy_tend_ysd(i, k, b_dist+2) - fieldd(i, k, j+1)
fls4 = field_bdy_ys(i, k, b_dist+2) + dtbc*field_bdy_tend_ys(i&
& , k, b_dist+2) - field(i, k, j+1)
field_tendd(i, k, j) = field_tendd(i, k, j) + fcx(b_dist+1)*&
& fls0d - gcx(b_dist+1)*(fls1d+fls2d+fls3d+fls4d-4.*fls0d)
field_tend(i, k, j) = field_tend(i, k, j) + fcx(b_dist+1)*fls0&
& - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
END DO
END DO
END DO
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
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
DO i=max4,min4
IF (i - 1 .LT. ibs) THEN
im1 = ibs
ELSE
im1 = i - 1
END IF
IF (i + 1 .GT. ibe) THEN
ip1 = ibe
ELSE
ip1 = i + 1
END IF
fls0d = field_bdy_yed(i, k, b_dist+1) + dtbc*&
& field_bdy_tend_yed(i, k, b_dist+1) - fieldd(i, k, j)
fls0 = field_bdy_ye(i, k, b_dist+1) + dtbc*field_bdy_tend_ye(i&
& , k, b_dist+1) - field(i, k, j)
fls1d = field_bdy_yed(im1, k, b_dist+1) + dtbc*&
& field_bdy_tend_yed(im1, k, b_dist+1) - fieldd(im1, k, j)
fls1 = field_bdy_ye(im1, k, b_dist+1) + dtbc*field_bdy_tend_ye&
& (im1, k, b_dist+1) - field(im1, k, j)
fls2d = field_bdy_yed(ip1, k, b_dist+1) + dtbc*&
& field_bdy_tend_yed(ip1, k, b_dist+1) - fieldd(ip1, k, j)
fls2 = field_bdy_ye(ip1, k, b_dist+1) + dtbc*field_bdy_tend_ye&
& (ip1, k, b_dist+1) - field(ip1, k, j)
fls3d = field_bdy_yed(i, k, b_dist) + dtbc*field_bdy_tend_yed(&
& i, k, b_dist) - fieldd(i, k, j+1)
fls3 = field_bdy_ye(i, k, b_dist) + dtbc*field_bdy_tend_ye(i, &
& k, b_dist) - field(i, k, j+1)
fls4d = field_bdy_yed(i, k, b_dist+2) + dtbc*&
& field_bdy_tend_yed(i, k, b_dist+2) - fieldd(i, k, j-1)
fls4 = field_bdy_ye(i, k, b_dist+2) + dtbc*field_bdy_tend_ye(i&
& , k, b_dist+2) - field(i, k, j-1)
field_tendd(i, k, j) = field_tendd(i, k, j) + fcx(b_dist+1)*&
& fls0d - gcx(b_dist+1)*(fls1d+fls2d+fls3d+fls4d-4.*fls0d)
field_tend(i, k, j) = field_tend(i, k, j) + fcx(b_dist+1)*fls0&
& - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
END DO
END DO
END DO
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
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
DO j=max6,min6
fls0d = field_bdy_xsd(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xsd(j, k, b_dist+1) - fieldd(i, k, j)
fls0 = field_bdy_xs(j, k, b_dist+1) + dtbc*field_bdy_tend_xs&
& (j, k, b_dist+1) - field(i, k, j)
fls1d = field_bdy_xsd(j-1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xsd(j-1, k, b_dist+1) - fieldd(i, k, j-1)
fls1 = field_bdy_xs(j-1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xs(j-1, k, b_dist+1) - field(i, k, j-1)
fls2d = field_bdy_xsd(j+1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xsd(j+1, k, b_dist+1) - fieldd(i, k, j+1)
fls2 = field_bdy_xs(j+1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xs(j+1, k, b_dist+1) - field(i, k, j+1)
fls3d = field_bdy_xsd(j, k, b_dist) + dtbc*&
& field_bdy_tend_xsd(j, k, b_dist) - fieldd(i-1, k, j)
fls3 = field_bdy_xs(j, k, b_dist) + dtbc*field_bdy_tend_xs(j&
& , k, b_dist) - field(i-1, k, j)
fls4d = field_bdy_xsd(j, k, b_dist+2) + dtbc*&
& field_bdy_tend_xsd(j, k, b_dist+2) - fieldd(i+1, k, j)
fls4 = field_bdy_xs(j, k, b_dist+2) + dtbc*field_bdy_tend_xs&
& (j, k, b_dist+2) - field(i+1, k, j)
field_tendd(i, k, j) = field_tendd(i, k, j) + fcx(b_dist+1)*&
& fls0d - gcx(b_dist+1)*(fls1d+fls2d+fls3d+fls4d-4.*fls0d)
field_tend(i, k, j) = field_tend(i, k, j) + fcx(b_dist+1)*&
& fls0 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
END DO
END DO
END DO
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
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
DO j=max8,min8
fls0d = field_bdy_xed(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xed(j, k, b_dist+1) - fieldd(i, k, j)
fls0 = field_bdy_xe(j, k, b_dist+1) + dtbc*field_bdy_tend_xe&
& (j, k, b_dist+1) - field(i, k, j)
fls1d = field_bdy_xed(j-1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xed(j-1, k, b_dist+1) - fieldd(i, k, j-1)
fls1 = field_bdy_xe(j-1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xe(j-1, k, b_dist+1) - field(i, k, j-1)
fls2d = field_bdy_xed(j+1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xed(j+1, k, b_dist+1) - fieldd(i, k, j+1)
fls2 = field_bdy_xe(j+1, k, b_dist+1) + dtbc*&
& field_bdy_tend_xe(j+1, k, b_dist+1) - field(i, k, j+1)
fls3d = field_bdy_xed(j, k, b_dist) + dtbc*&
& field_bdy_tend_xed(j, k, b_dist) - fieldd(i+1, k, j)
fls3 = field_bdy_xe(j, k, b_dist) + dtbc*field_bdy_tend_xe(j&
& , k, b_dist) - field(i+1, k, j)
fls4d = field_bdy_xed(j, k, b_dist+2) + dtbc*&
& field_bdy_tend_xed(j, k, b_dist+2) - fieldd(i-1, k, j)
fls4 = field_bdy_xe(j, k, b_dist+2) + dtbc*field_bdy_tend_xe&
& (j, k, b_dist+2) - field(i-1, k, j)
field_tendd(i, k, j) = field_tendd(i, k, j) + fcx(b_dist+1)*&
& fls0d - gcx(b_dist+1)*(fls1d+fls2d+fls3d+fls4d-4.*fls0d)
field_tend(i, k, j) = field_tend(i, k, j) + fcx(b_dist+1)*&
& fls0 - gcx(b_dist+1)*(fls1+fls2+fls3+fls4-4.*fls0)
END DO
END DO
END DO
END IF
END IF
END SUBROUTINE G_RELAX_BDYTEND_CORE
!------------------------------------------------------------------------
SUBROUTINE g_spec_bdytend ( field_tend, g_field_tend, & 7
field_bdy_xs, g_field_bdy_xs, &
field_bdy_xe, g_field_bdy_xe, &
field_bdy_ys, g_field_bdy_ys, &
field_bdy_ye, g_field_bdy_ye, &
field_bdy_tend_xs, g_field_bdy_tend_xs, &
field_bdy_tend_xe, g_field_bdy_tend_xe, &
field_bdy_tend_ys, g_field_bdy_tend_ys, &
field_bdy_tend_ye, g_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(OUT) :: g_field_tend
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(OUT) :: field_tend
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_xs, g_field_bdy_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_ys, g_field_bdy_ye
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_tend_xs, g_field_bdy_tend_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: g_field_bdy_tend_ys, g_field_bdy_tend_ye
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_xs, field_bdy_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_ys, field_bdy_ye
REAL, DIMENSION(jms:jme, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_tend_xs, field_bdy_tend_xe
REAL, DIMENSION(ims:ime, kds:kde, spec_bdy_width), INTENT(IN) :: field_bdy_tend_ys, field_bdy_tend_ye
TYPE(grid_config_rec_type), INTENT(IN) :: 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 (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)
g_field_tend(i,k,j) = g_field_bdy_tend_ys(i, k, b_dist+1)
field_tend(i,k,j) = field_bdy_tend_ys(i, k, b_dist+1)
ENDDO
ENDDO
ENDDO
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)
g_field_tend(i,k,j) = g_field_bdy_tend_ye(i, k, b_dist+1)
field_tend(i,k,j) = field_bdy_tend_ye(i, k, b_dist+1)
ENDDO
ENDDO
ENDDO
ENDIF
IF(.NOT.periodic_x)THEN
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)
g_field_tend(i,k,j) = g_field_bdy_tend_xs(j, k, b_dist+1)
field_tend(i,k,j) = field_bdy_tend_xs(j, k, b_dist+1)
ENDDO
ENDDO
ENDDO
ENDIF
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)
g_field_tend(i,k,j) = g_field_bdy_tend_xe(j, k, b_dist+1)
field_tend(i,k,j) = field_bdy_tend_xe(j, k, b_dist+1)
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_spec_bdytend
!------------------------------------------------------------------------
SUBROUTINE g_couple_bdy ( field, g_field, &
variable_in, config_flags, &
spec_zone, &
mu, g_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(IN ) :: g_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) :: g_field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: 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 (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
g_field(i,k,j) = g_field(i,k,j)*mu(i,j) + field(i,k,j)*g_mu(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)
else
g_field(i,k,j) = (g_field(i,k,j)*mu(i,j)+field(i,k,j)*g_mu(i,j)) / msf(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
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
g_field(i,k,j) = g_field(i,k,j)*mu(i,j) + field(i,k,j)*g_mu(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)
else
g_field(i,k,j) = (g_field(i,k,j)*mu(i,j)+field(i,k,j)*g_mu(i,j)) / msf(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
IF(.NOT.periodic_x)THEN
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
g_field(i,k,j) = g_field(i,k,j)*mu(i,j) + field(i,k,j)*g_mu(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)
else
g_field(i,k,j) = (g_field(i,k,j)*mu(i,j)+field(i,k,j)*g_mu(i,j)) / msf(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
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
g_field(i,k,j) = g_field(i,k,j)*mu(i,j) + field(i,k,j)*g_mu(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)
else
g_field(i,k,j) = (g_field(i,k,j)*mu(i,j)+field(i,k,j)*g_mu(i,j)) / msf(i,j)
field(i,k,j) = field(i,k,j)*mu(i,j)/msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_couple_bdy
!------------------------------------------------------------------------
SUBROUTINE g_uncouple_bdy( field, g_field, &
variable_in, config_flags, &
spec_zone, &
mu, g_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(IN ) :: g_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) :: g_field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: 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 (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
g_field(i,k,j) = g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j))
field(i,k,j) = field(i,k,j)/mu(i,j)
else
g_field(i,k,j) = ( g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j)) ) &
* msf(i,j)
field(i,k,j) = field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
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
g_field(i,k,j) = g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j))
field(i,k,j) = field(i,k,j)/mu(i,j)
else
g_field(i,k,j) = ( g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j)) ) &
* msf(i,j)
field(i,k,j) = field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
IF(.NOT.periodic_x)THEN
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
g_field(i,k,j) = g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j))
field(i,k,j) = field(i,k,j)/mu(i,j)
else
g_field(i,k,j) = ( g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j)) ) &
* msf(i,j)
field(i,k,j) = field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
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
g_field(i,k,j) = g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j))
field(i,k,j) = field(i,k,j)/mu(i,j)
else
g_field(i,k,j) = ( g_field(i,k,j)/mu(i,j) &
- field(i,k,j)*g_mu(i,j)/(mu(i,j)*mu(i,j)) ) &
* msf(i,j)
field(i,k,j) = field(i,k,j)/mu(i,j)*msf(i,j)
end if
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_uncouple_bdy
!------------------------------------------------------------------------
SUBROUTINE g_spec_bdyupdate( field, g_field, & 6
field_tend, g_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(INOUT) :: g_field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: g_field_tend
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: 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 (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)
g_field(i,k,j) = g_field(i,k,j) + dt*g_field_tend(i,k,j)
field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
ENDDO
ENDDO
ENDDO
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)
g_field(i,k,j) = g_field(i,k,j) + dt*g_field_tend(i,k,j)
field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
IF(.NOT.periodic_x)THEN
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)
g_field(i,k,j) = g_field(i,k,j) + dt*g_field_tend(i,k,j)
field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
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)
g_field(i,k,j) = g_field(i,k,j) + dt*g_field_tend(i,k,j)
field(i,k,j) = field(i,k,j) + dt*field_tend(i,k,j)
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_spec_bdyupdate
!------------------------------------------------------------------------
! Generated by TAPENADE (INRIA, Tropics team)
! Tapenade 3.10 (r5498) - 20 Jan 2015 09:48
!
! Differentiation of spec_bdy_final in forward (tangent) mode:
! variations of useful results: field
! 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:in field_bdy_tend_xe:in
! field_bdy_xs:in field_bdy_tend_xs:in field_bdy_ye:in
! field_bdy_tend_ye:in field_bdy_ys:in field_bdy_tend_ys:in
! mu:in
! domain dims
! memory dims
! patch dims
SUBROUTINE g_SPEC_BDY_FINAL(field, fieldd, mu, mud, msf, field_bdy_xs, & 10
& field_bdy_xsd, field_bdy_xe, field_bdy_xed, field_bdy_ys, &
& field_bdy_ysd, field_bdy_ye, field_bdy_yed, field_bdy_tend_xs, &
& field_bdy_tend_xsd, field_bdy_tend_xe, field_bdy_tend_xed, &
& field_bdy_tend_ys, field_bdy_tend_ysd, field_bdy_tend_ye, &
& field_bdy_tend_yed, 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) :: fieldd
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mu, msf
REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: mud
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), INTENT(IN) :: &
& field_bdy_xsd, field_bdy_xed
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), INTENT(IN) :: &
& field_bdy_ysd, field_bdy_yed
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), INTENT(IN) :: &
& field_bdy_tend_xsd, field_bdy_tend_xed
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), INTENT(IN) :: &
& field_bdy_tend_ysd, field_bdy_tend_yed
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 :: bfieldd, xmud
LOGICAL :: periodic_x, msfcouple, mucouple
INTEGER :: min6
INTEGER :: min5
INTEGER :: min4
INTEGER :: min3
INTEGER :: min2
INTEGER :: min1
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
xmud = 0.0
ELSE
min1 = jtf
xmud = 0.0
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
DO i=max1,min3
bfieldd = field_bdy_ysd(i, k, b_dist+1) + dtbc*&
& field_bdy_tend_ysd(i, k, b_dist+1)
bfield = field_bdy_ys(i, k, b_dist+1) + dtbc*field_bdy_tend_ys&
& (i, k, b_dist+1)
IF (msfcouple) xmsf = msf(i, j)
IF (mucouple) THEN
xmud = mud(i, j)
xmu = mu(i, j)
END IF
fieldd(i, k, j) = (xmsf*bfieldd*xmu-xmsf*bfield*xmud)/xmu**2
field(i, k, j) = xmsf*bfield/xmu
END DO
END DO
END DO
ELSE
xmud = 0.0
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
DO i=max3,min4
bfieldd = field_bdy_yed(i, k, b_dist+1) + dtbc*&
& field_bdy_tend_yed(i, k, b_dist+1)
bfield = field_bdy_ye(i, k, b_dist+1) + dtbc*field_bdy_tend_ye&
& (i, k, b_dist+1)
IF (msfcouple) xmsf = msf(i, j)
IF (mucouple) THEN
xmud = mud(i, j)
xmu = mu(i, j)
END IF
fieldd(i, k, j) = (xmsf*bfieldd*xmu-xmsf*bfield*xmud)/xmu**2
field(i, k, j) = xmsf*bfield/xmu
END DO
END DO
END DO
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
DO j=max4,min5
bfieldd = field_bdy_xsd(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xsd(j, k, b_dist+1)
bfield = field_bdy_xs(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xs(j, k, b_dist+1)
IF (msfcouple) xmsf = msf(i, j)
IF (mucouple) THEN
xmud = mud(i, j)
xmu = mu(i, j)
END IF
fieldd(i, k, j) = (xmsf*bfieldd*xmu-xmsf*bfield*xmud)/xmu**2
field(i, k, j) = xmsf*bfield/xmu
END DO
END DO
END DO
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
DO j=max6,min6
bfieldd = field_bdy_xed(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xed(j, k, b_dist+1)
bfield = field_bdy_xe(j, k, b_dist+1) + dtbc*&
& field_bdy_tend_xe(j, k, b_dist+1)
IF (msfcouple) xmsf = msf(i, j)
IF (mucouple) THEN
xmud = mud(i, j)
xmu = mu(i, j)
END IF
fieldd(i, k, j) = (xmsf*bfieldd*xmu-xmsf*bfield*xmud)/xmu**2
field(i, k, j) = xmsf*bfield/xmu
END DO
END DO
END DO
END IF
END IF
END SUBROUTINE g_SPEC_BDY_FINAL
!------------------------------------------------------------------------
SUBROUTINE g_zero_grad_bdy ( field, g_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) :: g_field
REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: 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
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 (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
g_field(i,k,j) = g_field(i_inner,k,jbs+spec_zone)
field(i,k,j) = field(i_inner,k,jbs+spec_zone)
ENDDO
ENDDO
ENDDO
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
g_field(i,k,j) = g_field(i_inner,k,jbe-spec_zone)
field(i,k,j) = field(i_inner,k,jbe-spec_zone)
ENDDO
ENDDO
ENDDO
ENDIF
IF(.NOT.periodic_x)THEN
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)
g_field(i,k,j) = g_field(ibs+spec_zone,k,j_inner)
field(i,k,j) = field(ibs+spec_zone,k,j_inner)
ENDDO
ENDDO
ENDDO
ENDIF
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)
g_field(i,k,j) = g_field(ibe-spec_zone,k,j_inner)
field(i,k,j) = field(ibe-spec_zone,k,j_inner)
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_zero_grad_bdy
!------------------------------------------------------------------------
SUBROUTINE g_flow_dep_bdy ( field, g_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) :: g_field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: 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
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 (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
g_field(i,k,j) = g_field(i_inner,k,jbs+spec_zone)
field(i,k,j) = field(i_inner,k,jbs+spec_zone)
ELSE
g_field(i,k,j) = 0.
field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
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
g_field(i,k,j) = g_field(i_inner,k,jbe-spec_zone)
field(i,k,j) = field(i_inner,k,jbe-spec_zone)
ELSE
g_field(i,k,j) = 0.
field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
IF(.NOT.periodic_x)THEN
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
g_field(i,k,j) = g_field(ibs+spec_zone,k,j_inner)
field(i,k,j) = field(ibs+spec_zone,k,j_inner)
ELSE
g_field(i,k,j) = 0.
field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
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
g_field(i,k,j) = g_field(ibe-spec_zone,k,j_inner)
field(i,k,j) = field(ibe-spec_zone,k,j_inner)
ELSE
g_field(i,k,j) = 0.
field(i,k,j) = 0.
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_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 forward (tangent) mode:
! variations 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 G_FLOW_DEP_BDY_QNN(field, fieldd, u, v, config_flags, & 1
& spec_zone, ccn_conc, 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, INTENT(IN) :: ccn_conc ! RAS
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: field
REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: fieldd
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
INTEGER :: min6
INTEGER :: min5
INTEGER :: min4
INTEGER :: min3
INTEGER :: min2
INTEGER :: min1
INTRINSIC MAX
INTRINSIC MIN
INTEGER :: max6
INTEGER :: max5
INTEGER :: max4
INTEGER :: max3
INTEGER :: max2
INTEGER :: max1
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
DO i=max1,min3
IF (i .LT. ibs + spec_zone) THEN
i_inner = ibs + spec_zone
ELSE
i_inner = i
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
fieldd(i, k, j) = fieldd(i_inner, k, jbs+spec_zone)
field(i, k, j) = field(i_inner, k, jbs+spec_zone)
ELSE
fieldd(i, k, j) = 0.0
field(i, k, j) = ccn_conc
END IF
END DO
END DO
END DO
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
DO i=max3,min4
IF (i .LT. ibs + spec_zone) THEN
i_inner = ibs + spec_zone
ELSE
i_inner = i
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
fieldd(i, k, j) = fieldd(i_inner, k, jbe-spec_zone)
field(i, k, j) = field(i_inner, k, jbe-spec_zone)
ELSE
fieldd(i, k, j) = 0.0
field(i, k, j) = ccn_conc
END IF
END DO
END DO
END DO
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
DO j=max4,min5
IF (j .LT. jbs + spec_zone) THEN
j_inner = jbs + spec_zone
ELSE
j_inner = j
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
fieldd(i, k, j) = fieldd(ibs+spec_zone, k, j_inner)
field(i, k, j) = field(ibs+spec_zone, k, j_inner)
ELSE
fieldd(i, k, j) = 0.0
field(i, k, j) = ccn_conc
END IF
END DO
END DO
END DO
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
DO j=max6,min6
IF (j .LT. jbs + spec_zone) THEN
j_inner = jbs + spec_zone
ELSE
j_inner = j
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
fieldd(i, k, j) = fieldd(ibe-spec_zone, k, j_inner)
field(i, k, j) = field(ibe-spec_zone, k, j_inner)
ELSE
fieldd(i, k, j) = 0.0
field(i, k, j) = ccn_conc
END IF
END DO
END DO
END DO
END IF
END IF
END SUBROUTINE G_FLOW_DEP_BDY_QNN
!---------------------------------------------ntu3m---------------------------
SUBROUTINE g_flow_dep_bdy_fixed_inflow(field,g_field,u,v,config_flags, & 1
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) :: g_field, &
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
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 (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
g_field(i,k,j) = g_field(i_inner,k,jbs+spec_zone)
field(i,k,j) = field(i_inner,k,jbs+spec_zone)
ELSE
g_field(i,k,j) = g_field(i,k,j)
field(i,k,j) = field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
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
g_field(i,k,j) = g_field(i_inner,k,jbe-spec_zone)
field(i,k,j) = field(i_inner,k,jbe-spec_zone)
ELSE
g_field(i,k,j) = g_field(i,k,j)
field(i,k,j) = field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
IF (.NOT.periodic_x) THEN
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
g_field(i,k,j) = g_field(ibs+spec_zone,k,j_inner)
field(i,k,j) = field(ibs+spec_zone,k,j_inner)
ELSE
g_field(i,k,j) = g_field(i,k,j)
field(i,k,j) = field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
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
g_field(i,k,j) = g_field(ibe-spec_zone,k,j_inner)
field(i,k,j) = field(ibe-spec_zone,k,j_inner)
ELSE
g_field(i,k,j) = g_field(i,k,j)
field(i,k,j) = field(i,k,j)
ENDIF
ENDDO
ENDDO
ENDDO
ENDIF
ENDIF
END SUBROUTINE g_flow_dep_bdy_fixed_inflow
!-----------------------------------------------ntu3m----------------------------
END MODULE g_module_bc