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