Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • nemo/nemo
  • sparonuz/nemo
  • hatfield/nemo
  • extdevs/nemo
4 results
Show changes
Hide whitespace changes
Inline Side-by-side
Showing
with 862 additions and 714 deletions
src/OCE/FLO/flodom.F90
View file @ 5bc9e5ca
......@@ -234,8 +234,8 @@ CONTAINS
zdyad = flo_dstnce( flxx(jfl), flyy(jfl), flxx(jfl), gphif(iimfl(jfl)-1,ijmfl(jfl)-1) )
! Translation of this distances (in meter) in indexes
zgifl(jfl)= (iimfl(jfl)-0.5) + zdxab/e1u(iimfl(jfl)-1,ijmfl(jfl)) + (mig(1)-1)
zgjfl(jfl)= (ijmfl(jfl)-0.5) + zdyad/e2v(iimfl(jfl),ijmfl(jfl)-1) + (mjg(1)-1)
zgifl(jfl)= (iimfl(jfl)-0.5) + zdxab/e1u(iimfl(jfl)-1,ijmfl(jfl)) + (mig(1,nn_hls)-1)
zgjfl(jfl)= (ijmfl(jfl)-0.5) + zdyad/e2v(iimfl(jfl),ijmfl(jfl)-1) + (mjg(1,nn_hls)-1)
zgkfl(jfl) = (( gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1,Kmm) - flzz(jfl) )* ikmfl(jfl)) &
& / ( gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl)+1,Kmm) &
& - gdepw(iimfl(jfl),ijmfl(jfl),ikmfl(jfl) ,Kmm) ) &
......
src/OCE/FLO/florst.F90
View file @ 5bc9e5ca
......@@ -97,10 +97,10 @@ CONTAINS
!
IF( lk_mpp ) THEN
DO jfl = 1, jpnfl
IF( (INT(tpifl(jfl)) >= mig(Nis0)) .AND. &
&(INT(tpifl(jfl)) <= mig(Nie0)) .AND. &
&(INT(tpjfl(jfl)) >= mjg(Njs0)) .AND. &
&(INT(tpjfl(jfl)) <= mjg(Nje0)) ) THEN
IF( (INT(tpifl(jfl)) >= mig(Nis0,nn_hls)) .AND. &
&(INT(tpifl(jfl)) <= mig(Nie0,nn_hls)) .AND. &
&(INT(tpjfl(jfl)) >= mjg(Njs0,nn_hls)) .AND. &
&(INT(tpjfl(jfl)) <= mjg(Nje0,nn_hls)) ) THEN
iperproc(narea) = iperproc(narea)+1
ENDIF
END DO
......
src/OCE/FLO/flowri.F90
View file @ 5bc9e5ca
......@@ -103,8 +103,8 @@ CONTAINS
IF( lk_mpp ) THEN
iafloc = mi1( iafl )
ibfloc = mj1( ibfl )
iafloc = mi1( iafl, nn_hls )
ibfloc = mj1( ibfl, nn_hls )
IF( Nis0 <= iafloc .AND. iafloc <= Nie0 .AND. &
& Njs0 <= ibfloc .AND. ibfloc <= Nje0 ) THEN
......
src/OCE/ICB/icbclv.F90
View file @ 5bc9e5ca
......@@ -132,8 +132,8 @@ CONTAINS
!
newpt%lon = glamt(ji,jj) ! at t-point (centre of the cell)
newpt%lat = gphit(ji,jj)
newpt%xi = REAL( mig(ji), wp ) - ( nn_hls - 1 )
newpt%yj = REAL( mjg(jj), wp ) - ( nn_hls - 1 )
newpt%xi = REAL( mig(ji,nn_hls), wp ) - ( nn_hls - 1 )
newpt%yj = REAL( mjg(jj,nn_hls), wp ) - ( nn_hls - 1 )
!
newpt%uvel = 0._wp ! initially at rest
newpt%vvel = 0._wp
......
src/OCE/ICB/icbdyn.F90
View file @ 5bc9e5ca
......@@ -197,10 +197,10 @@ CONTAINS
IF( ii == ii0 .AND. ij == ij0 ) RETURN ! berg remains in the same cell
!
! map into current processor
ii0 = mi1( ii0 )
ij0 = mj1( ij0 )
ii = mi1( ii )
ij = mj1( ij )
ii0 = mi1( ii0, nn_hls )
ij0 = mj1( ij0, nn_hls )
ii = mi1( ii , nn_hls )
ij = mj1( ij , nn_hls )
!
! assume icb is grounded if tmask(ii,ij,1) or tmask(ii,ij,ikb), depending of the option is not 0
IF ( ln_M2016 .AND. ln_icb_grd ) THEN
......
src/OCE/ICB/icbini.F90
View file @ 5bc9e5ca
......@@ -140,7 +140,7 @@ CONTAINS
DO_2D( 1, 1, 1, 1 )
src_calving_hflx(ji,jj) = narea
src_calving (ji,jj) = nicbpack * mjg(jj) + mig(ji)
src_calving (ji,jj) = nicbpack * mjg(jj,nn_hls) + mig(ji,nn_hls)
END_2D
CALL lbc_lnk( 'icbini', src_calving_hflx, 'T', 1._wp )
CALL lbc_lnk( 'icbini', src_calving , 'T', 1._wp )
......@@ -156,7 +156,7 @@ CONTAINS
i2 = INT( i3/nicbpack )
i1 = i3 - i2*nicbpack
i3 = INT( src_calving_hflx(ji,jj) )
IF( i1 == mig(ji) .AND. i3 == narea ) THEN
IF( i1 == mig(ji,nn_hls) .AND. i3 == narea ) THEN
IF( nicbdi < 0 ) THEN ; nicbdi = ji
ELSE ; nicbei = ji
ENDIF
......@@ -172,7 +172,7 @@ CONTAINS
i2 = INT( i3/nicbpack )
i1 = i3 - i2*nicbpack
i3 = INT( src_calving_hflx(ji,jj) )
IF( i2 == mjg(jj) .AND. i3 == narea ) THEN
IF( i2 == mjg(jj,nn_hls) .AND. i3 == narea ) THEN
IF( nicbdj < 0 ) THEN ; nicbdj = jj
ELSE ; nicbej = jj
ENDIF
......@@ -361,8 +361,8 @@ CONTAINS
rn_test_box(1) < glamt(ji,jj) .AND. glamt(ji,jj) < rn_test_box(2) .AND. &
rn_test_box(3) < gphit(ji,jj) .AND. gphit(ji,jj) < rn_test_box(4) ) THEN
localberg%mass_scaling = rn_mass_scaling(iberg)
localpt%xi = REAL( mig(ji) - (nn_hls-1), wp )
localpt%yj = REAL( mjg(jj) - (nn_hls-1), wp )
localpt%xi = REAL( mig(ji,nn_hls) - (nn_hls-1), wp )
localpt%yj = REAL( mjg(jj,nn_hls) - (nn_hls-1), wp )
CALL icb_utl_interp( localpt%xi, localpt%yj, plat=localpt%lat, plon=localpt%lon )
localpt%mass = rn_initial_mass (iberg)
localpt%thickness = rn_initial_thickness(iberg)
......
src/OCE/ICB/icblbc.F90
View file @ 5bc9e5ca
......@@ -90,9 +90,9 @@ CONTAINS
this => first_berg
DO WHILE( ASSOCIATED(this) )
pt => this%current_point
IF( pt%xi > REAL(mig(nicbei),wp) + 0.5_wp ) THEN
IF( pt%xi > REAL(mig(nicbei,nn_hls),wp) + 0.5_wp ) THEN
pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp
ELSE IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp ) THEN
ELSE IF( pt%xi < REAL(mig(nicbdi,nn_hls),wp) - 0.5_wp ) THEN
pt%xi = ricb_left + MOD(pt%xi, 1._wp )
ENDIF
this => this%next
......@@ -125,10 +125,10 @@ CONTAINS
DO WHILE( ASSOCIATED(this) )
pt => this%current_point
ijne = INT( pt%yj + 0.5 )
IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp ) THEN
IF( pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp ) THEN
!
iine = INT( pt%xi + 0.5 )
ipts = nicbfldpts (mi1(iine))
ipts = nicbfldpts (mi1(iine,nn_hls))
!
! moving across the cut line means both position and
! velocity must change
......@@ -228,7 +228,7 @@ CONTAINS
this => first_berg
DO WHILE (ASSOCIATED(this))
pt => this%current_point
IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) ) THEN
IF( ipe_E >= 0 .AND. pt%xi > REAL(mig(nicbei,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_e = ibergs_to_send_e + 1
......@@ -241,7 +241,7 @@ CONTAINS
! now pack it into buffer and delete from list
CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e)
CALL icb_utl_delete(first_berg, tmpberg)
ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) ) THEN
ELSE IF( ipe_W >= 0 .AND. pt%xi < REAL(mig(nicbdi,nn_hls),wp) - 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_w = ibergs_to_send_w + 1
......@@ -320,7 +320,7 @@ CONTAINS
this => first_berg
DO WHILE (ASSOCIATED(this))
pt => this%current_point
IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
IF( ipe_N >= 0 .AND. pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_n = ibergs_to_send_n + 1
......@@ -330,7 +330,7 @@ CONTAINS
ENDIF
CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n)
CALL icb_utl_delete(first_berg, tmpberg)
ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) ) THEN
ELSE IF( ipe_S >= 0 .AND. pt%yj < REAL(mjg(nicbdj,nn_hls),wp) - 0.5_wp - (nn_hls-1) ) THEN
tmpberg => this
this => this%next
ibergs_to_send_s = ibergs_to_send_s + 1
......@@ -441,10 +441,10 @@ CONTAINS
this => first_berg
DO WHILE (ASSOCIATED(this))
pt => this%current_point
IF( pt%xi < REAL(mig(nicbdi),wp) - 0.5_wp - (nn_hls-1) .OR. &
pt%xi > REAL(mig(nicbei),wp) + 0.5_wp - (nn_hls-1) .OR. &
pt%yj < REAL(mjg(nicbdj),wp) - 0.5_wp - (nn_hls-1) .OR. &
pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
IF( pt%xi < REAL(mig(nicbdi,nn_hls),wp) - 0.5_wp - (nn_hls-1) .OR. &
pt%xi > REAL(mig(nicbei,nn_hls),wp) + 0.5_wp - (nn_hls-1) .OR. &
pt%yj < REAL(mjg(nicbdj,nn_hls),wp) - 0.5_wp - (nn_hls-1) .OR. &
pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
i = i + 1
WRITE(numicb,*) 'berg lost in halo: ', this%number(:)
WRITE(numicb,*) ' ', nimpp, njmpp
......@@ -514,8 +514,8 @@ CONTAINS
DO WHILE (ASSOCIATED(this))
pt => this%current_point
iine = INT( pt%xi + 0.5 ) + (nn_hls-1)
iproc = nicbflddest(mi1(iine))
IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
iproc = nicbflddest(mi1(iine,nn_hls))
IF( pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
IF( iproc == ifldproc ) THEN
!
IF( iproc /= narea ) THEN
......@@ -593,9 +593,9 @@ CONTAINS
pt => this%current_point
iine = INT( pt%xi + 0.5 ) + (nn_hls-1)
ijne = INT( pt%yj + 0.5 ) + (nn_hls-1)
ipts = nicbfldpts (mi1(iine))
iproc = nicbflddest(mi1(iine))
IF( pt%yj > REAL(mjg(nicbej),wp) + 0.5_wp - (nn_hls-1) ) THEN
ipts = nicbfldpts (mi1(iine,nn_hls))
iproc = nicbflddest(mi1(iine,nn_hls))
IF( pt%yj > REAL(mjg(nicbej,nn_hls),wp) + 0.5_wp - (nn_hls-1) ) THEN
IF( iproc == ifldproc ) THEN
!
! moving across the cut line means both position and
......
src/OCE/ICB/icbrst.F90
View file @ 5bc9e5ca
......@@ -90,8 +90,8 @@ CONTAINS
ii = INT( localpt%xi + 0.5 ) + ( nn_hls-1 )
ij = INT( localpt%yj + 0.5 ) + ( nn_hls-1 )
! Only proceed if this iceberg is on the local processor (excluding halos).
IF ( ii >= mig(Nis0) .AND. ii <= mig(Nie0) .AND. &
& ij >= mjg(Njs0) .AND. ij <= mjg(Nje0) ) THEN
IF ( ii >= mig(Nis0,nn_hls) .AND. ii <= mig(Nie0,nn_hls) .AND. &
& ij >= mjg(Njs0,nn_hls) .AND. ij <= mjg(Nje0,nn_hls) ) THEN
CALL iom_get( ncid, jpdom_unknown, 'number', zdata(:) , ktime=jn, kstart=(/1/), kcount=(/nkounts/) )
localberg%number(:) = INT(zdata(:))
......@@ -244,16 +244,16 @@ CONTAINS
! global attributes
IF( lk_mpp ) THEN
! Set domain parameters (assume jpdom_local_full)
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig(Nis0,0), mjg(Njs0,0) /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig(Nie0,0), mjg(Nje0,0) /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) )
nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' )
ENDIF
IF (associated(first_berg)) then
......
src/OCE/ICB/icbthm.F90
View file @ 5bc9e5ca
......@@ -31,6 +31,8 @@ MODULE icbthm
PUBLIC icb_thm ! routine called in icbstp.F90 module
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: icbthm.F90 15088 2021-07-06 13:03:34Z acc $
......@@ -112,9 +114,9 @@ CONTAINS
zxi = pt%xi ! position in (i,j) referential
zyj = pt%yj
ii = INT( zxi + 0.5 ) ! T-cell of the berg
ii = mi1( ii + (nn_hls-1) )
ii = mi1( ii + (nn_hls-1), nn_hls )
ij = INT( zyj + 0.5 )
ij = mj1( ij + (nn_hls-1) )
ij = mj1( ij + (nn_hls-1), nn_hls )
zVol = zT * zW * zL
! Environment
......@@ -287,8 +289,8 @@ CONTAINS
! now use melt and associated heat flux in ocean (or not)
!
IF(.NOT. ln_passive_mode ) THEN
emp (:,:) = emp (:,:) - berg_grid%floating_melt(:,:)
qns (:,:) = qns (:,:) + berg_grid%calving_hflx (:,:)
emp (A2D(0)) = emp (A2D(0)) - berg_grid%floating_melt(A2D(0))
qns (:,:) = qns (:,:) + berg_grid%calving_hflx (A2D(0))
ENDIF
!
END SUBROUTINE icb_thm
......
src/OCE/ICB/icbutl.F90
View file @ 5bc9e5ca
......@@ -57,6 +57,7 @@ MODULE icbutl
PUBLIC icb_utl_heat ! routine called in icbdia module
!! * Substitutions
# include "do_loop_substitute.h90"
# include "domzgr_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
......@@ -101,7 +102,7 @@ CONTAINS
CALL lbc_lnk_icb( 'icbutl', ua_e , 'U', -1._wp, 1, 1 )
CALL lbc_lnk_icb( 'icbutl', va_e , 'V', -1._wp, 1, 1 )
#if defined key_si3
hi_e(1:jpi, 1:jpj) = hm_i (:,:)
hi_e(A2D(0)) = hm_i (:,:) ! clem: something is wrong here (hm_i defined in the interior only) but I do not what to do
ui_e(1:jpi, 1:jpj) = u_ice(:,:)
vi_e(1:jpi, 1:jpj) = v_ice(:,:)
!
......@@ -312,18 +313,18 @@ CONTAINS
!
IF (TRIM(cd_type) == 'T' ) THEN
ierr = 0
IF ( kii < mig( 1 ) ) THEN ; ierr = ierr + 1
ELSEIF( kii >= mig(jpi) ) THEN ; ierr = ierr + 1
IF ( kii < mig( 1 ,nn_hls) ) THEN ; ierr = ierr + 1
ELSEIF( kii >= mig(jpi,nn_hls) ) THEN ; ierr = ierr + 1
ENDIF
!
IF ( kij < mjg( 1 ) ) THEN ; ierr = ierr + 1
ELSEIF( kij >= mjg(jpj) ) THEN ; ierr = ierr + 1
IF ( kij < mjg( 1 ,nn_hls) ) THEN ; ierr = ierr + 1
ELSEIF( kij >= mjg(jpj,nn_hls) ) THEN ; ierr = ierr + 1
ENDIF
!
IF ( ierr > 0 ) THEN
WRITE(numicb,*) 'bottom left corner T point out of bound'
WRITE(numicb,*) pi, kii, mig( 1 ), mig(jpi)
WRITE(numicb,*) pj, kij, mjg( 1 ), mjg(jpj)
WRITE(numicb,*) pi, kii, mig( 1,nn_hls ), mig(jpi,nn_hls)
WRITE(numicb,*) pj, kij, mjg( 1,nn_hls ), mjg(jpj,nn_hls)
WRITE(numicb,*) pmsk
CALL FLUSH(numicb)
CALL ctl_stop('STOP','icb_utl_bilin_e: an icebergs coordinates is out of valid range (out of bound error).' , &
......@@ -335,13 +336,13 @@ CONTAINS
! find position in this processor. Prevent near edge problems (see #1389)
! (PM) will be useless if extra halo is used in NEMO
!
IF ( kii <= mig(1)-1 ) THEN ; kii = 0
ELSEIF( kii > mig(jpi) ) THEN ; kii = jpi
ELSE ; kii = mi1(kii)
IF ( kii <= mig(1,nn_hls)-1 ) THEN ; kii = 0
ELSEIF( kii > mig(jpi,nn_hls) ) THEN ; kii = jpi
ELSE ; kii = mi1(kii,nn_hls)
ENDIF
IF ( kij <= mjg(1)-1 ) THEN ; kij = 0
ELSEIF( kij > mjg(jpj) ) THEN ; kij = jpj
ELSE ; kij = mj1(kij)
IF ( kij <= mjg(1,nn_hls)-1 ) THEN ; kij = 0
ELSEIF( kij > mjg(jpj,nn_hls) ) THEN ; kij = jpj
ELSE ; kij = mj1(kij,nn_hls)
ENDIF
!
! define mask array
......@@ -462,8 +463,8 @@ CONTAINS
zj = pj - REAL(ij,wp)
! conversion to local domain (no need to do a sanity check already done in icbpos)
ii = mi1(ii) + (nn_hls-1)
ij = mj1(ij) + (nn_hls-1)
ii = mi1(ii,nn_hls) + (nn_hls-1)
ij = mj1(ij,nn_hls) + (nn_hls-1)
!
IF( 0.0_wp <= zi .AND. zi < 0.5_wp ) THEN
IF( 0.0_wp <= zj .AND. zj < 0.5_wp ) THEN ! NE quadrant
......
src/OCE/IOM/iom.F90
View file @ 5bc9e5ca
......@@ -1202,6 +1202,7 @@ CONTAINS
CHARACTER(LEN=1) :: cl_type ! local value of cd_type
LOGICAL :: ll_only3rd ! T => if kstart, kcount present then *only* use values for 3rd spatial dimension.
INTEGER :: inlev ! number of levels for 3D data
INTEGER :: ihls ! local value of the halo size
REAL(dp) :: gma, gmi
!---------------------------------------------------------------------
CHARACTER(LEN=lc) :: context
......@@ -1298,7 +1299,7 @@ CONTAINS
ENDIF
ELSE ! not a 1D array as pv_r1d requires jpdom_unknown
! we do not read the overlap and the extra-halos -> from Nis0 to Nie0 and from Njs0 to Nje0
IF( idom == jpdom_global ) istart(1:2) = (/ mig0(Nis0), mjg0(Njs0) /)
IF( idom == jpdom_global ) istart(1:2) = (/ mig(Nis0,0), mjg(Njs0,0) /)
icnt(1:2) = (/ Ni_0, Nj_0 /)
IF( PRESENT(pv_r3d) ) THEN
IF( idom == jpdom_auto_xy ) THEN
......@@ -1327,14 +1328,26 @@ CONTAINS
IF( irankpv == 1 ) ishape(1:1) = SHAPE(pv_r1d)
IF( irankpv == 2 ) ishape(1:2) = SHAPE(pv_r2d)
IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d)
ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2) ! index of the array to be read
ctmp1 = 'd'
ELSE
IF( irankpv == 2 ) THEN
ishape(1:2) = SHAPE(pv_r2d(Nis0:Nie0,Njs0:Nje0 )) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0)'
ENDIF
IF( irankpv == 3 ) THEN
ishape(1:3) = SHAPE(pv_r3d(Nis0:Nie0,Njs0:Nje0,:)) ; ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0,:)'
IF( irankpv == 2 ) ishape(1:2) = SHAPE(pv_r2d)
IF( irankpv == 3 ) ishape(1:3) = SHAPE(pv_r3d)
IF( ishape(1) == Ni_0 .AND. ishape(2) == Nj_0 ) THEN ! array with 0 halo
ix1 = 1 ; ix2 = Ni_0 ; iy1 = 1 ; iy2 = Nj_0 ! index of the array to be read
ctmp1 = 'd(:,:'
ELSEIF( ishape(1) == jpi .AND. ishape(2) == jpj ) THEN ! array with nn_hls halos
ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0 ! index of the array to be read
ctmp1 = 'd(Nis0:Nie0,Njs0:Nje0'
ELSEIF( ishape(1) == Ni_0+2 .AND. ishape(2) == Nj_0+2 ) THEN ! nn_hls = 2 and array with 1 halo
ix1 = 2 ; ix2 = Ni_0+1 ; iy1 = 2 ; iy2 = Nj_0+1 ! index of the array to be read
ctmp1 = 'd(2:Ni_0+1,2:Ni_0+1'
ELSE
CALL ctl_stop( 'iom_get_123d: should have been an impossible case...' )
ENDIF
ishape(1:2) = (/ Ni_0, Nj_0 /) ! update and force ishape to match the inner domain
IF( irankpv == 3 ) ctmp1 = TRIM(ctmp1)//',:'
ctmp1 = TRIM(ctmp1)//')'
ENDIF
DO jl = 1, irankpv
WRITE( ctmp2, FMT="(', ', i1,'): ', i5,' /= icnt(', i1,'):', i5)" ) jl, ishape(jl), jl, icnt(jl)
......@@ -1347,11 +1360,6 @@ CONTAINS
!-
IF( idvar > 0 .AND. istop == nstop ) THEN ! no additional errors until this point...
!
! find the right index of the array to be read
IF( idom /= jpdom_unknown ) THEN ; ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
ELSE ; ix1 = 1 ; ix2 = icnt(1) ; iy1 = 1 ; iy2 = icnt(2)
ENDIF
CALL iom_nf90_get( kiomid, idvar, inbdim, istart, icnt, ix1, ix2, iy1, iy2, pv_r1d, pv_r2d, pv_r3d )
IF( istop == nstop ) THEN ! no additional errors until this point...
......@@ -1359,13 +1367,15 @@ CONTAINS
cl_type = 'T'
IF( PRESENT(cd_type) ) cl_type = cd_type
zsgn = 1._wp
IF( PRESENT(psgn ) ) zsgn = psgn
!--- overlap areas and extra hallows (mpp)
IF( PRESENT(pv_r2d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN
CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill )
ELSEIF( PRESENT(pv_r3d) .AND. idom /= jpdom_unknown .AND. cl_type /= 'Z' ) THEN
CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill )
!--- halos and NP folding (NP folding to be done even if no halos)
IF( idom /= jpdom_unknown .AND. cl_type /= 'Z' .AND. ( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) ) THEN
zsgn = 1._wp
IF( PRESENT(psgn ) ) zsgn = psgn
IF( PRESENT(pv_r2d) ) THEN
CALL lbc_lnk( 'iom', pv_r2d, cl_type, zsgn, kfillmode = kfill )
ELSEIF( PRESENT(pv_r3d) ) THEN
CALL lbc_lnk( 'iom', pv_r3d, cl_type, zsgn, kfillmode = kfill )
ENDIF
ENDIF
!
ELSE
......@@ -2322,11 +2332,11 @@ CONTAINS
LOGICAL, INTENT(IN) :: ldxios, ldrxios
!!----------------------------------------------------------------------
!
CALL iom_set_domain_attr("grid_"//cdgrd, ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig0(Nis0)-1,jbegin=mjg0(Njs0)-1,ni=Ni_0,nj=Nj_0)
CALL iom_set_domain_attr("grid_"//cdgrd,ni_glo=Ni0glo,nj_glo=Nj0glo,ibegin=mig(Nis0,0)-1,jbegin=mjg(Njs0,0)-1,ni=Ni_0,nj=Nj_0)
CALL iom_set_domain_attr("grid_"//cdgrd, data_dim=2, data_ibegin = -nn_hls, data_ni=jpi, data_jbegin = -nn_hls, data_nj=jpj)
CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ni_glo = Ni0glo, nj_glo = Nj0glo, &
& ibegin = mig0(Nis0) - 1, jbegin = mjg0(Njs0) - 1, ni = Ni_0, nj = Nj_0)
& ibegin = mig(Nis0,0) - 1, jbegin = mjg(Njs0,0) - 1, ni = Ni_0, nj = Nj_0)
CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", data_dim=2, data_ibegin = 0, data_ni=Ni_0, data_jbegin = 0, data_nj=Nj_0)
IF( ln_tile ) THEN
......@@ -2336,14 +2346,14 @@ CONTAINS
idb(jn) = -nn_hls ! Tile data offset (halo size)
END DO
! Tile_[ij]begin are defined with respect to the processor data domain, so data_[ij]begin is added
CALL iom_set_domain_attr("grid_"//cdgrd, ntiles=nijtile, &
& tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, &
& tile_ibegin=ntsi_a(1:nijtile) - nn_hls - 1, tile_jbegin=ntsj_a(1:nijtile) - nn_hls - 1, &
& tile_ni=ini(:), tile_nj=inj(:), &
& tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), &
& tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:))
idb(:) = 0
CALL iom_set_domain_attr("grid_"//cdgrd//"_inner", ntiles=nijtile, &
& tile_ibegin=ntsi_a(1:nijtile) + idb(:) - 1, tile_jbegin=ntsj_a(1:nijtile) + idb(:) - 1, &
& tile_ibegin=ntsi_a(1:nijtile) - nn_hls - 1, tile_jbegin=ntsj_a(1:nijtile) - nn_hls - 1, &
& tile_ni=ini(:), tile_nj=inj(:), &
& tile_data_ibegin=idb(:), tile_data_jbegin=idb(:), &
& tile_data_ni=ini(:) - 2 * idb(:), tile_data_nj=inj(:) - 2 * idb(:))
......@@ -2452,8 +2462,8 @@ CONTAINS
!
! CALL dom_ngb( -168.53_wp, 65.03_wp, ix, iy, 'T' ) ! i-line that passes through Bering Strait: Reference latitude (used in plots)
CALL dom_ngb( 180.0_wp, 90.0_wp, ix, iy, 'T' ) ! i-line that passes near the North Pole : Reference latitude (used in plots)
CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig0(Nis0)-1, jbegin=mjg0(Njs0)-1, ni=Ni_0, nj=Nj_0)
CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin = -nn_hls, data_ni = jpi, data_jbegin = -nn_hls, data_nj = jpj)
CALL iom_set_domain_attr("gznl", ni_glo=Ni0glo, nj_glo=Nj0glo, ibegin=mig(Nis0,0)-1, jbegin=mjg(Njs0,0)-1, ni=Ni_0, nj=Nj_0)
CALL iom_set_domain_attr("gznl", data_dim=2, data_ibegin=0, data_ni=Ni_0, data_jbegin=0, data_nj=Nj_0)
CALL iom_set_domain_attr("gznl", lonvalue = real(zlon, dp), &
& latvalue = real(RESHAPE(plat(Nis0:Nie0, Njs0:Nje0),(/ Ni_0*Nj_0 /)),dp))
CALL iom_set_zoom_domain_attr("ptr", ibegin=ix-1, jbegin=0, ni=1, nj=Nj0glo)
......
src/OCE/IOM/iom_nf90.F90
View file @ 5bc9e5ca
......@@ -40,6 +40,8 @@ MODULE iom_nf90
MODULE PROCEDURE iom_nf90_rp0123d_dp
END INTERFACE
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: iom_nf90.F90 14433 2021-02-11 08:06:49Z smasson $
......@@ -144,16 +146,16 @@ CONTAINS
END SELECT
CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo)
! global attributes
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig(Nis0,0), mjg(Njs0,0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig(Nie0,0), mjg(Nje0,0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)
ELSE !* the file should be open for read mode so it must exist...
CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' )
ENDIF
......@@ -544,7 +546,7 @@ CONTAINS
INTEGER :: idvar ! variable id
INTEGER :: jd ! dimension loop counter
INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes
INTEGER, DIMENSION(4) :: idimsz ! dimensions size
INTEGER, DIMENSION(3) :: ishape ! dimensions size
INTEGER, DIMENSION(4) :: idimid ! dimensions id
CHARACTER(LEN=256) :: clinfo ! info character
INTEGER :: if90id ! nf90 file identifier
......@@ -627,11 +629,9 @@ CONTAINS
itype = NF90_DOUBLE
ENDIF
IF( PRESENT(pv_r0d) ) THEN
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, &
& iom_file(kiomid)%nvid(idvar) ), clinfo )
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, iom_file(kiomid)%nvid(idvar) ), clinfo )
ELSE
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), &
& iom_file(kiomid)%nvid(idvar) ), clinfo )
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), iom_file(kiomid)%nvid(idvar) ), clinfo )
ENDIF
lchunk = .false.
IF( snc4set%luse .AND. idims == 4 ) lchunk = .true.
......@@ -673,23 +673,13 @@ CONTAINS
ENDIF
! on what kind of domain must the data be written?
IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN
idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar)
IF( idimsz(1) == Ni_0 .AND. idimsz(2) == Nj_0 ) THEN
ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj
ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj
ELSE
CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' )
ENDIF
! write dimension variables if it is not already done
! =============
! trick: is defined to 0 => dimension variable are defined but not yet written
IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN ! time_counter = 0
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(ix1:ix2, iy1:iy2) ), clinfo )
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(ix1:ix2, iy1:iy2) ), clinfo )
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(A2D(0)) ), clinfo )
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(A2D(0)) ), clinfo )
SELECT CASE (iom_file(kiomid)%comp)
CASE ('OCE')
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo )
......@@ -704,6 +694,19 @@ CONTAINS
iom_file(kiomid)%dimsz(1, 4) = 1 ! so we don't enter this IF case any more...
IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done'
ENDIF
IF( PRESENT(pv_r2d) ) ishape(1:2) = SHAPE(pv_r2d)
IF( PRESENT(pv_r3d) ) ishape(1:3) = SHAPE(pv_r3d)
IF( ishape(1) == Ni_0 .AND. ishape(2) == Nj_0 ) THEN ! array with 0 halo
ix1 = 1 ; ix2 = Ni_0 ; iy1 = 1 ; iy2 = Nj_0
ELSEIF( ishape(1) == jpi .AND. ishape(2) == jpj ) THEN ! array with nn_hls halos
ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
ELSEIF( ishape(1) == Ni_0+2 .AND. ishape(2) == Nj_0+2 ) THEN ! nn_hls = 2 and array with 1 halo
ix1 = 2 ; ix2 = Ni_0+1 ; iy1 = 2 ; iy2 = Nj_0+1
ELSE
CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' )
ENDIF
ENDIF
! write the data
......@@ -712,7 +715,7 @@ CONTAINS
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r0d ), clinfo )
ELSEIF( PRESENT(pv_r1d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r1d(:) ), clinfo )
ELSEIF( PRESENT(pv_r2d) ) THEN
ELSEIF( PRESENT(pv_r2d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r2d(ix1:ix2,iy1:iy2) ), clinfo )
ELSEIF( PRESENT(pv_r3d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r3d(ix1:ix2,iy1:iy2,:) ), clinfo )
......
src/OCE/IOM/prtctl.F90
View file @ 5bc9e5ca
......@@ -119,11 +119,11 @@ CONTAINS
!! clinfo3 : additional information
!!----------------------------------------------------------------------
INTEGER , INTENT(in) :: ktab2d_1, ktab3d_1, ktab4d_1, ktab2d_2, ktab3d_2
REAL(2*wp), DIMENSION(A2D_T(ktab2d_1)) , INTENT(in), OPTIONAL :: tab2d_1
REAL(2*wp), DIMENSION(A2D_T(ktab3d_1),:) , INTENT(in), OPTIONAL :: tab3d_1
REAL(2*wp), DIMENSION(A2D_T(ktab4d_1),:,:), INTENT(in), OPTIONAL :: tab4d_1
REAL(2*wp), DIMENSION(A2D_T(ktab2d_2)) , INTENT(in), OPTIONAL :: tab2d_2
REAL(2*wp), DIMENSION(A2D_T(ktab3d_2),:) , INTENT(in), OPTIONAL :: tab3d_2
REAL(2*wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_1
REAL(2*wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_1
REAL(2*wp), DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: tab4d_1
REAL(2*wp), DIMENSION(:,:) , INTENT(in), OPTIONAL :: tab2d_2
REAL(2*wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: tab3d_2
REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask1
REAL(wp), DIMENSION(:,:,:) , INTENT(in), OPTIONAL :: mask2
CHARACTER(len=*), DIMENSION(:) , INTENT(in), OPTIONAL :: clinfo ! information about the tab3d array
......@@ -135,11 +135,20 @@ CONTAINS
CHARACTER(len=30) :: cl1, cl2
CHARACTER(len=6) :: clfmt
INTEGER :: jn, jl, kdir
INTEGER :: iis, iie, jjs, jje
INTEGER :: ipi1, ipi2, ipim1, ipim2
INTEGER :: isht1, isht2, ishtm1, ishtm2
INTEGER :: ii1s, ii1e, jj1s, jj1e
INTEGER :: ii2s, ii2e, jj2s, jj2e
INTEGER :: iim1s, iim1e, jjm1s, jjm1e
INTEGER :: iim2s, iim2e, jjm2s, jjm2e
INTEGER :: itra, inum
REAL(2*wp) :: zsum1, zsum2, zvctl1, zvctl2
!!----------------------------------------------------------------------
!
IF( ( ktab2d_1 * ktab3d_1 * ktab4d_1 * ktab2d_2 * ktab3d_2 ) /= 0 ) THEN
CALL ctl_stop( 'prt_ctl is a debugging toll that should not be used with tiles' )
ENDIF
! Arrays, scalars initialization
cl1 = ''
cl2 = ''
......@@ -154,22 +163,55 @@ CONTAINS
IF( wp == sp ) clfmt = 'D23.16' ! 16 significant numbers
IF( wp == dp ) clfmt = 'D41.34' ! 34 significant numbers
IF( PRESENT(tab2d_1) ) ipi1 = SIZE(tab2d_1,1)
IF( PRESENT(tab3d_1) ) ipi1 = SIZE(tab3d_1,1)
IF( PRESENT(tab4d_1) ) ipi1 = SIZE(tab4d_1,1)
isht1 = ( jpi - ipi1 ) / 2
ipi2 = -1 ! default definition
IF( PRESENT(tab2d_2) ) ipi2 = SIZE(tab2d_2,1)
IF( PRESENT(tab3d_2) ) ipi2 = SIZE(tab3d_2,1)
isht2 = ( jpi - ipi2 ) / 2
ipim1 = -1 ! default definition
IF( PRESENT(mask1) ) ipim1 = SIZE(mask1,1)
ishtm1 = ( jpi - ipim1 ) / 2
ipim2 = -1 ! default definition
IF( PRESENT(mask2) ) ipim2 = SIZE(mask2,1)
ishtm2 = ( jpi - ipim2 ) / 2
! Loop over each sub-domain, i.e. the total number of processors ijsplt
DO jl = 1, SIZE(nall_ictls)
ii1s = MAX( nall_ictls(jl), Nis0 ) - isht1
ii1e = MIN( nall_ictle(jl), Nie0 ) - isht1
jj1s = MAX( nall_jctls(jl), Njs0 ) - isht1
jj1e = MIN( nall_jctle(jl), Nje0 ) - isht1
! define shoter names...
iis = MAX( nall_ictls(jl), ntsi )
iie = MIN( nall_ictle(jl), ntei )
jjs = MAX( nall_jctls(jl), ntsj )
jje = MIN( nall_jctle(jl), ntej )
ii2s = MAX( nall_ictls(jl), Nis0 ) - isht2
ii2e = MIN( nall_ictle(jl), Nie0 ) - isht2
jj2s = MAX( nall_jctls(jl), Njs0 ) - isht2
jj2e = MIN( nall_jctle(jl), Nje0 ) - isht2
iim1s = MAX( nall_ictls(jl), Nis0 ) - ishtm1
iim1e = MIN( nall_ictle(jl), Nie0 ) - ishtm1
jjm1s = MAX( nall_jctls(jl), Njs0 ) - ishtm1
jjm1e = MIN( nall_jctle(jl), Nje0 ) - ishtm1
iim2s = MAX( nall_ictls(jl), Nis0 ) - ishtm2
iim2e = MIN( nall_ictle(jl), Nie0 ) - ishtm2
jjm2s = MAX( nall_jctls(jl), Njs0 ) - ishtm2
jjm2e = MIN( nall_jctle(jl), Nje0 ) - ishtm2
IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl)
ELSE ; inum = numprt_oce(jl)
ENDIF
! Compute the sum control only where the tile domain and control print area overlap
IF( iie >= iis .AND. jje >= jjs ) THEN
IF( ii1e >= ii1s .AND. jj1e >= jj1s ) THEN
DO jn = 1, itra
IF( PRESENT(clinfo3) ) THEN
......@@ -188,32 +230,42 @@ CONTAINS
! 2D arrays
IF( PRESENT(tab2d_1) ) THEN
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) )
ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) )
IF( PRESENT(mask1) ) THEN
zsum1 = SUM( tab2d_1(ii1s:ii1e,jj1s:jj1e) * mask1(iim1s:iim1e,jjm1s:jjm1e,1) )
ELSE
zsum1 = SUM( tab2d_1(ii1s:ii1e,jj1s:jj1e) )
ENDIF
ENDIF
IF( PRESENT(tab2d_2) ) THEN
IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) )
ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) )
IF( PRESENT(mask2) ) THEN
zsum2 = SUM( tab2d_2(ii2s:ii2e,jj2s:jj2e) * mask2(iim2s:iim2e,jjm2s:jjm2e,1) )
ELSE
zsum2 = SUM( tab2d_2(ii2s:ii2e,jj2s:jj2e) )
ENDIF
ENDIF
! 3D arrays
IF( PRESENT(tab3d_1) ) THEN
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) )
ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) )
IF( PRESENT(mask1) ) THEN
zsum1 = SUM( tab3d_1(ii1s:ii1e,jj1s:jj1e,1:kdir) * mask1(iim1s:iim1e,jjm1s:jjm1e,1:kdir) )
ELSE
zsum1 = SUM( tab3d_1(ii1s:ii1e,jj1s:jj1e,1:kdir) )
ENDIF
ENDIF
IF( PRESENT(tab3d_2) ) THEN
IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) )
ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) )
IF( PRESENT(mask2) ) THEN
zsum2 = SUM( tab3d_2(ii2s:ii2e,jj2s:jj2e,1:kdir) * mask2(iim2s:iim2e,jjm2s:jjm2e,1:kdir) )
ELSE
zsum2 = SUM( tab3d_2(ii2s:ii2e,jj2s:jj2e,1:kdir) )
ENDIF
ENDIF
! 4D arrays
IF( PRESENT(tab4d_1) ) THEN
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) )
ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) )
IF( PRESENT(mask1) ) THEN
zsum1 = SUM( tab4d_1(ii1s:ii1e,jj1s:jj1e,1:kdir,jn) * mask1(iim1s:iim1e,jjm1s:jjm1e,1:kdir) )
ELSE
zsum1 = SUM( tab4d_1(ii1s:ii1e,jj1s:jj1e,1:kdir,jn) )
ENDIF
ENDIF
......@@ -460,22 +512,22 @@ CONTAINS
!
idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg
idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use?
idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) )
idg2 = MAXVAL( (/ mig(nall_ictls(jl),0), mig(nall_ictle(jl),0), mjg(nall_jctls(jl),0), mjg(nall_jctle(jl),0) /) )
idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use?
WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2
WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2
WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") &
& 18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13)
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg(nall_jctle(jl),0), ') ', ('-', ji=1,13)
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ', &
& ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') '
WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig(nall_ictls(jl),0), ') ', &
& ' ictle = ', nall_ictle(jl), ' (', mig(nall_ictle(jl),0), ') '
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13)
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg(nall_jctls(jl),0), ') ', ('-', ji=1,13)
WRITE(inum,*)
WRITE(inum,*)
!
......
src/OCE/ISF/isfcpl.F90
View file @ 5bc9e5ca
......@@ -736,7 +736,8 @@ CONTAINS
END IF
!
! update isfpts structure
sisfpts(kpts) = isfcons(mig(ki), mjg(kj), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, glamt(ki,kj), gphit(ki,kj), ifind )
sisfpts(kpts) = isfcons(mig(ki,nn_hls), mjg(kj,nn_hls), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, &
& glamt(ki,kj), gphit(ki,kj), ifind )
!
END SUBROUTINE update_isfpts
!
......@@ -761,8 +762,8 @@ CONTAINS
IF ( kfind == 1 ) CALL dom_ngb( plon, plat, iig, ijg,'T', kk)
!
! fill the correction array
DO jj = mj0(ijg),mj1(ijg)
DO ji = mi0(iig),mi1(iig)
DO jj = mj0(ijg,nn_hls),mj1(ijg,nn_hls)
DO ji = mi0(iig,nn_hls),mi1(iig,nn_hls)
! correct the vol_flx and corresponding heat/salt flx in the closest cell
risfcpl_cons_vol(ji,jj,kk) = risfcpl_cons_vol(ji,jj,kk ) + pvolinc
risfcpl_cons_tsc(ji,jj,kk,jp_sal) = risfcpl_cons_tsc(ji,jj,kk,jp_sal) + psalinc
......
src/OCE/LBC/lbc_lnk_call_generic.h90
View file @ 5bc9e5ca
......@@ -27,7 +27,7 @@
& , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 &
& , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 &
& , pt29, cdna29, psgn29, pt30, cdna30, psgn30 &
& , kfillmode, pfillval, khls, lsend, lrecv, ld4only )
& , kfillmode, pfillval, lsend, lrecv, ld4only )
!!---------------------------------------------------------------------
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
REAL(PRECISION), DIMENSION(DIMS) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied
......@@ -50,7 +50,6 @@
& psgn30
INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out
LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
!!
......@@ -96,15 +95,11 @@
IF( PRESENT(psgn29) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
IF( PRESENT(psgn30) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
!
#if ! defined key_mpi2
IF( nn_comm == 1 ) THEN
CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
ELSE
CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
ENDIF
#else
CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
#endif
!
END SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION
......
src/OCE/LBC/lbc_lnk_neicoll_generic.h90
View file @ 5bc9e5ca
SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
......@@ -7,265 +7,311 @@
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
!
INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices
INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ip0i, ip1i, im0i, im1i
INTEGER :: ip0j, ip1j, im0j, im1j
INTEGER :: ishti, ishtj, ishti2, ishtj2
INTEGER :: iszS, iszR
INTEGER :: inbS, inbR, iszS, iszR
INTEGER :: ierr
INTEGER :: ihls, idx
INTEGER :: ihls, ihlsmax, idx
INTEGER :: impi_nc
INTEGER :: ifill_nfd
INTEGER, DIMENSION(4) :: iwewe, issnn
INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj
INTEGER, DIMENSION(8) :: ifill, iszall
INTEGER, DIMENSION(8) :: jnf
INTEGER, DIMENSION( kfld) :: ipi, ipj, ipk, ipl ! dimension of the input array
INTEGER, DIMENSION(8,kfld) :: ifill
INTEGER, DIMENSION(8,kfld) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8,kfld) :: isizej, ishtSj, ishtRj, ishtPj
INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received
INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays
LOGICAL, DIMENSION(8) :: llsend, llrecv
REAL(PRECISION) :: zland
LOGICAL, DIMENSION(8,kfld) :: llsend, llrecv
LOGICAL :: ll4only ! default: 8 neighbourgs
REAL(PRECISION) :: zland
!!----------------------------------------------------------------------
!
! ----------------------------------------- !
! 1. local variables initialization !
! ----------------------------------------- !
!
ipi = SIZE(ptab(1)%pt4d,1)
ipj = SIZE(ptab(1)%pt4d,2)
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
!
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
!
! take care of optional parameters
!
ihls = nn_hls ! default definition
IF( PRESENT( khls ) ) ihls = khls
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipi /= Ni_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipj /= Nj_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
!
ll4only = .FALSE. ! default definition
IF( PRESENT(ld4only) ) ll4only = ld4only
!
impi_nc = mpi_nc_com8(ihls) ! default
IF( ll4only ) impi_nc = mpi_nc_com4(ihls)
!
zland = 0._wp ! land filling value: zero by default
IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented')
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners
llrecv(:) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners
ENDIF
ifill_nfd = jpfillcst ! default definition
IF( PRESENT(kfillmode) ) ifill_nfd = kfillmode
!
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 8
IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined
ELSE ; ifill(jn) = jpfillcst ! constant value (zland)
ENDIF
END DO
! take care of "indirect self-periodicity" for the corners
DO jn = 5, 8
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later
END DO
! north fold treatment
IF( l_IdoNFold ) THEN
ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo
ENDIF
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
ihlsmax = 0
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
! ! ________________________
ip0i = 0 ! im0j = inner |__|________________|__|
ip1i = ihls ! im1j = inner - halo | |__|__________|__| |
im1i = ipi-2*ihls ! | | | | | |
im0i = ipi - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! | |__|__________|__| |
im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj - ihls ! ip0j = 0 |__|________________|__|
! ! ip0i ip1i im1i im0i
DO jf = 1, kfld
!
ipi(jf) = SIZE(ptab(jf)%pt4d,1)
ipj(jf) = SIZE(ptab(jf)%pt4d,2)
ipk(jf) = SIZE(ptab(jf)%pt4d,3)
ipl(jf) = SIZE(ptab(jf)%pt4d,4)
ihls = ( ipi(jf) - Ni_0 ) / 2
ihlsmax = MAX(ihls, ihlsmax)
!
IF( numcom == -1 ) THEN ! test input array shape. Use numcom to do these tests only at the beginning of the run
IF( MOD( ipi(jf) - Ni_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong i-size: ', ipi(jf), Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( MOD( ipj(jf) - Nj_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong j-size: ', ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ( ipj(jf) - Nj_0 ) / 2 /= ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array as wong i and j-size: ', &
& ipi(jf), Ni_0, ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but for the ', jf,'th input array, ', ihls, ' > n_hlsmax = ', &
& n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
ENDIF
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented')
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:,jf) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8,jf) = .FALSE. ! exclude corners
llrecv(:,jf) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8,jf) = .FALSE. ! exclude corners
ENDIF
!
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 8
IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn,jf) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn,jf) = kfillmode ! localy defined
ELSEIF( ihls == 0 ) THEN ; ifill(jn,jf) = jpfillnothing ! do nothing
ELSE ; ifill(jn,jf) = jpfillcst ! constant value (zland)
ENDIF
END DO
! take care of "indirect self-periodicity" for the corners
DO jn = 5, 8
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn,jf) = jpfillnothing ! no bi-perio but ew-perio: do corners later
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn,jf) = jpfillnothing ! no bi-perio but ns-perio: do corners later
END DO
! north fold treatment
IF( l_IdoNFold ) ifill(jpno,jf) = jpfillnothing ! we do north fold -> do nothing for northern halo
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
! ! ________________________
ip0i = 0 ! im0j = inner |__|________________|__|
ip1i = ihls ! im1j = inner - halo | |__|__________|__| |
im1i = ipi(jf)-2*ihls ! | | | | | |
im0i = ipi(jf) - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! | |__|__________|__| |
im1j = ipj(jf)-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj(jf) - ihls ! ip0j = 0 |__|________________|__|
! ! ip0i ip1i im1i im0i
!
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4,jf) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8,jf) = ihls ! i- count
isizej(1:4,jf) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8,jf) = ihls ! j- count
ishtSi(1:4,jf) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8,jf) = ishtSi( iwewe,jf ) ! i- shift send data
ishtSj(1:4,jf) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8,jf) = ishtSj( issnn,jf ) ! j- shift send data
ishtRi(1:4,jf) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8,jf) = ishtRi( iwewe,jf ) ! i- shift recv data
ishtRj(1:4,jf) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8,jf) = ishtRj( issnn,jf ) ! j- shift recv data
ishtPi(1:4,jf) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8,jf) = ishtPi( iwewe,jf ) ! i- shift perio data
ishtPj(1:4,jf) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8,jf) = ishtPj( issnn,jf ) ! j- shift perio data
!
END DO ! jf
!
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count
isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count
ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data
ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data
ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location
ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location
ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity
ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, SUM(ipk(:))/kfld, SUM(ipl(:))/kfld, kfld, ld_lbc = .TRUE. )
!
! -------------------------------- !
! 2. Prepare MPI exchanges !
! -------------------------------- !
!
! Allocate local temporary arrays to be sent/received.
iszS = COUNT( llsend )
iszR = COUNT( llrecv )
ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0
iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false.
iRcnt(:) = PACK( iszall, mask = llrecv )
IF( iszS > 0 ) iSdpl(1) = 0
DO jn = 2,iszS
inbS = COUNT( ANY(llsend,dim=2) ) ! number of snd neighbourgs
inbR = COUNT( ANY(llrecv,dim=2) ) ! number of rcv neighbourgs
ALLOCATE( iScnt(inbS), iRcnt(inbR), iSdpl(inbS), iRdpl(inbR) ) ! ok if iszS = 0 or iszR = 0
iScnt(:) = 0 ; idx = 0
DO jn = 1, 8
IF( COUNT( llsend(jn,:) ) > 0 ) THEN ! we send something to neighbourg jn
idx = idx + 1
DO jf = 1, kfld
IF( llsend(jn,jf) ) iScnt(idx) = iScnt(idx) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
END DO
ENDIF
END DO
IF( inbS > 0 ) iSdpl(1) = 0
DO jn = 2,inbS
iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype
END DO
IF( iszR > 0 ) iRdpl(1) = 0
DO jn = 2,iszR
iRcnt(:) = 0 ; idx = 0
DO jn = 1, 8
IF( COUNT( llrecv(jn,:) ) > 0 ) THEN ! we get something from neighbourg jn
idx = idx + 1
DO jf = 1, kfld
IF( llrecv(jn,jf) ) iRcnt(idx) = iRcnt(idx) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
END DO
ENDIF
END DO
IF( inbR > 0 ) iRdpl(1) = 0
DO jn = 2,inbR
iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype
END DO
!
! Allocate buffer arrays to be sent/received if needed
iszS = SUM(iszall, mask = llsend) ! send buffer size
iszS = SUM(iScnt) ! send buffer size
IF( ALLOCATED(BUFFSND) ) THEN
CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! needed only if PREVIOUS call was using nn_comm = 1 (for tests)
IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) )
iszR = SUM(iszall, mask = llrecv) ! recv buffer size
iszR = SUM(iRcnt) ! recv buffer size
IF( ALLOCATED(BUFFRCV) ) THEN
IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) )
!
! fill sending buffer with ptab(jf)%pt4d
idx = 1
idx = 0
DO jn = 1, 8
IF( llsend(jn) ) THEN
ishti = ishtSi(jn)
ishtj = ishtSj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
idx = idx + 1
END DO ; END DO ; END DO ; END DO ; END DO
ENDIF
DO jf = 1, kfld
IF( llsend(jn,jf) ) THEN
ishti = ishtSi(jn,jf)
ishtj = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
idx = idx + 1
BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
ENDIF
END DO
END DO
!
! ------------------------------------------------ !
! 3. Do all MPI exchanges in 1 unique call !
! ------------------------------------------------ !
!
IF( ln_timing ) CALL tic_tac(.TRUE.)
CALL mpi_neighbor_alltoallv (BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, ierr)
IF( ln_timing ) CALL tic_tac(.FALSE.)
IF( ihlsmax > 0 ) THEN
impi_nc = mpi_nc_com8( ihlsmax )
IF( ll4only ) impi_nc = mpi_nc_com4( ihlsmax )
#if ! defined key_mpi2
IF( ln_timing ) CALL tic_tac( .TRUE.)
CALL mpi_Ineighbor_alltoallv(BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, nreq_nei, ierr)
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
ENDIF
nreq_p2p = MPI_REQUEST_NULL ! needed only if we switch between nn_comm = 1 and 2 (for tests)
!
! ------------------------- !
! 4. Fill all halos !
! ------------------------- !
! --------------------------------- !
! 4. Fill all Non-MPI halos !
! --------------------------------- !
!
idx = 1
! MPI3 bug fix when domain decomposition has 2 columns/rows
IF (jpni .eq. 2) THEN
IF (jpnj .eq. 2) THEN
jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /)
ELSE
jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /)
ENDIF
ELSE
IF (jpnj .eq. 2) THEN
jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /)
ELSE
jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /)
ENDIF
ENDIF
! do it first to give (potentially) more time for the communications
DO jn = 1, 8
ishti = ishtRi(jnf(jn))
ishtj = ishtRj(jnf(jn))
SELECT CASE ( ifill(jnf(jn)) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! fill with data received by MPI
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx)
idx = idx + 1
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use periodicity
ishti2 = ishtPi(jnf(jn))
ishtj2 = ishtPj(jnf(jn))
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jnf(jn))
ishtj2 = ishtSj(jnf(jn))
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
DO jf = 1, kfld
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
SELECT CASE ( ifill(jn,jf) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! no it later
CASE ( jpfillperio ) ! use periodicity
ishti2 = ishtPi(jn,jf)
ishtj2 = ishtPj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jn,jf)
ishtj2 = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO
END SELECT
END DO
END DO
!
! ----------------------------- !
! 5. Fill all MPI halos !
! ----------------------------- !
!
CALL mpi_wait( nreq_nei, MPI_STATUS_IGNORE, ierr )
!
idx = 0
DO jn = 1, 8
DO jf = 1, kfld
IF( ifill(jn,jf) == jpfillmpi ) THEN ! fill with data received by MPI
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
idx = idx + 1
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx)
END DO; END DO ; END DO ; END DO
ENDIF
END DO
END DO
DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl )
IF( iszS > jpi*jpj ) DEALLOCATE(BUFFSND) ! blocking Send -> can directly deallocate
IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking Recv -> can directly deallocate
! potential "indirect self-periodicity" for the corners
!
! ---------------------------------------------------------------- !
! 6. Potential "indirect self-periodicity" for the corners !
! ---------------------------------------------------------------- !
!
DO jn = 5, 8
IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition
ishti = ishtRi(jn)
ishtj = ishtRj(jn)
ishti2 = ishtPi(jn) ! use i- shift periodicity
ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
DO jf = 1, kfld
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
ishti2 = ishtPi(jn,jf) ! use i- shift periodicity
ishtj2 = ishtRj(jn,jf) ! use j- shift recv location: use ew-perio -> ok as filling of the so and no halos now done
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
END DO
ENDIF
IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition
ishti = ishtRi(jn)
ishtj = ishtRj(jn)
ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done
ishtj2 = ishtPj(jn) ! use j- shift periodicity
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
DO jf = 1, kfld
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
ishti2 = ishtRi(jn,jf) ! use i- shift recv location: use ns-perio -> ok as filling of the we and ea halos now done
ishtj2 = ishtPj(jn,jf) ! use j- shift periodicity
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
END DO
ENDIF
END DO
!
! ------------------------------- !
! 5. north fold treatment !
! 7. north fold treatment !
! ------------------------------- !
!
IF( l_IdoNFold ) THEN
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , kfld ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, kfld ) ! mpi NFold
ENDIF
ENDIF
!
......
src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
View file @ 5bc9e5ca
#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL
SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL_nonMPI && ! defined BLOCK_FILL_MPI_RECV
SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
......@@ -8,161 +8,185 @@
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
!
INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices
INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ip0i, ip1i, im0i, im1i
INTEGER :: ip0j, ip1j, im0j, im1j
INTEGER :: ishti, ishtj, ishti2, ishtj2
INTEGER :: ifill_nfd, icomm, ierr
INTEGER :: ihls, idxs, idxr, iszS, iszR
INTEGER :: ihls, iisz
INTEGER :: idxs, idxr, iszS, iszR
INTEGER, DIMENSION(4) :: iwewe, issnn
INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj
INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR
INTEGER, DIMENSION(8) :: ireq ! mpi_request id
INTEGER, DIMENSION(8) :: ibufszS, ibufszR, ishtS, ishtR
INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id
REAL(PRECISION) :: zland
LOGICAL, DIMENSION(8) :: llsend, llrecv
INTEGER, DIMENSION( kfld) :: ipi, ipj, ipk, ipl ! dimension of the input array
INTEGER, DIMENSION(8,kfld) :: ifill
INTEGER, DIMENSION(8,kfld) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8,kfld) :: isizej, ishtSj, ishtRj, ishtPj
LOGICAL, DIMENSION(8,kfld) :: llsend, llrecv
LOGICAL :: ll4only ! default: 8 neighbourgs
REAL(PRECISION) :: zland
!!----------------------------------------------------------------------
!
! ----------------------------------------- !
! 1. local variables initialization !
! ----------------------------------------- !
!
ipi = SIZE(ptab(1)%pt4d,1)
ipj = SIZE(ptab(1)%pt4d,2)
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
!
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
!
idxs = 1 ! initalize index for send buffer
idxr = 1 ! initalize index for recv buffer
icomm = mpi_comm_oce ! shorter name
!
! take care of optional parameters
!
ihls = nn_hls ! default definition
IF( PRESENT( khls ) ) ihls = khls
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipi /= Ni_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipj /= Nj_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
!
ll4only = .FALSE. ! default definition
IF( PRESENT(ld4only) ) ll4only = ld4only
ll4only = .FALSE. ! default definition
IF( PRESENT( ld4only ) ) ll4only = ld4only
!
zland = 0._wp ! land filling value: zero by default
IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
IF( PRESENT( pfillval) ) zland = pfillval ! set land value
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
llsend(:) = lsend(:) ; llrecv(:) = lrecv(:)
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners
llrecv(:) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners
ENDIF
ifill_nfd = jpfillcst ! default definition
IF( PRESENT(kfillmode) ) ifill_nfd = kfillmode
!
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 4
IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined
ELSE ; ifill(jn) = jpfillcst ! constant value (zland)
DO jf = 1, kfld
!
ipi(jf) = SIZE(ptab(jf)%pt4d,1)
ipj(jf) = SIZE(ptab(jf)%pt4d,2)
ipk(jf) = SIZE(ptab(jf)%pt4d,3)
ipl(jf) = SIZE(ptab(jf)%pt4d,4)
ihls = ( ipi(jf) - Ni_0 ) / 2
!
IF( numcom == -1 ) THEN ! test input array shape. Use numcom to do these tests only at the beginning of the run
IF( MOD( ipi(jf) - Ni_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong i-size: ', ipi(jf), Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( MOD( ipj(jf) - Nj_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong j-size: ', ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ( ipj(jf) - Nj_0 ) / 2 /= ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array as wong i and j-size: ', &
& ipi(jf), Ni_0, ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but for the ', jf,'th input array, ', ihls, ' > n_hlsmax = ', &
& n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
ENDIF
END DO
DO jn = 5, 8
IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
ELSE ; ifill(jn) = jpfillnothing! do nothing
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
llsend(:,jf) = lsend(:) ; llrecv(:,jf) = lrecv(:)
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:,jf) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8,jf) = .FALSE. ! exclude corners
llrecv(:,jf) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8,jf) = .FALSE. ! exclude corners
ENDIF
END DO
!
! north fold treatment
IF( l_IdoNFold ) THEN
ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo
ENDIF
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
! ! ________________________
ip0i = 0 ! im0j = inner |__|__|__________|__|__|
ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__|
im1i = ipi-2*ihls ! | | | | | |
im0i = ipi - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! |__|__|__________|__|__|
im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__|
! ! ip0i ip1i im1i im0i
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 4 ! 4 sides
IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn,jf) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn,jf) = kfillmode ! localy defined
ELSEIF( ihls == 0 ) THEN ; ifill(jn,jf) = jpfillnothing ! do nothing
ELSE ; ifill(jn,jf) = jpfillcst ! constant value (zland)
ENDIF
END DO
DO jn = 5, 8 ! 4 corners
IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
ELSE ; ifill(jn,jf) = jpfillnothing ! do nothing
ENDIF
END DO
!
! north fold treatment
IF( l_IdoNFold ) ifill(jpno,jf) = jpfillnothing ! we do north fold -> do nothing for northern halo
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
!
! ! ________________________
ip0i = 0 ! im0j = inner |__|__|__________|__|__|
ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__|
im1i = ipi(jf)-2*ihls ! | | | | | |
im0i = ipi(jf) - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! |__|__|__________|__|__|
im1j = ipj(jf)-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj(jf) - ihls ! ip0j = 0 |__|__|__________|__|__|
! ! ip0i ip1i im1i im0i
!
! define shorter names...
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
iisz = ipi(jf)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4,jf) = (/ ihls, ihls, iisz, iisz /) ; isizei(5:8,jf) = ihls ! i- count
isizej(1:4,jf) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8,jf) = ihls ! j- count
ishtSi(1:4,jf) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8,jf) = ishtSi( iwewe,jf ) ! i- shift send data
ishtSj(1:4,jf) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8,jf) = ishtSj( issnn,jf ) ! j- shift send data
ishtRi(1:4,jf) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8,jf) = ishtRi( iwewe,jf ) ! i- shift recv data
ishtRj(1:4,jf) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8,jf) = ishtRj( issnn,jf ) ! j- shift recv data
ishtPi(1:4,jf) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8,jf) = ishtPi( iwewe,jf ) ! i- shift perio data
ishtPj(1:4,jf) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8,jf) = ishtPj( issnn,jf ) ! j- shift perio data
!
END DO ! jf
!
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count
isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count
ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data
ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data
ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location
ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location
ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity
ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, SUM(ipk(:))/kfld, SUM(ipl(:))/kfld, kfld, ld_lbc = .TRUE. )
!
! -------------------------------- !
! 2. Prepare MPI exchanges !
! -------------------------------- !
!
iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different
iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! can be any value but each value must be unique
! define iRtag with the corresponding iStag, e.g. data received at west where sent at east.
iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso)
iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw)
!
iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
! size of the buffer to be sent/recv in each direction
ibufszS(:) = 0 ! defaut definition
ibufszR(:) = 0
DO jf = 1, kfld
DO jn = 1, 8
IF( llsend(jn,jf) ) ibufszS(jn) = ibufszS(jn) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
IF( llrecv(jn,jf) ) ibufszR(jn) = ibufszR(jn) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
END DO
END DO
!
! offset to apply to find the position of the sent/recv data within the buffer
ishtS(1) = 0
DO jn = 2, 8
ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) )
ishtS(jn) = ishtS(jn-1) + ibufszS(jn-1)
END DO
ishtR(1) = 0
DO jn = 2, 8
ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) )
ishtR(jn) = ishtR(jn-1) + ibufszR(jn-1)
END DO
!
! Allocate buffer arrays to be sent/received if needed
iszS = SUM(iszall, mask = llsend) ! send buffer size
iszS = SUM(ibufszS) ! send buffer size
IF( ALLOCATED(BUFFSND) ) THEN
CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call
IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) )
iszR = SUM(iszall, mask = llrecv) ! recv buffer size
iszR = SUM(ibufszR) ! recv buffer size
IF( ALLOCATED(BUFFRCV) ) THEN
IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) )
!
! default definition when no communication is done. understood by mpi_waitall
! Default definition when no communication is done. Understood by mpi_waitall
nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above
!
! ----------------------------------------------- !
......@@ -177,19 +201,28 @@
!
! ----------------------------------- !
! 4. Fill east and west halos !
! Must be done before sending data !
! data to south/north/corners !
! ----------------------------------- !
!
DO jn = 1, 2
#define BLOCK_FILL
DO jn = 1, 2 ! first: do all the non-MPI filling to give more time to MPI_RECV
#define BLOCK_FILL_nonMPI
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL_nonMPI
END DO
DO jn = 1, 2 ! next: do the MPI_RECV part
#define BLOCK_FILL_MPI_RECV
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL
#undef BLOCK_FILL_MPI_RECV
END DO
!
! ------------------------------------------------- !
! 5. Do north and south MPI_Isend if needed !
! and Specific problem in corner treatment !
! ( very rate case... ) !
! ------------------------------------------------- !
!
DO jn = 3, 4
DO jn = 3, 8
#define BLOCK_ISEND
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_ISEND
......@@ -199,44 +232,34 @@
! 6. north fold treatment !
! ------------------------------- !
!
! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...)
! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data
! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data
! Do it after MPI_iSend to south/north/corners neighbourgs so they won't wait (too much) to receive their data
! Do if before MPI_Recv from south/north/corners neighbourgs so we will have more time to receive data
!
IF( l_IdoNFold ) THEN
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , kfld ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, kfld ) ! mpi NFold
ENDIF
ENDIF
!
! ------------------------------------- !
! 7. Fill south and north halos !
! ------------------------------------- !
! ------------------------------------------------ !
! 7. Fill south and north halos !
! and specific problem in corner treatment !
! ( very rate case... ) !
! ------------------------------------------------ !
!
DO jn = 3, 4
#define BLOCK_FILL
DO jn = 3, 8 ! first: do all the non-MPI filling to give more time to MPI_RECV
#define BLOCK_FILL_nonMPI
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL
#undef BLOCK_FILL_nonMPI
END DO
!
! ----------------------------------------------- !
! 8. Specific problem in corner treatment !
! ( very rate case... ) !
! ----------------------------------------------- !
!
DO jn = 5, 8
#define BLOCK_ISEND
DO jn = 3, 8 ! next: do the MPI_RECV part
#define BLOCK_FILL_MPI_RECV
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_ISEND
END DO
DO jn = 5, 8
#define BLOCK_FILL
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL
#undef BLOCK_FILL_MPI_RECV
END DO
!
! -------------------------------------------- !
! 9. deallocate local temporary arrays !
! 8. deallocate local temporary arrays !
! if they areg larger than jpi*jpj ! <- arbitrary max size...
! -------------------------------------------- !
!
......@@ -250,53 +273,72 @@
#endif
#if defined BLOCK_ISEND
IF( llsend(jn) ) THEN
ishti = ishtSi(jn)
ishtj = ishtSj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
idxs = idxs + 1
END DO ; END DO ; END DO ; END DO ; END DO
IF( ibufszS(jn) > 0 ) THEN ! we must send some data
DO jf = 1, kfld ! first: fill the buffer to be sent
IF( llsend(jn,jf) ) THEN
ishti = ishtSi(jn,jf)
ishtj = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
idxs = idxs + 1
END DO ; END DO ; END DO ; END DO
ENDIF
END DO
#if ! defined key_mpi_off
IF( ln_timing ) CALL tic_tac(.TRUE.)
! non-blocking send of the west/east side using local buffer
CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr )
! next: non-blocking send using local buffer. use mpiSnei(n_hlsmax,jn), see mppini
CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), ibufszS(jn), MPI_TYPE, mpiSnei(n_hlsmax,jn), iStag(jn), icomm, nreq_p2p(jn), ierr )
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
ENDIF
#endif
#if defined BLOCK_FILL
ishti = ishtRi(jn)
ishtj = ishtRj(jn)
SELECT CASE ( ifill(jn) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! fill with data received by MPI
#if defined BLOCK_FILL_nonMPI
DO jf = 1, kfld
IF( ifill(jn,jf) /= jpfillmpi ) THEN ! treat first all non-MPI cases
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
SELECT CASE ( ifill(jn,jf) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillperio ) ! we will do it later
ishti2 = ishtPi(jn,jf)
ishtj2 = ishtPj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jn,jf)
ishtj2 = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO
END SELECT
ENDIF
END DO
#endif
#if defined BLOCK_FILL_MPI_RECV
IF( ibufszR(jn) > 0 ) THEN ! we must receive some data
#if ! defined key_mpi_off
IF( ln_timing ) CALL tic_tac(.TRUE.)
! ! blocking receive of the west/east halo in local temporary arrays
CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr )
! blocking receive in local buffer. use mpiRnei(n_hlsmax,jn), see mppini
CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), ibufszR(jn), MPI_TYPE, mpiRnei(n_hlsmax,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr )
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr)
idxr = idxr + 1
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use periodicity
ishti2 = ishtPi(jn)
ishtj2 = ishtPj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jn)
ishtj2 = ishtSj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
DO jf = 1, kfld
IF( ifill(jn,jf) == jpfillmpi ) THEN ! Use MPI-received data
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr)
idxr = idxr + 1
END DO ; END DO ; END DO ; END DO
ENDIF
END DO
ENDIF
#endif
src/OCE/LBC/lbc_nfd_generic.h90
View file @ 5bc9e5ca
SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld )
SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfld )
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
!
INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ipi, ipj, ipk, ipl, ihls ! dimension of the input array
INTEGER :: ii1, ii2, ij1, ij2
!!----------------------------------------------------------------------
!
ipi = SIZE(ptab(1)%pt4d,1)
ipj = SIZE(ptab(1)%pt4d,2)
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
DO jf = 1, kfld ! Loop on the number of arrays to be treated
!
IF( ipi /= Ni0glo+2*khls ) THEN
WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
!
DO jf = 1, ipf ! Loop on the number of arrays to be treated
ipi = SIZE(ptab(jf)%pt4d,1)
ipj = SIZE(ptab(jf)%pt4d,2)
ipk = SIZE(ptab(jf)%pt4d,3)
ipl = SIZE(ptab(jf)%pt4d,4)
!
ihls = ( ipi - Ni0glo ) / 2
!
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
!
......@@ -30,160 +25,162 @@
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls+1
ii1 = khls + ji
DO ji = 1, 1 ! point ihls+1
ii1 = ihls + ji
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2
DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls + 1
ii1 = ipi - khls + ji
ii2 = khls + ji
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
ii1 = ipi - ihls + ji
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls-1 ! last khls-1 points
ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi
ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2
DO ji = 1, ihls-1 ! last ihls-1 points
ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - ihls - 1) + 1 = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls - 1) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-khls
ii1 = ji ! ends at: khls
ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls-1 points: have been / will done by e-w periodicity
! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
END DO ; END DO
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-khls
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls-1 points: have been / will done by e-w periodicity
! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
END DO ; END DO
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls+1 lines (from ipj to ipj-khls) : full
DO jj = 1, khls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls
ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1
! last ihls+1 lines (from ipj to ipj-ihls) : full
DO jj = 1, ihls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls+1
ii1 = khls + ji
DO ji = 1, 1 ! point ihls+1
ii1 = ihls + ji
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2
DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls + 1
ii1 = ipi - khls + ji
ii2 = khls + ji
IF( ihls > 0 ) THEN
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
ii1 = ipi - ihls + ji
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls-1 ! last khls-1 points
ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi
ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2
ENDIF
DO ji = 1, ihls-1 ! last ihls-1 points
ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
END DO; END DO
END DO ; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls+1 lines (from ipj to ipj-khls) : full
DO jj = 1, khls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls
ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1
! last ihls+1 lines (from ipj to ipj-ihls) : full
DO jj = 1, ihls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
......@@ -199,9 +196,9 @@
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! first: line number ipj-khls : 3 points
! first: line number ipj-ihls : 3 points
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, 1 ! points from ipi/2+1
......@@ -209,37 +206,37 @@
ii2 = ipi/2 - ji + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
END DO
DO ji = 1, 1 ! points ipi - khls
ii1 = ipi - khls + ji - 1
ii2 = khls + ji
DO ji = 1, 1 ! points ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
END DO
DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done)
! ! as we just changed point ipi - khls
ii1 = khls + ji - 1
ii2 = khls + ji
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ihls: redo it just in case (if e-w periodocity already done)
! ! as we just changed point ipi - ihls
ii1 = ihls + ji - 1
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
END DO
END DO
!
! Second: last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls
ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls
! Second: last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
......@@ -248,34 +245,34 @@
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls
ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
DO ji = 1, khls-1 ! first khls-1 points
ii1 = ji ! ends at: khls-1
ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
DO ji = 1, ihls-1 ! first ihls-1 points
ii1 = ji ! ends at: ihls-1
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls
ii1 = khls + ji - 1
DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1
ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1
DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls
ii1 = ipi - khls + ji - 1
DO ji = 1, 1 ! point ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
......@@ -284,100 +281,100 @@
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-khls
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls points: have been / will done by e-w periodicity
! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls-1 ! first khls-1 points
ii1 = ji ! ends at: khls-1
ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
DO ji = 1, ihls-1 ! first ihls-1 points
ii1 = ji ! ends at: ihls-1
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls
ii1 = khls + ji - 1
DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1
ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1
DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls
ii1 = ipi - khls + ji - 1
DO ji = 1, 1 ! point ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - ihls-1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1
ii1 = ji ! ends at: khls
ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
DO ji = 1, ihls-1 ! first ihls-1 points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-nn_hl-1
ii1 = ji ! ends at: ihls
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls points: have been / will done by e-w periodicity
! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
......@@ -385,7 +382,7 @@
!
ENDIF ! c_NFtype == 'F'
!
END DO ! ipf
END DO ! kfld
!
END SUBROUTINE lbc_nfd_/**/PRECISION
src/OCE/LBC/lbclnk.F90
View file @ 5bc9e5ca
......@@ -38,11 +38,9 @@ MODULE lbclnk
MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp
END INTERFACE
#if ! defined key_mpi2
INTERFACE lbc_lnk_neicoll
MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp
END INTERFACE
#endif
!
INTERFACE lbc_lnk_icb
MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp
......@@ -51,10 +49,10 @@ MODULE lbclnk
PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions
PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions
REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers
REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp !
INTEGER, DIMENSION(8) :: nreq_p2p ! request id for MPI_Isend in point-2-point communication
REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers
REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp !
INTEGER, DIMENSION(8) :: nreq_p2p = MPI_REQUEST_NULL ! request id for MPI_Isend in point-2-point communication
INTEGER :: nreq_nei = MPI_REQUEST_NULL ! request id for mpi_neighbor_ialltoallv
!! * Substitutions
!!# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
......@@ -134,9 +132,7 @@ CONTAINS
# define BUFFSND buffsnd_sp
# define BUFFRCV buffrcv_sp
# include "lbc_lnk_pt2pt_generic.h90"
#if ! defined key_mpi2
# include "lbc_lnk_neicoll_generic.h90"
#endif
# undef MPI_TYPE
# undef BUFFSND
# undef BUFFRCV
......@@ -149,9 +145,7 @@ CONTAINS
# define BUFFSND buffsnd_dp
# define BUFFRCV buffrcv_dp
# include "lbc_lnk_pt2pt_generic.h90"
#if ! defined key_mpi2
# include "lbc_lnk_neicoll_generic.h90"
#endif
# undef MPI_TYPE
# undef BUFFSND
# undef BUFFRCV
......
src/OCE/LBC/lbcnfd.F90
View file @ 5bc9e5ca
......@@ -23,8 +23,11 @@ MODULE lbcnfd
PRIVATE
INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll
MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp
MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp
MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_dp
END INTERFACE
INTERFACE lbc_nfd_ext ! called by mpp_lnk_2d_icb
MODULE PROCEDURE lbc_nfd_ext_sp, lbc_nfd_ext_dp
END INTERFACE
INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll
......@@ -33,11 +36,13 @@ MODULE lbcnfd
PUBLIC mpp_nfd ! mpi north fold conditions
PUBLIC lbc_nfd ! north fold conditions
PUBLIC lbc_nfd_ext ! north fold conditions, called by mpp_lnk_2d_icb
INTEGER, PUBLIC :: nfd_nbnei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_rksnd
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_jisnd
INTEGER, PUBLIC :: nfd_nbnei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:,:) :: nfd_rksnd
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:,:) :: nfd_jisnd
LOGICAL, PUBLIC, ALLOCATABLE, DIMENSION (:,: ) :: lnfd_same
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
......