915 lines
34 KiB
Fortran
Executable File
915 lines
34 KiB
Fortran
Executable File
MODULE agrif_dom_update
|
|
|
|
USE dom_oce
|
|
USE agrif_parameters
|
|
USE agrif_profiles
|
|
USE agrif_recompute_scales
|
|
USE lbclnk
|
|
|
|
IMPLICIT none
|
|
PRIVATE
|
|
|
|
REAL(wp), PARAMETER :: rminfrac = 0.98_wp ! Should be < 1
|
|
LOGICAL :: l_match_area=.FALSE.
|
|
|
|
PUBLIC agrif_update_all
|
|
|
|
CONTAINS
|
|
|
|
#if defined key_agrif
|
|
|
|
SUBROUTINE agrif_update_all
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE agrif_update_all ***
|
|
!!----------------------------------------------------------------------
|
|
!
|
|
|
|
IF( Agrif_Root() ) return
|
|
!
|
|
! Update e1t and e2t (set grid cell area as over child grid):
|
|
CALL agrif_update_variable(e1e2t_upd_id, procname = update_e1e2t)
|
|
|
|
! Update e2u and e1v at cell faces:
|
|
CALL agrif_update_variable(e2u_id, procname = update_e2u)
|
|
CALL agrif_update_variable(e1v_id, procname = update_e1v)
|
|
|
|
! Then compute fractional area over child grid:
|
|
ALLOCATE(e1e2t_frac(jpi,jpj), e2u_frac(jpi,jpj), e1v_frac(jpi,jpj))
|
|
CALL Agrif_Init_variable(e1e2t_frac_id, procname = interp_e1e2t_frac)
|
|
! And fractional size of cell faces:
|
|
CALL Agrif_Init_variable(e2u_frac_id, procname = interp_e2u_frac)
|
|
CALL Agrif_Init_variable(e1v_frac_id, procname = interp_e1v_frac)
|
|
!
|
|
! Update scale factors:
|
|
!
|
|
Agrif_UseSpecialValueInUpdate = .FALSE.
|
|
IF ( .NOT.ln_vert_remap ) THEN
|
|
! Get max bottom level over coarse grid (mbkt):
|
|
CALL agrif_update_variable(mbkt_id, procname = update_mbkt)
|
|
! Set e3t over parent as averages of child grid cells:
|
|
CALL agrif_update_variable(e3t_id, procname = update_e3t_z)
|
|
! Set e3w over parent as the center of child cells volumes:
|
|
CALL agrif_update_variable(e3w_id, procname = update_e3w_z)
|
|
!
|
|
! Update surface mask at U/V points in case it has been updated above:
|
|
CALL Agrif_ChildGrid_To_ParentGrid()
|
|
CALL update_surf_masks
|
|
CALL Agrif_ParentGrid_To_ChildGrid()
|
|
!
|
|
! Set mbku as maximum over U-faces:
|
|
CALL agrif_update_variable(mbku_id, procname = update_mbku)
|
|
! Set e3u/e3uw as U-faces averages:
|
|
CALL agrif_update_variable(e3u_id, procname = update_e3u_z)
|
|
! Set e3uw over parent as the center of child cells volumes:
|
|
CALL agrif_update_variable(e3uw_id, procname = update_e3uw_z)
|
|
! Set mbkv as maximum over V-faces:
|
|
CALL agrif_update_variable(mbkv_id, procname = update_mbkv)
|
|
! Set e3v/e3vw as v-faces averages:
|
|
CALL agrif_update_variable(e3v_id, procname = update_e3v_z)
|
|
! Set e3vw over parent as the center of child cells volumes:
|
|
CALL agrif_update_variable(e3vw_id, procname = update_e3vw_z)
|
|
! Copy mbkf value at F-points:
|
|
CALL agrif_update_variable(mbkf_id, procname = update_mbkf)
|
|
! Copy e3f at faces corners:
|
|
CALL agrif_update_variable(e3f_id, procname = update_e3f_z)
|
|
!
|
|
ELSE
|
|
! Reconstruct e3t/e3w over parent grid such that total volume is conserved:
|
|
CALL agrif_update_variable(e3t_id, procname = update_e3tw_z_gen)
|
|
!
|
|
! Update vertical scale factors at U, V and F-points:
|
|
CALL Agrif_ChildGrid_To_ParentGrid()
|
|
CALL update_surf_masks
|
|
CALL agrif_recompute_scalefactors
|
|
CALL Agrif_ParentGrid_To_ChildGrid()
|
|
ENDIF
|
|
DEALLOCATE(e1e2t_frac, e2u_frac, e1v_frac)
|
|
!
|
|
END SUBROUTINE agrif_update_all
|
|
|
|
|
|
SUBROUTINE update_surf_masks
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_surf_masks ***
|
|
!!
|
|
!! Update surface mask at U/V points from mask at T-points
|
|
!!----------------------------------------------------------------------
|
|
INTEGER :: ji, jj
|
|
!!----------------------------------------------------------------------
|
|
DO jj = 1, jpjm1
|
|
DO ji = 1, jpim1
|
|
ssumask(ji,jj) = ssmask(ji ,jj ) * ssmask(ji+1,jj )
|
|
ssvmask(ji,jj) = ssmask(ji ,jj ) * ssmask(ji ,jj+1)
|
|
ssfmask(ji,jj) = ssmask(ji ,jj ) * ssmask(ji+1,jj ) &
|
|
&*ssmask(ji+1,jj+1) * ssmask(ji ,jj+1)
|
|
END DO
|
|
END DO
|
|
!
|
|
CALL lbc_lnk_multi( 'update_surf_masks', ssumask, 'U', 1., ssvmask, 'V', 1., ssfmask,'F', 1.)
|
|
!
|
|
END SUBROUTINE update_surf_masks
|
|
|
|
|
|
SUBROUTINE update_mbkt( ptab, i1, i2, j1, j2, before)
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_mbkt ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL, DIMENSION(i1:i2,j1:j2) , INTENT(inout) :: ptab
|
|
LOGICAL , INTENT(in ) :: before
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!
|
|
IF( before) THEN
|
|
ptab(i1:i2,j1:j2) = mbkt(i1:i2,j1:j2) * ssmask(i1:i2,j1:j2)
|
|
ELSE
|
|
mbkt(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2))
|
|
|
|
WHERE ( mbkt(i1:i2,j1:j2) .EQ. 0 )
|
|
ssmask(i1:i2,j1:j2) = 0._wp
|
|
mbkt(i1:i2,j1:j2) = 1
|
|
ELSEWHERE
|
|
ssmask(i1:i2,j1:j2) = 1._wp
|
|
END WHERE
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_mbkt
|
|
|
|
|
|
SUBROUTINE update_mbku( ptab, i1, i2, j1, j2, before)
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_mbku ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL, DIMENSION(i1:i2,j1:j2) , INTENT(inout) :: ptab
|
|
LOGICAL , INTENT(in ) :: before
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!
|
|
IF( before) THEN
|
|
ptab(i1:i2,j1:j2) = mbku(i1:i2,j1:j2) * ssumask(i1:i2,j1:j2)
|
|
ELSE
|
|
mbku(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2))
|
|
|
|
WHERE ( mbku(i1:i2,j1:j2) .EQ. 0 )
|
|
mbku(i1:i2,j1:j2) = 1
|
|
END WHERE
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_mbku
|
|
|
|
|
|
SUBROUTINE update_mbkv( ptab, i1, i2, j1, j2, before)
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_mbkv ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL, DIMENSION(i1:i2,j1:j2) , INTENT(inout) :: ptab
|
|
LOGICAL , INTENT(in ) :: before
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!
|
|
IF( before) THEN
|
|
ptab(i1:i2,j1:j2) = mbkv(i1:i2,j1:j2) * ssvmask(i1:i2,j1:j2)
|
|
ELSE
|
|
mbkv(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2))
|
|
|
|
WHERE ( mbkv(i1:i2,j1:j2) .EQ. 0 )
|
|
mbkv(i1:i2,j1:j2) = 1
|
|
END WHERE
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_mbkv
|
|
|
|
|
|
SUBROUTINE update_mbkf( ptab, i1, i2, j1, j2, before)
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_mbkf ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL, DIMENSION(i1:i2,j1:j2) , INTENT(inout) :: ptab
|
|
LOGICAL , INTENT(in ) :: before
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!
|
|
IF( before) THEN
|
|
ptab(i1:i2,j1:j2) = mbkf(i1:i2,j1:j2) * ssfmask(i1:i2,j1:j2)
|
|
ELSE
|
|
mbkf(i1:i2,j1:j2) = nint(ptab(i1:i2,j1:j2))
|
|
|
|
WHERE ( mbkf(i1:i2,j1:j2) .EQ. 0 )
|
|
mbkf(i1:i2,j1:j2) = 1
|
|
END WHERE
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_mbkf
|
|
|
|
|
|
SUBROUTINE update_e3t_z( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3t_z ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk, ik
|
|
REAL(wp) :: zimin
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk=k1,k2
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssmask(ji,jj) /=0._wp).AND.(mbkt(ji,jj).GE.jk) ) THEN
|
|
tabres(ji,jj,jk) = e1e2t_frac(ji,jj) * e3t_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
tabres(i1:i2,j1:j2,k2) = e1e2t_frac(i1:i2,j1:j2) * ssmask(i1:i2,j1:j2) ! To get fractional area
|
|
ELSE
|
|
!
|
|
DO jk=1,jpkm1
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssmask(ji,jj)==1._wp).AND.(mbkt(ji,jj).GE.jk) ) THEN
|
|
e3t_0(ji,jj,jk) = tabres(ji,jj,jk)
|
|
ELSE
|
|
e3t_0(ji,jj,jk) = e3t_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
! Change surface mask below in case of too shallow
|
|
! depth on parent grid
|
|
!---------------------------------------------------
|
|
! Update bathymetry:
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
bathy(ji,jj) = SUM(e3t_0(ji,jj,1:mbkt(ji,jj) ) )
|
|
END DO
|
|
END DO
|
|
!
|
|
! Mask points:
|
|
|
|
|
|
IF ( l_match_area) THEN ; zimin = 0._wp ; ELSE ; zimin = rminfrac ; ENDIF
|
|
|
|
WHERE ( ( mbkt(i1:i2,j1:j2) .EQ. 1 ) &
|
|
& .OR.(tabres(i1:i2,j1:j2,k2)<=zimin) )
|
|
bathy(i1:i2,j1:j2) = 0._wp
|
|
ssmask(i1:i2,j1:j2) = 0._wp
|
|
mbkt(i1:i2,j1:j2) = 1
|
|
END WHERE
|
|
!
|
|
! Reset thicknesses to the one from the reference grid over land:
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF (mbkt(ji,jj)==1) THEN
|
|
DO jk=1,jpk
|
|
e3t_0(ji,jj,jk) = e3t_1d(jk)
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3t_z
|
|
|
|
SUBROUTINE update_e3tw_z_gen( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3tw_z_gen ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk, ik
|
|
REAL(wp) :: ze3min, zdepth, zdepwp, ze3tp, ze3wp, zimin
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk = k1, k2-1
|
|
DO jj = j1, j2
|
|
DO ji = i1, i2
|
|
IF ( (ssmask(ji,jj) /=0._wp).AND.( mbkt(ji,jj) .GE. jk ) ) THEN
|
|
tabres(ji,jj,jk) = e1e2t_frac(ji,jj) * e3t_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
endif
|
|
END DO
|
|
END DO
|
|
END DO
|
|
tabres(i1:i2,j1:j2,k2) = e1e2t_frac(i1:i2,j1:j2) * ssmask(i1:i2,j1:j2) ! To get fractional area
|
|
ELSE
|
|
!
|
|
! Compute child bathymetry:
|
|
bathy(i1:i2,j1:j2) = 0._wp
|
|
DO jk=k1,k2-1
|
|
bathy(i1:i2,j1:j2) = bathy(i1:i2,j1:j2) + tabres(i1:i2,j1:j2,jk)
|
|
END DO
|
|
WHERE( bathy(i1:i2,j1:j2) == 0._wp ) ; mbathy(i1:i2,j1:j2) = 0
|
|
ELSE WHERE ; mbathy(i1:i2,j1:j2) = jpkm1
|
|
END WHERE
|
|
|
|
DO jk = jpkm1, 1, -1
|
|
zdepth = gdepw_1d(jk) + 1.e-6 ! + MIN( e3zps_min, e3t_1d(jk)*e3zps_rat )
|
|
WHERE( 0._wp < bathy(i1:i2,j1:j2) .AND. bathy(i1:i2,j1:j2) <= zdepth ) mbathy(i1:i2,j1:j2) = jk-1
|
|
END DO
|
|
|
|
! Scale factors and depth at T- and W-points
|
|
DO jk = 1, jpk
|
|
gdept_0(i1:i2,j1:j2,jk) = gdept_1d(jk)
|
|
gdepw_0(i1:i2,j1:j2,jk) = gdepw_1d(jk)
|
|
e3t_0 (i1:i2,j1:j2,jk) = e3t_1d (jk)
|
|
e3w_0 (i1:i2,j1:j2,jk) = e3w_1d (jk)
|
|
END DO
|
|
! Scale factors and depth at T- and W-points
|
|
DO jj = j1, j2
|
|
DO ji = i1, i2
|
|
ik = mbathy(ji,jj)
|
|
IF( ik > 0 ) THEN ! ocean point only
|
|
! max ocean level case
|
|
IF( ik == jpkm1 ) THEN
|
|
zdepwp = bathy(ji,jj)
|
|
ze3tp = bathy(ji,jj) - gdepw_1d(ik)
|
|
ze3wp = 0.5_wp * e3w_1d(ik) * ( 1._wp + ( ze3tp/e3t_1d(ik) ) )
|
|
e3t_0(ji,jj,ik ) = ze3tp
|
|
e3w_0(ji,jj,ik ) = ze3wp
|
|
IF ( ln_e3_dep.AND.ln_dept_mid ) THEN
|
|
gdept_0(ji,jj,ik) = gdepw_1d(ik) + 0.5_wp * ze3tp
|
|
e3w_0(ji,jj,ik ) = gdept_0(ji,jj,ik) - gdept_0(ji,jj,ik-1)
|
|
ELSE
|
|
gdept_0(ji,jj,ik) = gdept_1d(ik-1) + ze3wp
|
|
e3w_0(ji,jj,ik ) = ze3wp
|
|
ENDIF
|
|
gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + ze3tp
|
|
e3w_0(ji,jj,ik+1) = ze3tp
|
|
gdepw_0(ji,jj,ik+1) = zdepwp
|
|
!
|
|
ELSE ! standard case
|
|
IF( bathy(ji,jj) <= gdepw_1d(ik+1) ) THEN
|
|
gdepw_0(ji,jj,ik+1) = bathy(ji,jj)
|
|
ELSE
|
|
gdepw_0(ji,jj,ik+1) = gdepw_1d(ik+1)
|
|
ENDIF
|
|
e3t_0 (ji,jj,ik) = e3t_1d (ik) * ( gdepw_0 (ji,jj,ik+1) - gdepw_1d(ik)) &
|
|
& / ( gdepw_1d( ik+1) - gdepw_1d(ik))
|
|
IF ( ln_e3_dep.AND.ln_dept_mid ) THEN
|
|
gdept_0(ji,jj,ik) = gdepw_1d(ik) + 0.5_wp * e3t_0(ji,jj,ik)
|
|
e3w_0(ji,jj,ik) = gdept_0(ji,jj,ik) - gdept_0(ji,jj,ik-1)
|
|
ELSE
|
|
gdept_0(ji,jj,ik) = gdepw_1d(ik) + ( gdepw_0(ji,jj,ik+1) - gdepw_1d(ik) ) &
|
|
& * ((gdept_1d( ik ) - gdepw_1d(ik) ) &
|
|
& / ( gdepw_1d( ik+1) - gdepw_1d(ik) ))
|
|
e3w_0(ji,jj,ik) = &
|
|
& 0.5_wp * (gdepw_0(ji,jj,ik+1) + gdepw_1d(ik+1) - 2._wp * gdepw_1d(ik) ) &
|
|
& * ( e3w_1d(ik) / ( gdepw_1d(ik+1) - gdepw_1d(ik) ) )
|
|
ENDIF
|
|
! ... on ik+1
|
|
e3w_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik)
|
|
e3t_0 (ji,jj,ik+1) = e3t_0 (ji,jj,ik)
|
|
gdept_0(ji,jj,ik+1) = gdept_0(ji,jj,ik) + e3t_0(ji,jj,ik)
|
|
ENDIF
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
!
|
|
! Expand last level if too thin:
|
|
! DO jj=j1,j2
|
|
! DO ji=i1,i2
|
|
! ik = mbathy(ji,jj)
|
|
! IF ( ik > 2 ) THEN
|
|
! ze3min = MIN( e3zps_min, e3t_1d(ik)*e3zps_rat )
|
|
! IF ( e3t_0(ji,jj,ik) < ze3min ) THEN
|
|
! e3t_0(ji,jj,ik-1) = e3t_0(ji,jj,ik-1) - (ze3min - e3t_0(ji,jj,ik))
|
|
! e3t_0(ji,jj,ik ) = ze3min
|
|
! gdept_0(ji,jj,ik-1) = gdepw_1d(ik-1) + 0.5_wp * e3t_0(ji,jj,ik-1)
|
|
! gdept_0(ji,jj,ik ) = gdept_0(ji,jj,ik-1) + 0.5_wp * (e3t_0(ji,jj,ik) + e3t_0(ji,jj,ik-1))
|
|
! e3w_0(ji,jj,ik-1) = gdept_0(ji,jj,ik-1)-gdept_0(ji,jj,ik-2)
|
|
! e3w_0(ji,jj,ik ) = gdept_0(ji,jj,ik )-gdept_0(ji,jj,ik-1)
|
|
! e3w_0 (ji,jj,ik+1) = e3t_0(ji,jj,ik)
|
|
! e3t_0 (ji,jj,ik+1) = e3t_0(ji,jj,ik)
|
|
! ENDIF
|
|
! ENDIF
|
|
! END DO
|
|
! END DO
|
|
!
|
|
mbkt(i1:i2,j1:j2) = MAX( mbathy(i1:i2,j1:j2), 1 )
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
bathy(ji,jj) = SUM(e3t_0(ji,jj,1:mbkt(ji,jj) ) )
|
|
END DO
|
|
END DO
|
|
!
|
|
IF ( l_match_area) THEN ; zimin = 0._wp ; ELSE ; zimin = rminfrac ; ENDIF
|
|
|
|
WHERE ( ( mbkt(i1:i2,j1:j2) .EQ. 1 ) &
|
|
& .OR.(tabres(i1:i2,j1:j2,k2)<zimin) )
|
|
bathy(i1:i2,j1:j2) = 0._wp
|
|
ssmask(i1:i2,j1:j2) = 0._wp
|
|
mbkt(i1:i2,j1:j2) = 1
|
|
ELSEWHERE
|
|
ssmask(i1:i2,j1:j2) = 1._wp
|
|
END WHERE
|
|
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF (mbkt(ji,jj)==1) THEN
|
|
DO jk=1,jpk
|
|
e3t_0(ji,jj,jk) = e3t_1d(jk)
|
|
e3w_0(ji,jj,jk) = e3w_1d(jk)
|
|
gdept_0(ji,jj,jk) = gdept_1d(jk)
|
|
gdepw_0(ji,jj,jk) = gdepw_1d(jk)
|
|
END DO
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3tw_z_gen
|
|
|
|
|
|
SUBROUTINE update_e3w_z( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3w_z ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk=k1,k2
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssmask(ji,jj)/=0._wp).AND.(mbkt(ji,jj).GE.jk) ) THEN
|
|
tabres(ji,jj,jk) = e1e2t_frac(ji,jj) * e3w_0(ji,jj,jk) * e3t_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
ELSE
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( ssmask(ji,jj)==1._wp ) THEN
|
|
e3w_0(ji,jj,1) = tabres(ji,jj,1) / e3t_0(ji,jj,1)
|
|
gdept_0(ji,jj,1) = 0.5_wp * e3w_0(ji,jj,1)
|
|
ELSE
|
|
e3w_0(ji,jj,1) = e3w_1d(1)
|
|
gdept_0(ji,jj,1) = gdept_1d(1)
|
|
ENDIF
|
|
!
|
|
DO jk=2,jpkm1
|
|
IF ( (ssmask(ji,jj)==1._wp).AND.(mbkt(ji,jj).GE.jk) ) THEN
|
|
gdept_0(ji,jj,jk) = gdept_1d(jk-1) + tabres(ji,jj,jk) / e3t_0(ji,jj,jk)
|
|
ELSE
|
|
gdept_0(ji,jj,jk) = gdept_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
DO jk=2,jpk
|
|
IF ( (ssmask(ji,jj)==1._wp).AND.(mbkt(ji,jj).GE.jk) ) THEN
|
|
e3w_0(ji,jj,jk) = gdept_0(ji,jj,jk) - gdept_0(ji,jj,jk-1)
|
|
ELSE
|
|
e3w_0(ji,jj,jk) = e3w_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3w_z
|
|
|
|
|
|
SUBROUTINE update_e3uw_z( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3uw_z ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: gdepu
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk=k1,k2
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssumask(ji,jj)/=0._wp).AND.(mbku(ji,jj).GE.jk) ) THEN
|
|
tabres(ji,jj,jk) = e2u_frac(ji,jj) * e3uw_0(ji,jj,jk) * e3u_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
ELSE
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( ssumask(ji,jj)==1._wp ) THEN
|
|
e3uw_0(ji,jj,1) = tabres(ji,jj,1) / e3u_0(ji,jj,1)
|
|
gdepu(ji,jj,1) = 0.5_wp * e3uw_0(ji,jj,1)
|
|
ELSE
|
|
e3uw_0(ji,jj,1) = e3w_1d(1)
|
|
gdepu(ji,jj,1) = gdept_1d(1)
|
|
ENDIF
|
|
!
|
|
DO jk=2,jpkm1
|
|
IF ( (ssumask(ji,jj)==1._wp).AND.(mbku(ji,jj).GE.jk) ) THEN
|
|
gdepu(ji,jj,jk) = gdept_1d(jk-1) + tabres(ji,jj,jk) / e3u_0(ji,jj,jk)
|
|
ELSE
|
|
gdepu(ji,jj,jk) = gdept_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
DO jk=2,jpk
|
|
IF ( (ssumask(ji,jj)==1._wp).AND.(mbku(ji,jj).GE.jk) ) THEN
|
|
e3uw_0(ji,jj,jk) = gdepu(ji,jj,jk) - gdepu(ji,jj,jk-1)
|
|
ELSE
|
|
e3uw_0(ji,jj,jk) = e3w_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3uw_z
|
|
|
|
|
|
SUBROUTINE update_e3vw_z( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3vw_z ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp), DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
REAL(wp), DIMENSION(i1:i2,j1:j2,1:jpk) :: gdepv
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk=k1,k2
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssvmask(ji,jj)/=0._wp).AND.(mbkv(ji,jj).GE.jk) ) THEN
|
|
tabres(ji,jj,jk) = e1v_frac(ji,jj) * e3vw_0(ji,jj,jk) * e3v_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
ELSE
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( ssvmask(ji,jj)==1._wp ) THEN
|
|
e3vw_0(ji,jj,1) = tabres(ji,jj,1) / e3v_0(ji,jj,1)
|
|
gdepv(ji,jj,1) = 0.5_wp * e3vw_0(ji,jj,1)
|
|
ELSE
|
|
e3vw_0(ji,jj,1) = e3w_1d(1)
|
|
gdepv(ji,jj,1) = gdept_1d(1)
|
|
ENDIF
|
|
!
|
|
DO jk=2,jpkm1
|
|
IF ( (ssvmask(ji,jj)==1._wp).AND.(mbkv(ji,jj).GE.jk) ) THEN
|
|
gdepv(ji,jj,jk) = gdept_1d(jk-1) + tabres(ji,jj,jk) / e3v_0(ji,jj,jk)
|
|
ELSE
|
|
gdepv(ji,jj,jk) = gdept_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
DO jk=2,jpk
|
|
IF ( (ssvmask(ji,jj)==1._wp).AND.(mbkv(ji,jj).GE.jk) ) THEN
|
|
e3vw_0(ji,jj,jk) = gdepv(ji,jj,jk) - gdepv(ji,jj,jk-1)
|
|
ELSE
|
|
e3vw_0(ji,jj,jk) = e3w_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3vw_z
|
|
|
|
|
|
SUBROUTINE update_e3u_z( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3u_z ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk=k1,k2
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssumask(ji,jj) /=0._wp).AND.(mbku(ji,jj).GE.jk) ) THEN
|
|
tabres(ji,jj,jk) = e2u_frac(ji,jj) * e3u_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
ELSE
|
|
!
|
|
DO jk=1,jpkm1
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssumask(ji,jj)==1._wp).AND.(mbku(ji,jj).GE.jk) ) THEN
|
|
e3u_0(ji,jj,jk) = tabres(ji,jj,jk)
|
|
ELSE
|
|
e3u_0(ji,jj,jk) = e3t_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3u_z
|
|
|
|
|
|
SUBROUTINE update_e3v_z( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3v_z ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk=k1,k2
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssvmask(ji,jj) /=0._wp).AND.(mbkv(ji,jj).GE.jk) ) THEN
|
|
tabres(ji,jj,jk) = e1v_frac(ji,jj) * e3v_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
ELSE
|
|
!
|
|
DO jk=1,jpkm1
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssvmask(ji,jj)==1._wp).AND.(mbkv(ji,jj).GE.jk) ) THEN
|
|
e3v_0(ji,jj,jk) = tabres(ji,jj,jk)
|
|
ELSE
|
|
e3v_0(ji,jj,jk) = e3t_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3v_z
|
|
|
|
|
|
SUBROUTINE update_e3f_z( tabres, i1, i2, j1, j2, k1, k2, before )
|
|
!!---------------------------------------------
|
|
!! *** update_e3f_z ***
|
|
!!---------------------------------------------
|
|
INTEGER, INTENT(in) :: i1,i2,j1,j2,k1,k2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2,k1:k2), INTENT(inout) :: tabres
|
|
LOGICAL, INTENT(in) :: before
|
|
!!
|
|
INTEGER :: ji, jj, jk
|
|
!!---------------------------------------------
|
|
!
|
|
IF (before) THEN
|
|
DO jk=k1,k2
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssfmask(ji,jj) /=0._wp).AND.(mbkf(ji,jj).GE.jk) ) THEN
|
|
tabres(ji,jj,jk) = e3f_0(ji,jj,jk)
|
|
ELSE
|
|
tabres(ji,jj,jk) = 0._wp
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
ELSE
|
|
!
|
|
DO jk=1,jpkm1
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( (ssfmask(ji,jj)==1._wp).AND.(mbkf(ji,jj).GE.jk) ) THEN
|
|
e3f_0(ji,jj,jk) = tabres(ji,jj,jk)
|
|
ELSE
|
|
e3f_0(ji,jj,jk) = e3t_1d(jk)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
END DO
|
|
!
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e3f_z
|
|
|
|
|
|
SUBROUTINE update_e1e2t(tabres, i1, i2, j1, j2, n1, n2, before )
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_e1e2t ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2, n1, n2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2,n1:n2), INTENT(inout) :: tabres
|
|
LOGICAL , INTENT(in ) :: before
|
|
!!
|
|
INTEGER :: ji ,jj, jk
|
|
REAL(wp) :: ztemp
|
|
!!----------------------------------------------------------------------
|
|
|
|
IF (before) THEN
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF ( l_match_area ) THEN
|
|
tabres(ji,jj,1) = e1t(ji,jj)*e2t(ji,jj)*ssmask(ji,jj)
|
|
tabres(ji,jj,2) = e1t(ji,jj)*ssmask(ji,jj)
|
|
tabres(ji,jj,3) = e2t(ji,jj)*ssmask(ji,jj)
|
|
ELSE
|
|
tabres(ji,jj,1) = e1t(ji,jj)*e2t(ji,jj)
|
|
tabres(ji,jj,2) = e1t(ji,jj)
|
|
tabres(ji,jj,3) = e2t(ji,jj)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
tabres(i1:i2,j1:j2,1) = tabres(i1:i2,j1:j2,1)*Agrif_Rhox()*Agrif_Rhoy()
|
|
tabres(i1:i2,j1:j2,2) = tabres(i1:i2,j1:j2,2)*Agrif_Rhox()
|
|
tabres(i1:i2,j1:j2,3) = tabres(i1:i2,j1:j2,3)*Agrif_Rhoy()
|
|
ELSE
|
|
DO jj=j1,j2
|
|
DO ji=i1,i2
|
|
IF (tabres(ji,jj,1)/=0._wp) THEN
|
|
ztemp = SQRT(tabres(ji,jj,1) &
|
|
& /(tabres(ji,jj,2)*tabres(ji,jj,3)))
|
|
e1t(ji,jj) = tabres(ji,jj,2)*ztemp
|
|
e2t(ji,jj) = tabres(ji,jj,3)*ztemp
|
|
e1e2t(ji,jj) = tabres(ji,jj,1)
|
|
r1_e1e2t(ji,jj) = 1._wp / tabres(ji,jj,1)
|
|
r1_e1t(ji,jj) = 1._wp / (tabres(ji,jj,2)*ztemp)
|
|
r1_e2t(ji,jj) = 1._wp / (tabres(ji,jj,3)*ztemp)
|
|
ENDIF
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e1e2t
|
|
|
|
|
|
SUBROUTINE update_e2u(tabres, i1, i2, j1, j2, before )
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_e2u ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
|
|
LOGICAL , INTENT(in ) :: before
|
|
!!
|
|
INTEGER :: ji ,jj
|
|
!!----------------------------------------------------------------------
|
|
|
|
IF (before) THEN
|
|
IF ( l_match_area ) THEN
|
|
tabres(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * ssumask(i1:i2,j1:j2) * Agrif_Rhoy()
|
|
ELSE
|
|
tabres(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) * Agrif_Rhoy()
|
|
ENDIF
|
|
ELSE
|
|
DO ji=i1,i2
|
|
DO jj=j1,j2
|
|
IF (tabres(ji,jj)/=0._wp) THEN
|
|
e2u(ji,jj) = tabres(ji,jj)
|
|
r1_e2u(ji,jj) = 1._wp / tabres(ji,jj)
|
|
END IF
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e2u
|
|
|
|
|
|
SUBROUTINE update_e1v(tabres, i1, i2, j1, j2, before )
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE update_e1v ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
|
|
LOGICAL , INTENT(in ) :: before
|
|
!!
|
|
INTEGER :: ji ,jj
|
|
!!----------------------------------------------------------------------
|
|
|
|
IF (before) THEN
|
|
IF ( l_match_area ) THEN
|
|
tabres(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * ssvmask(i1:i2,j1:j2) * Agrif_Rhox()
|
|
ELSE
|
|
tabres(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) * Agrif_Rhox()
|
|
ENDIF
|
|
ELSE
|
|
DO ji=i1,i2
|
|
DO jj=j1,j2
|
|
IF (tabres(ji,jj)/=0._wp) THEN
|
|
e1v(ji,jj) = tabres(ji,jj)
|
|
r1_e1v(ji,jj) = 1._wp / tabres(ji,jj)
|
|
END IF
|
|
END DO
|
|
END DO
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE update_e1v
|
|
|
|
|
|
SUBROUTINE interp_e1e2t_frac(tabres, i1, i2, j1, j2, before )
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE interp_e1e2t_frac ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
|
|
LOGICAL , INTENT(in ) :: before
|
|
!!
|
|
!!----------------------------------------------------------------------
|
|
|
|
IF (before) THEN
|
|
tabres(i1:i2,j1:j2) = e1e2t(i1:i2,j1:j2)
|
|
ELSE
|
|
e1e2t_frac(i1:i2,j1:j2) = e1e2t(i1:i2,j1:j2) &
|
|
& / tabres(i1:i2,j1:j2) * Agrif_Rhox() * Agrif_Rhoy()
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE interp_e1e2t_frac
|
|
|
|
|
|
SUBROUTINE interp_e2u_frac(tabres, i1, i2, j1, j2, before )
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE interp_e2u_frac ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
|
|
LOGICAL , INTENT(in ) :: before
|
|
!!
|
|
!!----------------------------------------------------------------------
|
|
|
|
IF (before) THEN
|
|
tabres(i1:i2,j1:j2) = e2u(i1:i2,j1:j2)
|
|
ELSE
|
|
e2u_frac(i1:i2,j1:j2) = e2u(i1:i2,j1:j2) &
|
|
& / tabres(i1:i2,j1:j2) * Agrif_Rhoy()
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE interp_e2u_frac
|
|
|
|
|
|
SUBROUTINE interp_e1v_frac(tabres, i1, i2, j1, j2, before )
|
|
!
|
|
!!----------------------------------------------------------------------
|
|
!! *** ROUTINE interp_e1v_frac ***
|
|
!!----------------------------------------------------------------------
|
|
INTEGER , INTENT(in ) :: i1, i2, j1, j2
|
|
REAL(wp),DIMENSION(i1:i2,j1:j2), INTENT(inout) :: tabres
|
|
LOGICAL , INTENT(in ) :: before
|
|
!!
|
|
!!----------------------------------------------------------------------
|
|
|
|
IF (before) THEN
|
|
tabres(i1:i2,j1:j2) = e1v(i1:i2,j1:j2)
|
|
ELSE
|
|
e1v_frac(i1:i2,j1:j2) = e1v(i1:i2,j1:j2) &
|
|
& / tabres(i1:i2,j1:j2) * Agrif_Rhox()
|
|
ENDIF
|
|
!
|
|
END SUBROUTINE interp_e1v_frac
|
|
|
|
#else
|
|
SUBROUTINE agrif_update_all
|
|
END SUBROUTINE agrif_update_all
|
|
#endif
|
|
|
|
END MODULE agrif_dom_update
|