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 1125 additions and 984 deletions
src/OCE/IOM/iom_nf90.F90
View file @ c72255b2
......@@ -40,6 +40,8 @@ MODULE iom_nf90
MODULE PROCEDURE iom_nf90_rp0123d_dp
END INTERFACE
!! * Substitutions
# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
!! $Id: iom_nf90.F90 14433 2021-02-11 08:06:49Z smasson $
......@@ -144,16 +146,16 @@ CONTAINS
END SELECT
CALL iom_nf90_check(NF90_DEF_DIM( if90id, 'time_counter', NF90_UNLIMITED, idmy ), clinfo)
! global attributes
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig0(Nis0), mjg0(Njs0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig0(Nie0), mjg0(Nje0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT( if90id, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_number' , narea-1 ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/ 1 , 2 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_size_global' , (/ Ni0glo , Nj0glo /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_size_local' , (/ Ni_0 , Nj_0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_position_first' , (/ mig(Nis0,0), mjg(Njs0,0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_position_last' , (/ mig(Nie0,0), mjg(Nje0,0) /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_halo_size_start', (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/ 0 , 0 /) ), clinfo)
CALL iom_nf90_check(NF90_PUT_ATT(if90id,NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ), clinfo)
ELSE !* the file should be open for read mode so it must exist...
CALL ctl_stop( TRIM(clinfo), ' should be impossible case...' )
ENDIF
......@@ -544,7 +546,7 @@ CONTAINS
INTEGER :: idvar ! variable id
INTEGER :: jd ! dimension loop counter
INTEGER :: ix1, ix2, iy1, iy2 ! subdomain indexes
INTEGER, DIMENSION(4) :: idimsz ! dimensions size
INTEGER, DIMENSION(3) :: ishape ! dimensions size
INTEGER, DIMENSION(4) :: idimid ! dimensions id
CHARACTER(LEN=256) :: clinfo ! info character
INTEGER :: if90id ! nf90 file identifier
......@@ -627,11 +629,9 @@ CONTAINS
itype = NF90_DOUBLE
ENDIF
IF( PRESENT(pv_r0d) ) THEN
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, &
& iom_file(kiomid)%nvid(idvar) ), clinfo )
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, iom_file(kiomid)%nvid(idvar) ), clinfo )
ELSE
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), &
& iom_file(kiomid)%nvid(idvar) ), clinfo )
CALL iom_nf90_check(NF90_DEF_VAR( if90id, TRIM(cdvar), itype, idimid(1:idims), iom_file(kiomid)%nvid(idvar) ), clinfo )
ENDIF
lchunk = .false.
IF( snc4set%luse .AND. idims == 4 ) lchunk = .true.
......@@ -673,23 +673,13 @@ CONTAINS
ENDIF
! on what kind of domain must the data be written?
IF( PRESENT(pv_r2d) .OR. PRESENT(pv_r3d) ) THEN
idimsz(1:2) = iom_file(kiomid)%dimsz(1:2,idvar)
IF( idimsz(1) == Ni_0 .AND. idimsz(2) == Nj_0 ) THEN
ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj
ELSEIF( idimsz(1) == jpi .AND. idimsz(2) == jpj ) THEN
ix1 = 1 ; ix2 = jpi ; iy1 = 1 ; iy2 = jpj
ELSE
CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' )
ENDIF
! write dimension variables if it is not already done
! =============
! trick: is defined to 0 => dimension variable are defined but not yet written
IF( iom_file(kiomid)%dimsz(1, 4) == 0 ) THEN ! time_counter = 0
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(ix1:ix2, iy1:iy2) ), clinfo )
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(ix1:ix2, iy1:iy2) ), clinfo )
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 1, glamt(A2D(0)) ), clinfo )
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 2, gphit(A2D(0)) ), clinfo )
SELECT CASE (iom_file(kiomid)%comp)
CASE ('OCE')
CALL iom_nf90_check( NF90_PUT_VAR( if90id, 3, gdept_1d ), clinfo )
......@@ -704,6 +694,19 @@ CONTAINS
iom_file(kiomid)%dimsz(1, 4) = 1 ! so we don't enter this IF case any more...
IF(lwp) WRITE(numout,*) TRIM(clinfo)//' write dimension variables done'
ENDIF
IF( PRESENT(pv_r2d) ) ishape(1:2) = SHAPE(pv_r2d)
IF( PRESENT(pv_r3d) ) ishape(1:3) = SHAPE(pv_r3d)
IF( ishape(1) == Ni_0 .AND. ishape(2) == Nj_0 ) THEN ! array with 0 halo
ix1 = 1 ; ix2 = Ni_0 ; iy1 = 1 ; iy2 = Nj_0
ELSEIF( ishape(1) == jpi .AND. ishape(2) == jpj ) THEN ! array with nn_hls halos
ix1 = Nis0 ; ix2 = Nie0 ; iy1 = Njs0 ; iy2 = Nje0
ELSEIF( ishape(1) == Ni_0+1 .AND. ishape(2) == Nj_0+1 ) THEN ! nn_hls = 2 and array with 1 halo
ix1 = 2 ; ix2 = Ni_0+1 ; iy1 = 2 ; iy2 = Nj_0+1
ELSE
CALL ctl_stop( 'iom_nf90_rp0123d: should have been an impossible case...' )
ENDIF
ENDIF
! write the data
......@@ -712,7 +715,7 @@ CONTAINS
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r0d ), clinfo )
ELSEIF( PRESENT(pv_r1d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r1d(:) ), clinfo )
ELSEIF( PRESENT(pv_r2d) ) THEN
ELSEIF( PRESENT(pv_r2d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r2d(ix1:ix2,iy1:iy2) ), clinfo )
ELSEIF( PRESENT(pv_r3d) ) THEN
CALL iom_nf90_check( NF90_PUT_VAR( if90id, idvar, pv_r3d(ix1:ix2,iy1:iy2,:) ), clinfo )
......
src/OCE/IOM/prtctl.F90
View file @ c72255b2
......@@ -137,9 +137,14 @@ CONTAINS
INTEGER :: jn, jl, kdir
INTEGER :: iis, iie, jjs, jje
INTEGER :: itra, inum
INTEGER, DIMENSION(4) :: ishape
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 not working with tiles' )
ENDIF
! Arrays, scalars initialization
cl1 = ''
cl2 = ''
......@@ -157,12 +162,19 @@ CONTAINS
! Loop over each sub-domain, i.e. the total number of processors ijsplt
DO jl = 1, SIZE(nall_ictls)
! define shoter names...
iis = MAX( nall_ictls(jl), ntsi )
iie = MIN( nall_ictle(jl), ntei )
jjs = MAX( nall_jctls(jl), ntsj )
jje = MIN( nall_jctle(jl), ntej )
IF( PRESENT(tab2d_1) ) ishape(1:2) = SHAPE(tab2d_1)
IF( PRESENT(tab3d_1) ) ishape(1:3) = SHAPE(tab3d_1)
IF( PRESENT(tab4d_1) ) ishape(1:4) = SHAPE(tab4d_1)
IF( ishape(1) == jpi .AND. ishape(2) == jpj ) THEN
iis = Nis0 ; iie = Nie0 ; jjs = Njs0 ; jje = Nje0
ELSE
iis = 1 ; iie = ishape(1) ; jjs = 1 ; jje = ishape(2)
ENDIF
iis = MAX( nall_ictls(jl), iis )
iie = MIN( nall_ictle(jl), iie )
jjs = MAX( nall_jctls(jl), jjs )
jje = MIN( nall_jctle(jl), jje )
IF( PRESENT(clinfo) ) THEN ; inum = numprt_top(jl)
ELSE ; inum = numprt_oce(jl)
......@@ -188,32 +200,32 @@ CONTAINS
! 2D arrays
IF( PRESENT(tab2d_1) ) THEN
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(iis:iie,jjs:jje,1) )
ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) )
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) * mask1(A2D(0),1) )
ELSE ; zsum1 = SUM( tab2d_1(iis:iie,jjs:jje) )
ENDIF
ENDIF
IF( PRESENT(tab2d_2) ) THEN
IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(iis:iie,jjs:jje,1) )
ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) )
IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) * mask2(A2D(0),1) )
ELSE ; zsum2 = SUM( tab2d_2(iis:iie,jjs:jje) )
ENDIF
ENDIF
! 3D arrays
IF( PRESENT(tab3d_1) ) THEN
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(iis:iie,jjs:jje,1:kdir) )
ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) )
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) * mask1(A2D(0),1:kdir) )
ELSE ; zsum1 = SUM( tab3d_1(iis:iie,jjs:jje,1:kdir) )
ENDIF
ENDIF
IF( PRESENT(tab3d_2) ) THEN
IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(iis:iie,jjs:jje,1:kdir) )
ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) )
IF( PRESENT(mask2) ) THEN ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) * mask2(A2D(0),1:kdir) )
ELSE ; zsum2 = SUM( tab3d_2(iis:iie,jjs:jje,1:kdir) )
ENDIF
ENDIF
! 4D arrays
IF( PRESENT(tab4d_1) ) THEN
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(iis:iie,jjs:jje,1:kdir) )
ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) )
IF( PRESENT(mask1) ) THEN ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) * mask1(A2D(0),1:kdir) )
ELSE ; zsum1 = SUM( tab4d_1(iis:iie,jjs:jje,1:kdir,jn) )
ENDIF
ENDIF
......@@ -460,22 +472,22 @@ CONTAINS
!
idg = MAXVAL( (/ nall_ictls(jl), nall_ictle(jl), nall_jctls(jl), nall_jctle(jl) /) ) ! temporary use of idg
idg = INT(LOG10(REAL(idg,wp))) + 1 ! how many digits do we use?
idg2 = MAXVAL( (/ mig0(nall_ictls(jl)), mig0(nall_ictle(jl)), mjg0(nall_jctls(jl)), mjg0(nall_jctle(jl)) /) )
idg2 = MAXVAL( (/ mig(nall_ictls(jl),0), mig(nall_ictle(jl),0), mjg(nall_jctls(jl),0), mjg(nall_jctle(jl),0) /) )
idg2 = INT(LOG10(REAL(idg2,wp))) + 1 ! how many digits do we use?
WRITE(clfmt2, "('(18x, 13a1, a9, i', i1, ', a2, i',i1,', a2, 13a1)')") idg, idg2
WRITE(clfmt3, "('(18x, a1, ', i2,'x, a1)')") 13+9+idg+2+idg2+2+13 - 2
WRITE(clfmt4, "('(', i2,'x, a9, i', i1,', a2, i', i1,', a2, ', i2,'x, a9, i', i1,', a2, i', i1,', a2)')") &
& 18-7, idg, idg2, 13+9+idg+2+idg2+2+13 - (2+idg+2+idg2+2+8), idg, idg2
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg0(nall_jctle(jl)), ') ', ('-', ji=1,13)
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctle = ', nall_jctle(jl), ' (', mjg(nall_jctle(jl),0), ') ', ('-', ji=1,13)
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig0(nall_ictls(jl)), ') ', &
& ' ictle = ', nall_ictle(jl), ' (', mig0(nall_ictle(jl)), ') '
WRITE(inum,clfmt4) ' ictls = ', nall_ictls(jl), ' (', mig(nall_ictls(jl),0), ') ', &
& ' ictle = ', nall_ictle(jl), ' (', mig(nall_ictle(jl),0), ') '
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt3) '|', '|'
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg0(nall_jctls(jl)), ') ', ('-', ji=1,13)
WRITE(inum,clfmt2) ('-', ji=1,13), ' jctls = ', nall_jctls(jl), ' (', mjg(nall_jctls(jl),0), ') ', ('-', ji=1,13)
WRITE(inum,*)
WRITE(inum,*)
!
......
src/OCE/ISF/isfcpl.F90
View file @ c72255b2
......@@ -736,7 +736,8 @@ CONTAINS
END IF
!
! update isfpts structure
sisfpts(kpts) = isfcons(mig(ki), mjg(kj), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, glamt(ki,kj), gphit(ki,kj), ifind )
sisfpts(kpts) = isfcons(mig(ki,nn_hls), mjg(kj,nn_hls), kk, pratio * pdvol, pratio * pdsal, pratio * pdtem, &
& glamt(ki,kj), gphit(ki,kj), ifind )
!
END SUBROUTINE update_isfpts
!
......@@ -761,8 +762,8 @@ CONTAINS
IF ( kfind == 1 ) CALL dom_ngb( plon, plat, iig, ijg,'T', kk)
!
! fill the correction array
DO jj = mj0(ijg),mj1(ijg)
DO ji = mi0(iig),mi1(iig)
DO jj = mj0(ijg,nn_hls),mj1(ijg,nn_hls)
DO ji = mi0(iig,nn_hls),mi1(iig,nn_hls)
! correct the vol_flx and corresponding heat/salt flx in the closest cell
risfcpl_cons_vol(ji,jj,kk) = risfcpl_cons_vol(ji,jj,kk ) + pvolinc
risfcpl_cons_tsc(ji,jj,kk,jp_sal) = risfcpl_cons_tsc(ji,jj,kk,jp_sal) + psalinc
......
src/OCE/LBC/lbc_lnk_call_generic.h90
View file @ c72255b2
......@@ -27,7 +27,7 @@
& , pt21, cdna21, psgn21, pt22, cdna22, psgn22, pt23, cdna23, psgn23, pt24, cdna24, psgn24 &
& , pt25, cdna25, psgn25, pt26, cdna26, psgn26, pt27, cdna27, psgn27, pt28, cdna28, psgn28 &
& , pt29, cdna29, psgn29, pt30, cdna30, psgn30 &
& , kfillmode, pfillval, khls, lsend, lrecv, ld4only )
& , kfillmode, pfillval, lsend, lrecv, ld4only )
!!---------------------------------------------------------------------
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
REAL(PRECISION), DIMENSION(DIMS) , TARGET, CONTIGUOUS, INTENT(inout) :: pt1 ! arrays on which the lbc is applied
......@@ -50,7 +50,6 @@
& psgn30
INTEGER , OPTIONAL , INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION) , OPTIONAL , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , OPTIONAL , INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8), OPTIONAL , INTENT(in ) :: lsend, lrecv ! indicate how communications are to be carried out
LOGICAL , OPTIONAL , INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
!!
......@@ -96,15 +95,11 @@
IF( PRESENT(psgn29) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt29, cdna29, psgn29, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
IF( PRESENT(psgn30) ) CALL load_ptr_/**/XD/**/_/**/PRECISION( pt30, cdna30, psgn30, ptab_ptr, cdna_ptr, psgn_ptr, kfld )
!
#if ! defined key_mpi2
IF( nn_comm == 1 ) THEN
CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
ELSE
CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
CALL lbc_lnk_neicoll( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
ENDIF
#else
CALL lbc_lnk_pt2pt( cdname, ptab_ptr, cdna_ptr, psgn_ptr, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
#endif
!
END SUBROUTINE lbc_lnk_call_/**/XD/**/_/**/PRECISION
......
src/OCE/LBC/lbc_lnk_neicoll_generic.h90
View file @ c72255b2
SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
SUBROUTINE lbc_lnk_neicoll_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
......@@ -7,265 +7,311 @@
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
!
INTEGER :: ji, jj, jk , jl, jf, jn ! dummy loop indices
INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ip0i, ip1i, im0i, im1i
INTEGER :: ip0j, ip1j, im0j, im1j
INTEGER :: ishti, ishtj, ishti2, ishtj2
INTEGER :: iszS, iszR
INTEGER :: inbS, inbR, iszS, iszR
INTEGER :: ierr
INTEGER :: ihls, idx
INTEGER :: ihls, ihlsmax, idx
INTEGER :: impi_nc
INTEGER :: ifill_nfd
INTEGER, DIMENSION(4) :: iwewe, issnn
INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj
INTEGER, DIMENSION(8) :: ifill, iszall
INTEGER, DIMENSION(8) :: jnf
INTEGER, DIMENSION( kfld) :: ipi, ipj, ipk, ipl ! dimension of the input array
INTEGER, DIMENSION(8,kfld) :: ifill
INTEGER, DIMENSION(8,kfld) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8,kfld) :: isizej, ishtSj, ishtRj, ishtPj
INTEGER, DIMENSION(:), ALLOCATABLE :: iScnt, iRcnt ! number of elements to be sent/received
INTEGER, DIMENSION(:), ALLOCATABLE :: iSdpl, iRdpl ! displacement in halos arrays
LOGICAL, DIMENSION(8) :: llsend, llrecv
REAL(PRECISION) :: zland
LOGICAL, DIMENSION(8,kfld) :: llsend, llrecv
LOGICAL :: ll4only ! default: 8 neighbourgs
REAL(PRECISION) :: zland
!!----------------------------------------------------------------------
!
! ----------------------------------------- !
! 1. local variables initialization !
! ----------------------------------------- !
!
ipi = SIZE(ptab(1)%pt4d,1)
ipj = SIZE(ptab(1)%pt4d,2)
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
!
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
!
! take care of optional parameters
!
ihls = nn_hls ! default definition
IF( PRESENT( khls ) ) ihls = khls
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipi /= Ni_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipj /= Nj_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
!
ll4only = .FALSE. ! default definition
IF( PRESENT(ld4only) ) ll4only = ld4only
!
impi_nc = mpi_nc_com8(ihls) ! default
IF( ll4only ) impi_nc = mpi_nc_com4(ihls)
!
zland = 0._wp ! land filling value: zero by default
IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented')
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners
llrecv(:) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners
ENDIF
ifill_nfd = jpfillcst ! default definition
IF( PRESENT(kfillmode) ) ifill_nfd = kfillmode
!
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 8
IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined
ELSE ; ifill(jn) = jpfillcst ! constant value (zland)
ENDIF
END DO
! take care of "indirect self-periodicity" for the corners
DO jn = 5, 8
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn) = jpfillnothing ! no bi-perio but ew-perio: do corners later
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn) = jpfillnothing ! no bi-perio but ns-perio: do corners later
END DO
! north fold treatment
IF( l_IdoNFold ) THEN
ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo
ENDIF
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
ihlsmax = 0
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
! ! ________________________
ip0i = 0 ! im0j = inner |__|________________|__|
ip1i = ihls ! im1j = inner - halo | |__|__________|__| |
im1i = ipi-2*ihls ! | | | | | |
im0i = ipi - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! | |__|__________|__| |
im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj - ihls ! ip0j = 0 |__|________________|__|
! ! ip0i ip1i im1i im0i
DO jf = 1, kfld
!
ipi(jf) = SIZE(ptab(jf)%pt4d,1)
ipj(jf) = SIZE(ptab(jf)%pt4d,2)
ipk(jf) = SIZE(ptab(jf)%pt4d,3)
ipl(jf) = SIZE(ptab(jf)%pt4d,4)
ihls = ( ipi(jf) - Ni_0 ) / 2
ihlsmax = MAX(ihls, ihlsmax)
!
IF( numcom == -1 ) THEN ! test input array shape. Use numcom to do these tests only at the beginning of the run
IF( MOD( ipi(jf) - Ni_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong i-size: ', ipi(jf), Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( MOD( ipj(jf) - Nj_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong j-size: ', ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ( ipj(jf) - Nj_0 ) / 2 /= ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array as wong i and j-size: ', &
& ipi(jf), Ni_0, ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but for the ', jf,'th input array, ', ihls, ' > n_hlsmax = ', &
& n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
ENDIF
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
CALL ctl_stop( 'STOP', 'mpp_nc_generic+lsend and lrecv not yet implemented')
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:,jf) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8,jf) = .FALSE. ! exclude corners
llrecv(:,jf) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8,jf) = .FALSE. ! exclude corners
ENDIF
!
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 8
IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn,jf) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn,jf) = kfillmode ! localy defined
ELSEIF( ihls == 0 ) THEN ; ifill(jn,jf) = jpfillnothing ! do nothing
ELSE ; ifill(jn,jf) = jpfillcst ! constant value (zland)
ENDIF
END DO
! take care of "indirect self-periodicity" for the corners
DO jn = 5, 8
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpwe)) ifill(jn,jf) = jpfillnothing ! no bi-perio but ew-perio: do corners later
IF(.NOT.l_SelfPerio(jn) .AND. l_SelfPerio(jpso)) ifill(jn,jf) = jpfillnothing ! no bi-perio but ns-perio: do corners later
END DO
! north fold treatment
IF( l_IdoNFold ) ifill(jpno,jf) = jpfillnothing ! we do north fold -> do nothing for northern halo
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
! ! ________________________
ip0i = 0 ! im0j = inner |__|________________|__|
ip1i = ihls ! im1j = inner - halo | |__|__________|__| |
im1i = ipi(jf)-2*ihls ! | | | | | |
im0i = ipi(jf) - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! | |__|__________|__| |
im1j = ipj(jf)-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj(jf) - ihls ! ip0j = 0 |__|________________|__|
! ! ip0i ip1i im1i im0i
!
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4,jf) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8,jf) = ihls ! i- count
isizej(1:4,jf) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8,jf) = ihls ! j- count
ishtSi(1:4,jf) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8,jf) = ishtSi( iwewe,jf ) ! i- shift send data
ishtSj(1:4,jf) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8,jf) = ishtSj( issnn,jf ) ! j- shift send data
ishtRi(1:4,jf) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8,jf) = ishtRi( iwewe,jf ) ! i- shift recv data
ishtRj(1:4,jf) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8,jf) = ishtRj( issnn,jf ) ! j- shift recv data
ishtPi(1:4,jf) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8,jf) = ishtPi( iwewe,jf ) ! i- shift perio data
ishtPj(1:4,jf) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8,jf) = ishtPj( issnn,jf ) ! j- shift perio data
!
END DO ! jf
!
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4) = (/ ihls, ihls, Ni_0, Ni_0 /) ; isizei(5:8) = ihls ! i- count
isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count
ishtSi(1:4) = (/ ip1i, im1i, ip1i, ip1i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data
ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data
ishtRi(1:4) = (/ ip0i, im0i, ip1i, ip1i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location
ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location
ishtPi(1:4) = (/ im1i, ip1i, ip1i, ip1i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity
ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, SUM(ipk(:))/kfld, SUM(ipl(:))/kfld, kfld, ld_lbc = .TRUE. )
!
! -------------------------------- !
! 2. Prepare MPI exchanges !
! -------------------------------- !
!
! Allocate local temporary arrays to be sent/received.
iszS = COUNT( llsend )
iszR = COUNT( llrecv )
ALLOCATE( iScnt(iszS), iRcnt(iszR), iSdpl(iszS), iRdpl(iszR) ) ! ok if iszS = 0 or iszR = 0
iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
iScnt(:) = PACK( iszall, mask = llsend ) ! ok if mask = .false.
iRcnt(:) = PACK( iszall, mask = llrecv )
IF( iszS > 0 ) iSdpl(1) = 0
DO jn = 2,iszS
inbS = COUNT( ANY(llsend,dim=2) ) ! number of snd neighbourgs
inbR = COUNT( ANY(llrecv,dim=2) ) ! number of rcv neighbourgs
ALLOCATE( iScnt(inbS), iRcnt(inbR), iSdpl(inbS), iRdpl(inbR) ) ! ok if iszS = 0 or iszR = 0
iScnt(:) = 0 ; idx = 0
DO jn = 1, 8
IF( COUNT( llsend(jn,:) ) > 0 ) THEN ! we send something to neighbourg jn
idx = idx + 1
DO jf = 1, kfld
IF( llsend(jn,jf) ) iScnt(idx) = iScnt(idx) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
END DO
ENDIF
END DO
IF( inbS > 0 ) iSdpl(1) = 0
DO jn = 2,inbS
iSdpl(jn) = iSdpl(jn-1) + iScnt(jn-1) ! with _alltoallv: in units of sendtype
END DO
IF( iszR > 0 ) iRdpl(1) = 0
DO jn = 2,iszR
iRcnt(:) = 0 ; idx = 0
DO jn = 1, 8
IF( COUNT( llrecv(jn,:) ) > 0 ) THEN ! we get something from neighbourg jn
idx = idx + 1
DO jf = 1, kfld
IF( llrecv(jn,jf) ) iRcnt(idx) = iRcnt(idx) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
END DO
ENDIF
END DO
IF( inbR > 0 ) iRdpl(1) = 0
DO jn = 2,inbR
iRdpl(jn) = iRdpl(jn-1) + iRcnt(jn-1) ! with _alltoallv: in units of sendtype
END DO
!
! Allocate buffer arrays to be sent/received if needed
iszS = SUM(iszall, mask = llsend) ! send buffer size
iszS = SUM(iScnt) ! send buffer size
IF( ALLOCATED(BUFFSND) ) THEN
CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! needed only if PREVIOUS call was using nn_comm = 1 (for tests)
IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) )
iszR = SUM(iszall, mask = llrecv) ! recv buffer size
iszR = SUM(iRcnt) ! recv buffer size
IF( ALLOCATED(BUFFRCV) ) THEN
IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) )
!
! fill sending buffer with ptab(jf)%pt4d
idx = 1
idx = 0
DO jn = 1, 8
IF( llsend(jn) ) THEN
ishti = ishtSi(jn)
ishtj = ishtSj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
idx = idx + 1
END DO ; END DO ; END DO ; END DO ; END DO
ENDIF
DO jf = 1, kfld
IF( llsend(jn,jf) ) THEN
ishti = ishtSi(jn,jf)
ishtj = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
idx = idx + 1
BUFFSND(idx) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
ENDIF
END DO
END DO
!
! ------------------------------------------------ !
! 3. Do all MPI exchanges in 1 unique call !
! ------------------------------------------------ !
!
IF( ln_timing ) CALL tic_tac(.TRUE.)
CALL mpi_neighbor_alltoallv (BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, ierr)
IF( ln_timing ) CALL tic_tac(.FALSE.)
IF( ihlsmax > 0 ) THEN
impi_nc = mpi_nc_com8( ihlsmax )
IF( ll4only ) impi_nc = mpi_nc_com4( ihlsmax )
#if ! defined key_mpi2
IF( ln_timing ) CALL tic_tac( .TRUE.)
CALL mpi_Ineighbor_alltoallv(BUFFSND, iScnt, iSdpl, MPI_TYPE, BUFFRCV, iRcnt, iRdpl, MPI_TYPE, impi_nc, nreq_nei, ierr)
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
ENDIF
nreq_p2p = MPI_REQUEST_NULL ! needed only if we switch between nn_comm = 1 and 2 (for tests)
!
! ------------------------- !
! 4. Fill all halos !
! ------------------------- !
! --------------------------------- !
! 4. Fill all Non-MPI halos !
! --------------------------------- !
!
idx = 1
! MPI3 bug fix when domain decomposition has 2 columns/rows
IF (jpni .eq. 2) THEN
IF (jpnj .eq. 2) THEN
jnf(1:8) = (/ 2, 1, 4, 3, 8, 7, 6, 5 /)
ELSE
jnf(1:8) = (/ 2, 1, 3, 4, 6, 5, 8, 7 /)
ENDIF
ELSE
IF (jpnj .eq. 2) THEN
jnf(1:8) = (/ 1, 2, 4, 3, 7, 8, 5, 6 /)
ELSE
jnf(1:8) = (/ 1, 2, 3, 4, 5, 6, 7, 8 /)
ENDIF
ENDIF
! do it first to give (potentially) more time for the communications
DO jn = 1, 8
ishti = ishtRi(jnf(jn))
ishtj = ishtRj(jnf(jn))
SELECT CASE ( ifill(jnf(jn)) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! fill with data received by MPI
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx)
idx = idx + 1
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use periodicity
ishti2 = ishtPi(jnf(jn))
ishtj2 = ishtPj(jnf(jn))
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jnf(jn))
ishtj2 = ishtSj(jnf(jn))
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jnf(jn)) ; DO ji = 1,isizei(jnf(jn))
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
DO jf = 1, kfld
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
SELECT CASE ( ifill(jn,jf) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! no it later
CASE ( jpfillperio ) ! use periodicity
ishti2 = ishtPi(jn,jf)
ishtj2 = ishtPj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jn,jf)
ishtj2 = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO
END SELECT
END DO
END DO
!
! ----------------------------- !
! 5. Fill all MPI halos !
! ----------------------------- !
!
CALL mpi_wait( nreq_nei, MPI_STATUS_IGNORE, ierr )
!
idx = 0
DO jn = 1, 8
DO jf = 1, kfld
IF( ifill(jn,jf) == jpfillmpi ) THEN ! fill with data received by MPI
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
idx = idx + 1
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idx)
END DO; END DO ; END DO ; END DO
ENDIF
END DO
END DO
DEALLOCATE( iScnt, iRcnt, iSdpl, iRdpl )
IF( iszS > jpi*jpj ) DEALLOCATE(BUFFSND) ! blocking Send -> can directly deallocate
IF( iszR > jpi*jpj ) DEALLOCATE(BUFFRCV) ! blocking Recv -> can directly deallocate
! potential "indirect self-periodicity" for the corners
!
! ---------------------------------------------------------------- !
! 6. Potential "indirect self-periodicity" for the corners !
! ---------------------------------------------------------------- !
!
DO jn = 5, 8
IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpwe) ) THEN ! no bi-perio but ew-perio: corners indirect definition
ishti = ishtRi(jn)
ishtj = ishtRj(jn)
ishti2 = ishtPi(jn) ! use i- shift periodicity
ishtj2 = ishtRj(jn) ! use j- shift recv location: use ew-perio -> ok as filling of the south and north halos now done
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
DO jf = 1, kfld
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
ishti2 = ishtPi(jn,jf) ! use i- shift periodicity
ishtj2 = ishtRj(jn,jf) ! use j- shift recv location: use ew-perio -> ok as filling of the so and no halos now done
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
END DO
ENDIF
IF( .NOT. l_SelfPerio(jn) .AND. l_SelfPerio(jpso) ) THEN ! no bi-perio but ns-perio: corners indirect definition
ishti = ishtRi(jn)
ishtj = ishtRj(jn)
ishti2 = ishtRi(jn) ! use i- shift recv location: use ns-perio -> ok as filling of the west and east halos now done
ishtj2 = ishtPj(jn) ! use j- shift periodicity
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
DO jf = 1, kfld
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
ishti2 = ishtRi(jn,jf) ! use i- shift recv location: use ns-perio -> ok as filling of the we and ea halos now done
ishtj2 = ishtPj(jn,jf) ! use j- shift periodicity
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
END DO
ENDIF
END DO
!
! ------------------------------- !
! 5. north fold treatment !
! 7. north fold treatment !
! ------------------------------- !
!
IF( l_IdoNFold ) THEN
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , kfld ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, kfld ) ! mpi NFold
ENDIF
ENDIF
!
......
src/OCE/LBC/lbc_lnk_pt2pt_generic.h90
View file @ c72255b2
#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL
SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, khls, lsend, lrecv, ld4only )
#if ! defined BLOCK_ISEND && ! defined BLOCK_FILL_nonMPI && ! defined BLOCK_FILL_MPI_RECV
SUBROUTINE lbc_lnk_pt2pt_/**/PRECISION( cdname, ptab, cd_nat, psgn, kfld, kfillmode, pfillval, lsend, lrecv, ld4only )
CHARACTER(len=*) , INTENT(in ) :: cdname ! name of the calling subroutine
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
......@@ -8,161 +8,185 @@
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
INTEGER , OPTIONAL, INTENT(in ) :: kfillmode ! filling method for halo over land (default = constant)
REAL(PRECISION), OPTIONAL, INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , OPTIONAL, INTENT(in ) :: khls ! halo size, default = nn_hls
LOGICAL, DIMENSION(8),OPTIONAL, INTENT(in ) :: lsend, lrecv ! communication with other 4 proc
LOGICAL, OPTIONAL, INTENT(in ) :: ld4only ! if .T., do only 4-neighbour comm (ignore corners)
!
INTEGER :: ji, jj, jk, jl, jf, jn ! dummy loop indices
INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ip0i, ip1i, im0i, im1i
INTEGER :: ip0j, ip1j, im0j, im1j
INTEGER :: ishti, ishtj, ishti2, ishtj2
INTEGER :: ifill_nfd, icomm, ierr
INTEGER :: ihls, idxs, idxr, iszS, iszR
INTEGER :: ihls, iisz
INTEGER :: idxs, idxr, iszS, iszR
INTEGER, DIMENSION(4) :: iwewe, issnn
INTEGER, DIMENSION(8) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8) :: isizej, ishtSj, ishtRj, ishtPj
INTEGER, DIMENSION(8) :: ifill, iszall, ishtS, ishtR
INTEGER, DIMENSION(8) :: ireq ! mpi_request id
INTEGER, DIMENSION(8) :: ibufszS, ibufszR, ishtS, ishtR
INTEGER, DIMENSION(8) :: iStag, iRtag ! Send and Recv mpi_tag id
REAL(PRECISION) :: zland
LOGICAL, DIMENSION(8) :: llsend, llrecv
INTEGER, DIMENSION( kfld) :: ipi, ipj, ipk, ipl ! dimension of the input array
INTEGER, DIMENSION(8,kfld) :: ifill
INTEGER, DIMENSION(8,kfld) :: isizei, ishtSi, ishtRi, ishtPi
INTEGER, DIMENSION(8,kfld) :: isizej, ishtSj, ishtRj, ishtPj
LOGICAL, DIMENSION(8,kfld) :: llsend, llrecv
LOGICAL :: ll4only ! default: 8 neighbourgs
REAL(PRECISION) :: zland
!!----------------------------------------------------------------------
!
! ----------------------------------------- !
! 1. local variables initialization !
! ----------------------------------------- !
!
ipi = SIZE(ptab(1)%pt4d,1)
ipj = SIZE(ptab(1)%pt4d,2)
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
!
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, ipk, ipl, ipf, ld_lbc = .TRUE. )
!
idxs = 1 ! initalize index for send buffer
idxr = 1 ! initalize index for recv buffer
icomm = mpi_comm_oce ! shorter name
!
! take care of optional parameters
!
ihls = nn_hls ! default definition
IF( PRESENT( khls ) ) ihls = khls
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with khls > n_hlsmax : ', khls, '>', n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipi /= Ni_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along i: ', ipi, ihls, Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ipj /= Nj_0+2*ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with an input array which does not match ihls along j:', ipj, ihls , Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
!
ll4only = .FALSE. ! default definition
IF( PRESENT(ld4only) ) ll4only = ld4only
ll4only = .FALSE. ! default definition
IF( PRESENT( ld4only ) ) ll4only = ld4only
!
zland = 0._wp ! land filling value: zero by default
IF( PRESENT( pfillval ) ) zland = pfillval ! set land value
IF( PRESENT( pfillval) ) zland = pfillval ! set land value
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
llsend(:) = lsend(:) ; llrecv(:) = lrecv(:)
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8) = .FALSE. ! exclude corners
llrecv(:) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8) = .FALSE. ! exclude corners
ENDIF
ifill_nfd = jpfillcst ! default definition
IF( PRESENT(kfillmode) ) ifill_nfd = kfillmode
!
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 4
IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn) = kfillmode ! localy defined
ELSE ; ifill(jn) = jpfillcst ! constant value (zland)
DO jf = 1, kfld
!
ipi(jf) = SIZE(ptab(jf)%pt4d,1)
ipj(jf) = SIZE(ptab(jf)%pt4d,2)
ipk(jf) = SIZE(ptab(jf)%pt4d,3)
ipl(jf) = SIZE(ptab(jf)%pt4d,4)
ihls = ( ipi(jf) - Ni_0 ) / 2
!
IF( numcom == -1 ) THEN ! test input array shape. Use numcom to do these tests only at the beginning of the run
IF( MOD( ipi(jf) - Ni_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong i-size: ', ipi(jf), Ni_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( MOD( ipj(jf) - Nj_0, 2 ) /= 0 ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array has wong j-size: ', ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ( ipj(jf) - Nj_0 ) / 2 /= ihls ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but the ', jf,'th input array as wong i and j-size: ', &
& ipi(jf), Ni_0, ipj(jf), Nj_0
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
IF( ihls > n_hlsmax ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk but for the ', jf,'th input array, ', ihls, ' > n_hlsmax = ', &
& n_hlsmax
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
ENDIF
END DO
DO jn = 5, 8
IF( llrecv(jn) ) THEN ; ifill(jn) = jpfillmpi ! with an mpi communication
ELSE ; ifill(jn) = jpfillnothing! do nothing
!
! define llsend and llrecv: logicals which say if mpi-neibourgs for send or receive exist or not.
IF ( PRESENT(lsend) .AND. PRESENT(lrecv) ) THEN ! localy defined neighbourgs
llsend(:,jf) = lsend(:) ; llrecv(:,jf) = lrecv(:)
ELSE IF( PRESENT(lsend) .OR. PRESENT(lrecv) ) THEN
WRITE(ctmp1,*) TRIM(cdname), ' is calling lbc_lnk with only one of the two arguments lsend or lrecv'
CALL ctl_stop( 'STOP', ctmp1 )
ELSE ! default neighbours
llsend(:,jf) = mpiSnei(ihls,:) >= 0
IF( ll4only ) llsend(5:8,jf) = .FALSE. ! exclude corners
llrecv(:,jf) = mpiRnei(ihls,:) >= 0
IF( ll4only ) llrecv(5:8,jf) = .FALSE. ! exclude corners
ENDIF
END DO
!
! north fold treatment
IF( l_IdoNFold ) THEN
ifill_nfd = ifill(jpno) ! if we are here, this means llrecv(jpno) = .false. and l_SelfPerio(jpno) = .false.
ifill( (/jpno/) ) = jpfillnothing ! we do north fold -> do nothing for northern halo
ENDIF
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
! ! ________________________
ip0i = 0 ! im0j = inner |__|__|__________|__|__|
ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__|
im1i = ipi-2*ihls ! | | | | | |
im0i = ipi - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! |__|__|__________|__|__|
im1j = ipj-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj - ihls ! ip0j = 0 |__|__|__________|__|__|
! ! ip0i ip1i im1i im0i
! define ifill: which method should be used to fill each parts (sides+corners) of the halos
! default definition
DO jn = 1, 4 ! 4 sides
IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
ELSEIF( l_SelfPerio(jn) ) THEN ; ifill(jn,jf) = jpfillperio ! with self-periodicity
ELSEIF( PRESENT(kfillmode) ) THEN ; ifill(jn,jf) = kfillmode ! localy defined
ELSEIF( ihls == 0 ) THEN ; ifill(jn,jf) = jpfillnothing ! do nothing
ELSE ; ifill(jn,jf) = jpfillcst ! constant value (zland)
ENDIF
END DO
DO jn = 5, 8 ! 4 corners
IF( llrecv(jn,jf) ) THEN ; ifill(jn,jf) = jpfillmpi ! with an mpi communication
ELSE ; ifill(jn,jf) = jpfillnothing ! do nothing
ENDIF
END DO
!
! north fold treatment
IF( l_IdoNFold ) ifill(jpno,jf) = jpfillnothing ! we do north fold -> do nothing for northern halo
! We first define the localization and size of the parts of the array that will be sent (s), received (r)
! or used for periodocity (p). The localization is defined as "the bottom left corner - 1" in i and j directions.
! This is a shift that will be applied later in the do loops to pick-up the appropriate part of the array
!
! all definitions bellow do not refer to N[ij][se]0 so we can use it with any local value of ihls
!
! ! ________________________
ip0i = 0 ! im0j = inner |__|__|__________|__|__|
ip1i = ihls ! im1j = inner - halo |__|__|__________|__|__|
im1i = ipi(jf)-2*ihls ! | | | | | |
im0i = ipi(jf) - ihls ! | | | | | |
ip0j = 0 ! | | | | | |
ip1j = ihls ! |__|__|__________|__|__|
im1j = ipj(jf)-2*ihls ! ip1j = halo |__|__|__________|__|__|
im0j = ipj(jf) - ihls ! ip0j = 0 |__|__|__________|__|__|
! ! ip0i ip1i im1i im0i
!
! define shorter names...
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
iisz = ipi(jf)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4,jf) = (/ ihls, ihls, iisz, iisz /) ; isizei(5:8,jf) = ihls ! i- count
isizej(1:4,jf) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8,jf) = ihls ! j- count
ishtSi(1:4,jf) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8,jf) = ishtSi( iwewe,jf ) ! i- shift send data
ishtSj(1:4,jf) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8,jf) = ishtSj( issnn,jf ) ! j- shift send data
ishtRi(1:4,jf) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8,jf) = ishtRi( iwewe,jf ) ! i- shift recv data
ishtRj(1:4,jf) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8,jf) = ishtRj( issnn,jf ) ! j- shift recv data
ishtPi(1:4,jf) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8,jf) = ishtPi( iwewe,jf ) ! i- shift perio data
ishtPj(1:4,jf) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8,jf) = ishtPj( issnn,jf ) ! j- shift perio data
!
END DO ! jf
!
iwewe(:) = (/ jpwe,jpea,jpwe,jpea /) ; issnn(:) = (/ jpso,jpso,jpno,jpno /)
! sides: west east south north ; corners: so-we, so-ea, no-we, no-ea
isizei(1:4) = (/ ihls, ihls, ipi, ipi /) ; isizei(5:8) = ihls ! i- count
isizej(1:4) = (/ Nj_0, Nj_0, ihls, ihls /) ; isizej(5:8) = ihls ! j- count
ishtSi(1:4) = (/ ip1i, im1i, ip0i, ip0i /) ; ishtSi(5:8) = ishtSi( iwewe ) ! i- shift send data
ishtSj(1:4) = (/ ip1j, ip1j, ip1j, im1j /) ; ishtSj(5:8) = ishtSj( issnn ) ! j- shift send data
ishtRi(1:4) = (/ ip0i, im0i, ip0i, ip0i /) ; ishtRi(5:8) = ishtRi( iwewe ) ! i- shift received data location
ishtRj(1:4) = (/ ip1j, ip1j, ip0j, im0j /) ; ishtRj(5:8) = ishtRj( issnn ) ! j- shift received data location
ishtPi(1:4) = (/ im1i, ip1i, ip0i, ip0i /) ; ishtPi(5:8) = ishtPi( iwewe ) ! i- shift data used for periodicity
ishtPj(1:4) = (/ ip1j, ip1j, im1j, ip1j /) ; ishtPj(5:8) = ishtPj( issnn ) ! j- shift data used for periodicity
IF( narea == 1 .AND. numcom == -1 ) CALL mpp_report( cdname, SUM(ipk(:))/kfld, SUM(ipl(:))/kfld, kfld, ld_lbc = .TRUE. )
!
! -------------------------------- !
! 2. Prepare MPI exchanges !
! -------------------------------- !
!
iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! any value but each one must be different
iStag = (/ 1, 2, 3, 4, 5, 6, 7, 8 /) ! can be any value but each value must be unique
! define iRtag with the corresponding iStag, e.g. data received at west where sent at east.
iRtag(jpwe) = iStag(jpea) ; iRtag(jpea) = iStag(jpwe) ; iRtag(jpso) = iStag(jpno) ; iRtag(jpno) = iStag(jpso)
iRtag(jpsw) = iStag(jpne) ; iRtag(jpse) = iStag(jpnw) ; iRtag(jpnw) = iStag(jpse) ; iRtag(jpne) = iStag(jpsw)
!
iszall(:) = isizei(:) * isizej(:) * ipk * ipl * ipf
! size of the buffer to be sent/recv in each direction
ibufszS(:) = 0 ! defaut definition
ibufszR(:) = 0
DO jf = 1, kfld
DO jn = 1, 8
IF( llsend(jn,jf) ) ibufszS(jn) = ibufszS(jn) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
IF( llrecv(jn,jf) ) ibufszR(jn) = ibufszR(jn) + isizei(jn,jf) * isizej(jn,jf) * ipk(jf) * ipl(jf)
END DO
END DO
!
! offset to apply to find the position of the sent/recv data within the buffer
ishtS(1) = 0
DO jn = 2, 8
ishtS(jn) = ishtS(jn-1) + iszall(jn-1) * COUNT( (/llsend(jn-1)/) )
ishtS(jn) = ishtS(jn-1) + ibufszS(jn-1)
END DO
ishtR(1) = 0
DO jn = 2, 8
ishtR(jn) = ishtR(jn-1) + iszall(jn-1) * COUNT( (/llrecv(jn-1)/) )
ishtR(jn) = ishtR(jn-1) + ibufszR(jn-1)
END DO
!
! Allocate buffer arrays to be sent/received if needed
iszS = SUM(iszall, mask = llsend) ! send buffer size
iszS = SUM(ibufszS) ! send buffer size
IF( ALLOCATED(BUFFSND) ) THEN
CALL mpi_waitall(8, nreq_p2p, MPI_STATUSES_IGNORE, ierr) ! wait for Isend from the PREVIOUS call
IF( SIZE(BUFFSND) < iszS ) DEALLOCATE(BUFFSND) ! send buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFSND) ) ALLOCATE( BUFFSND(iszS) )
iszR = SUM(iszall, mask = llrecv) ! recv buffer size
iszR = SUM(ibufszR) ! recv buffer size
IF( ALLOCATED(BUFFRCV) ) THEN
IF( SIZE(BUFFRCV) < iszR ) DEALLOCATE(BUFFRCV) ! recv buffer is too small
ENDIF
IF( .NOT. ALLOCATED(BUFFRCV) ) ALLOCATE( BUFFRCV(iszR) )
!
! default definition when no communication is done. understood by mpi_waitall
! Default definition when no communication is done. Understood by mpi_waitall
nreq_p2p(:) = MPI_REQUEST_NULL ! WARNING: Must be done after the call to mpi_waitall just above
!
! ----------------------------------------------- !
......@@ -177,19 +201,28 @@
!
! ----------------------------------- !
! 4. Fill east and west halos !
! Must be done before sending data !
! data to south/north/corners !
! ----------------------------------- !
!
DO jn = 1, 2
#define BLOCK_FILL
DO jn = 1, 2 ! first: do all the non-MPI filling to give more time to MPI_RECV
#define BLOCK_FILL_nonMPI
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL_nonMPI
END DO
DO jn = 1, 2 ! next: do the MPI_RECV part
#define BLOCK_FILL_MPI_RECV
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL
#undef BLOCK_FILL_MPI_RECV
END DO
!
! ------------------------------------------------- !
! 5. Do north and south MPI_Isend if needed !
! and Specific problem in corner treatment !
! ( very rate case... ) !
! ------------------------------------------------- !
!
DO jn = 3, 4
DO jn = 3, 8
#define BLOCK_ISEND
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_ISEND
......@@ -199,44 +232,34 @@
! 6. north fold treatment !
! ------------------------------- !
!
! Must be done after receiving data from East/West neighbourgs (as it is coded in mpp_nfd, to be changed one day...)
! Do it after MPI_iSend to south/north neighbourgs so they won't wait (too much) to receive their data
! Do if before MPI_Recv from south/north neighbourgs so we have more time to receive data
! Do it after MPI_iSend to south/north/corners neighbourgs so they won't wait (too much) to receive their data
! Do if before MPI_Recv from south/north/corners neighbourgs so we will have more time to receive data
!
IF( l_IdoNFold ) THEN
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , ihls, ipf ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, ihls, ipf ) ! mpi NFold
IF( jpni == 1 ) THEN ; CALL lbc_nfd( ptab, cd_nat, psgn , kfld ) ! self NFold
ELSE ; CALL mpp_nfd( ptab, cd_nat, psgn, ifill_nfd, zland, kfld ) ! mpi NFold
ENDIF
ENDIF
!
! ------------------------------------- !
! 7. Fill south and north halos !
! ------------------------------------- !
! ------------------------------------------------ !
! 7. Fill south and north halos !
! and specific problem in corner treatment !
! ( very rate case... ) !
! ------------------------------------------------ !
!
DO jn = 3, 4
#define BLOCK_FILL
DO jn = 3, 8 ! first: do all the non-MPI filling to give more time to MPI_RECV
#define BLOCK_FILL_nonMPI
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL
#undef BLOCK_FILL_nonMPI
END DO
!
! ----------------------------------------------- !
! 8. Specific problem in corner treatment !
! ( very rate case... ) !
! ----------------------------------------------- !
!
DO jn = 5, 8
#define BLOCK_ISEND
DO jn = 3, 8 ! next: do the MPI_RECV part
#define BLOCK_FILL_MPI_RECV
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_ISEND
END DO
DO jn = 5, 8
#define BLOCK_FILL
# include "lbc_lnk_pt2pt_generic.h90"
#undef BLOCK_FILL
#undef BLOCK_FILL_MPI_RECV
END DO
!
! -------------------------------------------- !
! 9. deallocate local temporary arrays !
! 8. deallocate local temporary arrays !
! if they areg larger than jpi*jpj ! <- arbitrary max size...
! -------------------------------------------- !
!
......@@ -250,53 +273,72 @@
#endif
#if defined BLOCK_ISEND
IF( llsend(jn) ) THEN
ishti = ishtSi(jn)
ishtj = ishtSj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
idxs = idxs + 1
END DO ; END DO ; END DO ; END DO ; END DO
IF( ibufszS(jn) > 0 ) THEN ! we must send some data
DO jf = 1, kfld ! first: fill the buffer to be sent
IF( llsend(jn,jf) ) THEN
ishti = ishtSi(jn,jf)
ishtj = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
BUFFSND(idxs) = ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl)
idxs = idxs + 1
END DO ; END DO ; END DO ; END DO
ENDIF
END DO
#if ! defined key_mpi_off
IF( ln_timing ) CALL tic_tac(.TRUE.)
! non-blocking send of the west/east side using local buffer
CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), iszall(jn), MPI_TYPE, mpiSnei(ihls,jn), iStag(jn), icomm, nreq_p2p(jn), ierr )
! next: non-blocking send using local buffer. use mpiSnei(n_hlsmax,jn), see mppini
CALL MPI_ISEND( BUFFSND(ishtS(jn)+1), ibufszS(jn), MPI_TYPE, mpiSnei(n_hlsmax,jn), iStag(jn), icomm, nreq_p2p(jn), ierr )
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
ENDIF
#endif
#if defined BLOCK_FILL
ishti = ishtRi(jn)
ishtj = ishtRj(jn)
SELECT CASE ( ifill(jn) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillmpi ) ! fill with data received by MPI
#if defined BLOCK_FILL_nonMPI
DO jf = 1, kfld
IF( ifill(jn,jf) /= jpfillmpi ) THEN ! treat first all non-MPI cases
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
SELECT CASE ( ifill(jn,jf) )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillperio ) ! we will do it later
ishti2 = ishtPi(jn,jf)
ishtj2 = ishtPj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jn,jf)
ishtj2 = ishtSj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO
END SELECT
ENDIF
END DO
#endif
#if defined BLOCK_FILL_MPI_RECV
IF( ibufszR(jn) > 0 ) THEN ! we must receive some data
#if ! defined key_mpi_off
IF( ln_timing ) CALL tic_tac(.TRUE.)
! ! blocking receive of the west/east halo in local temporary arrays
CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), iszall(jn), MPI_TYPE, mpiRnei(ihls,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr )
! blocking receive in local buffer. use mpiRnei(n_hlsmax,jn), see mppini
CALL MPI_RECV( BUFFRCV(ishtR(jn)+1), ibufszR(jn), MPI_TYPE, mpiRnei(n_hlsmax,jn), iRtag(jn), icomm, MPI_STATUS_IGNORE, ierr )
IF( ln_timing ) CALL tic_tac(.FALSE.)
#endif
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr)
idxr = idxr + 1
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillperio ) ! use periodicity
ishti2 = ishtPi(jn)
ishtj2 = ishtPj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with inner domain values
ishti2 = ishtSi(jn)
ishtj2 = ishtSj(jn)
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = ptab(jf)%pt4d(ishti2+ji,ishtj2+jj,jk,jl)
END DO ; END DO ; END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ; DO jj = 1,isizej(jn) ; DO ji = 1,isizei(jn)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = zland
END DO ; END DO ; END DO ; END DO ; END DO
END SELECT
DO jf = 1, kfld
IF( ifill(jn,jf) == jpfillmpi ) THEN ! Use MPI-received data
ishti = ishtRi(jn,jf)
ishtj = ishtRj(jn,jf)
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ; DO jj = 1,isizej(jn,jf) ; DO ji = 1,isizei(jn,jf)
ptab(jf)%pt4d(ishti+ji,ishtj+jj,jk,jl) = BUFFRCV(idxr)
idxr = idxr + 1
END DO ; END DO ; END DO ; END DO
ENDIF
END DO
ENDIF
#endif
src/OCE/LBC/lbc_nfd_generic.h90
View file @ c72255b2
SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, khls, kfld )
SUBROUTINE lbc_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfld )
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
!
INTEGER :: ji, jj, jk, jl, jf ! dummy loop indices
INTEGER :: ipi, ipj, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ipi, ipj, ipk, ipl, ihls ! dimension of the input array
INTEGER :: ii1, ii2, ij1, ij2
!!----------------------------------------------------------------------
!
ipi = SIZE(ptab(1)%pt4d,1)
ipj = SIZE(ptab(1)%pt4d,2)
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
DO jf = 1, kfld ! Loop on the number of arrays to be treated
!
IF( ipi /= Ni0glo+2*khls ) THEN
WRITE(ctmp1,*) 'lbc_nfd input array does not match khls', ipi, khls, Ni0glo
CALL ctl_stop( 'STOP', ctmp1 )
ENDIF
!
DO jf = 1, ipf ! Loop on the number of arrays to be treated
ipi = SIZE(ptab(jf)%pt4d,1)
ipj = SIZE(ptab(jf)%pt4d,2)
ipk = SIZE(ptab(jf)%pt4d,3)
ipl = SIZE(ptab(jf)%pt4d,4)
!
ihls = ( ipi - Ni0glo ) / 2
!
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
!
......@@ -30,160 +25,162 @@
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls+1
ii1 = khls + ji
DO ji = 1, 1 ! point ihls+1
ii1 = ihls + ji
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2
DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls + 1
ii1 = ipi - khls + ji
ii2 = khls + ji
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
ii1 = ipi - ihls + ji
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls-1 ! last khls-1 points
ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi
ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2
DO ji = 1, ihls-1 ! last ihls-1 points
ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - khls - 1) + 1 = ipi - khls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls - 1) + 1 = khls + 2
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji + 1 ! ends at: ipi/2 + (ipi/2 - ihls - 1) + 1 = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls - 1) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-khls
ii1 = ji ! ends at: khls
ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls-1 points: have been / will done by e-w periodicity
! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
END DO ; END DO
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-khls
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls-1 points: have been / will done by e-w periodicity
! ! last ihls-1 points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
END DO ; END DO
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls+1 lines (from ipj to ipj-khls) : full
DO jj = 1, khls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls
ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1
! last ihls+1 lines (from ipj to ipj-ihls) : full
DO jj = 1, ihls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 2 - ji ! ends at: 2*khls + 2 - khls = khls + 2
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 2 - ji ! ends at: 2*ihls + 2 - ihls = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls+1
ii1 = khls + ji
DO ji = 1, 1 ! point ihls+1
ii1 = ihls + ji
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+2 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = 2 + khls + ji - 1 ! ends at: 2 + khls + ipi - 2*khls - 1 - 1 = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) + 1 = khls + 2
DO ji = 1, Ni0glo - 1 ! points from ihls+2 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = 2 + ihls + ji - 1 ! ends at: 2 + ihls + ipi - 2*ihls - 1 - 1 = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) + 1 = ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls + 1
ii1 = ipi - khls + ji
ii2 = khls + ji
IF( ihls > 0 ) THEN
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ipi - ihls + 1
ii1 = ipi - ihls + ji
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls-1 ! last khls-1 points
ii1 = ipi - khls + 1 + ji ! ends at: ipi - khls + 1 + khls - 1 = ipi
ii2 = ipi - khls + 1 - ji ! ends at: ipi - khls + 1 - khls + 1 = ipi - 2*khls + 2
ENDIF
DO ji = 1, ihls-1 ! last ihls-1 points
ii1 = ipi - ihls + 1 + ji ! ends at: ipi - ihls + 1 + ihls - 1 = ipi
ii2 = ipi - ihls + 1 - ji ! ends at: ipi - ihls + 1 - ihls + 1 = ipi - 2*ihls + 2
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
END DO; END DO
END DO ; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls+1 lines (from ipj to ipj-khls) : full
DO jj = 1, khls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( khls + 1 ) + 1 = ipj - khls
ij2 = ipj - 2*khls + jj - 2 ! ends at: ipj - 2*khls + khls + 1 - 2 = ipj - khls - 1
! last ihls+1 lines (from ipj to ipj-ihls) : full
DO jj = 1, ihls+1
ij1 = ipj - jj + 1 ! ends at: ipj - ( ihls + 1 ) + 1 = ipj - ihls
ij2 = ipj - 2*ihls + jj - 2 ! ends at: ipj - 2*ihls + ihls + 1 - 2 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
......@@ -199,9 +196,9 @@
CASE ( 'T' , 'W' ) ! T-, W-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! first: line number ipj-khls : 3 points
! first: line number ipj-ihls : 3 points
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, 1 ! points from ipi/2+1
......@@ -209,37 +206,37 @@
ii2 = ipi/2 - ji + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
END DO
DO ji = 1, 1 ! points ipi - khls
ii1 = ipi - khls + ji - 1
ii2 = khls + ji
DO ji = 1, 1 ! points ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
END DO
DO ji = 1, 1 ! point khls: redo it just in case (if e-w periodocity already done)
! ! as we just changed point ipi - khls
ii1 = khls + ji - 1
ii2 = khls + ji
DO ji = 1, COUNT( (/ihls > 0/) ) ! point ihls: redo it just in case (if e-w periodocity already done)
! ! as we just changed point ipi - ihls
ii1 = ihls + ji - 1
ii2 = ihls + ji
ptab(jf)%pt4d(ii1,ij1,jk,jl) = ptab(jf)%pt4d(ii2,ij2,jk,jl) ! Warning: pb with sign...
END DO
END DO
!
! Second: last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls
ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls
! Second: last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
......@@ -248,34 +245,34 @@
CASE ( 'U' ) ! U-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - khls
ij2 = ipj - 2*khls + jj ! ends at: ipj - 2*khls + khls = ipj - khls
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj + 1 - jj ! ends at: ipj + 1 - ihls
ij2 = ipj - 2*ihls + jj ! ends at: ipj - 2*ihls + ihls = ipj - ihls
!
DO ji = 1, khls-1 ! first khls-1 points
ii1 = ji ! ends at: khls-1
ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
DO ji = 1, ihls-1 ! first ihls-1 points
ii1 = ji ! ends at: ihls-1
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls
ii1 = khls + ji - 1
DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1
ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1
DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls
ii1 = ipi - khls + ji - 1
DO ji = 1, 1 ! point ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
......@@ -284,100 +281,100 @@
CASE ( 'V' ) ! V-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls ! first khls points
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo ! points from khls to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ipi - 2*khls = ipi - khls
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls - ( ipi - 2*khls ) + 1 = khls + 1
DO ji = 1, Ni0glo ! points from ihls to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ipi - 2*ihls = ipi - ihls
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls - ( ipi - 2*ihls ) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji + 1 ! ends at: ipi - khls + 1 - khls = ipi - 2*khls + 1
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji + 1 ! ends at: ipi - ihls + 1 - ihls = ipi - 2*ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - khls (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - khls) + 1 = khls + 1
DO ji = 1, Ni0glo/2 ! points from ipi/2+1 to ipi - ihls (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji + 1 ! ends at: ipi/2 - (ipi/2 - ihls) + 1 = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! first khls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-khls
ii1 = ji ! ends at: khls
ii2 = 2*khls + 1 - ji ! ends at: 2*khls + 1 - khls = khls + 1
DO ji = 1, ihls ! first ihls points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-ihls
ii1 = ji ! ends at: ihls
ii2 = 2*ihls + 1 - ji ! ends at: 2*ihls + 1 - ihls = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls points: have been / will done by e-w periodicity
! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
CASE ( 'F' ) ! F-point
DO jl = 1, ipl ; DO jk = 1, ipk
!
! last khls lines (from ipj to ipj-khls+1) : full
DO jj = 1, khls
ij1 = ipj - jj + 1 ! ends at: ipj - khls + 1
ij2 = ipj - 2*khls + jj - 1 ! ends at: ipj - 2*khls + khls - 1 = ipj - khls - 1
! last ihls lines (from ipj to ipj-ihls+1) : full
DO jj = 1, ihls
ij1 = ipj - jj + 1 ! ends at: ipj - ihls + 1
ij2 = ipj - 2*ihls + jj - 1 ! ends at: ipj - 2*ihls + ihls - 1 = ipj - ihls - 1
!
DO ji = 1, khls-1 ! first khls-1 points
ii1 = ji ! ends at: khls-1
ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
DO ji = 1, ihls-1 ! first ihls-1 points
ii1 = ji ! ends at: ihls-1
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point khls
ii1 = khls + ji - 1
DO ji = 1, 1 ! point ihls (here ihls > 0 so it is ok)
ii1 = ihls + ji - 1
ii2 = ipi - ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, Ni0glo - 1 ! points from khls+1 to ipi - khls - 1 (note: Ni0glo = ipi - 2*khls)
ii1 = khls + ji ! ends at: khls + ( ipi - 2*khls - 1 ) = ipi - khls - 1
ii2 = ipi - khls - ji ! ends at: ipi - khls - ( ipi - 2*khls - 1 ) = khls + 1
DO ji = 1, Ni0glo - 1 ! points from ihls+1 to ipi - ihls - 1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ihls + ji ! ends at: ihls + ( ipi - 2*ihls - 1 ) = ipi - ihls - 1
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ( ipi - 2*ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, 1 ! point ipi - khls
ii1 = ipi - khls + ji - 1
DO ji = 1, 1 ! point ipi - ihls
ii1 = ipi - ihls + ji - 1
ii2 = ii1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls ! last khls points
ii1 = ipi - khls + ji ! ends at: ipi - khls + khls = ipi
ii2 = ipi - khls - ji ! ends at: ipi - khls - khls = ipi - 2*khls
DO ji = 1, ihls ! last ihls points
ii1 = ipi - ihls + ji ! ends at: ipi - ihls + ihls = ipi
ii2 = ipi - ihls - ji ! ends at: ipi - ihls - ihls = ipi - 2*ihls
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
!
! line number ipj-khls : right half
! line number ipj-ihls : right half
DO jj = 1, 1
ij1 = ipj - khls
ij1 = ipj - ihls
ij2 = ij1 ! same line
!
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - khls-1 (note: Ni0glo = ipi - 2*khls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - khls) = ipi - khls
ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - khls - 1 ) = khls + 1
DO ji = 1, Ni0glo/2-1 ! points from ipi/2+1 to ipi - ihls-1 (note: Ni0glo = ipi - 2*ihls)
ii1 = ipi/2 + ji ! ends at: ipi/2 + (ipi/2 - ihls) = ipi - ihls
ii2 = ipi/2 - ji ! ends at: ipi/2 - (ipi/2 - ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = 1, khls-1 ! first khls-1 points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2khls+1 to ipi-nn_hl-1
ii1 = ji ! ends at: khls
ii2 = 2*khls - ji ! ends at: 2*khls - ( khls - 1 ) = khls + 1
DO ji = 1, ihls-1 ! first ihls-1 points: redo them just in case (if e-w periodocity already done)
! ! as we just changed points ipi-2ihls+1 to ipi-nn_hl-1
ii1 = ji ! ends at: ihls
ii2 = 2*ihls - ji ! ends at: 2*ihls - ( ihls - 1 ) = ihls + 1
ptab(jf)%pt4d(ii1,ij1,jk,jl) = psgn(jf) * ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
! ! last khls points: have been / will done by e-w periodicity
! ! last ihls points: have been or will be done by e-w periodicity
END DO
!
END DO; END DO
......@@ -385,7 +382,7 @@
!
ENDIF ! c_NFtype == 'F'
!
END DO ! ipf
END DO ! kfld
!
END SUBROUTINE lbc_nfd_/**/PRECISION
src/OCE/LBC/lbclnk.F90
View file @ c72255b2
......@@ -38,11 +38,9 @@ MODULE lbclnk
MODULE PROCEDURE lbc_lnk_pt2pt_sp, lbc_lnk_pt2pt_dp
END INTERFACE
#if ! defined key_mpi2
INTERFACE lbc_lnk_neicoll
MODULE PROCEDURE lbc_lnk_neicoll_sp ,lbc_lnk_neicoll_dp
END INTERFACE
#endif
!
INTERFACE lbc_lnk_icb
MODULE PROCEDURE mpp_lnk_2d_icb_dp, mpp_lnk_2d_icb_sp
......@@ -51,10 +49,10 @@ MODULE lbclnk
PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions
PUBLIC lbc_lnk_icb ! iceberg lateral boundary conditions
REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers
REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp !
INTEGER, DIMENSION(8) :: nreq_p2p ! request id for MPI_Isend in point-2-point communication
REAL(dp), DIMENSION(:), ALLOCATABLE :: buffsnd_dp, buffrcv_dp ! MPI send/recv buffers
REAL(sp), DIMENSION(:), ALLOCATABLE :: buffsnd_sp, buffrcv_sp !
INTEGER, DIMENSION(8) :: nreq_p2p = MPI_REQUEST_NULL ! request id for MPI_Isend in point-2-point communication
INTEGER :: nreq_nei = MPI_REQUEST_NULL ! request id for mpi_neighbor_ialltoallv
!! * Substitutions
!!# include "do_loop_substitute.h90"
!!----------------------------------------------------------------------
......@@ -134,9 +132,7 @@ CONTAINS
# define BUFFSND buffsnd_sp
# define BUFFRCV buffrcv_sp
# include "lbc_lnk_pt2pt_generic.h90"
#if ! defined key_mpi2
# include "lbc_lnk_neicoll_generic.h90"
#endif
# undef MPI_TYPE
# undef BUFFSND
# undef BUFFRCV
......@@ -149,9 +145,7 @@ CONTAINS
# define BUFFSND buffsnd_dp
# define BUFFRCV buffrcv_dp
# include "lbc_lnk_pt2pt_generic.h90"
#if ! defined key_mpi2
# include "lbc_lnk_neicoll_generic.h90"
#endif
# undef MPI_TYPE
# undef BUFFSND
# undef BUFFRCV
......
src/OCE/LBC/lbcnfd.F90
View file @ c72255b2
......@@ -23,8 +23,11 @@ MODULE lbcnfd
PRIVATE
INTERFACE lbc_nfd ! called by mpp_nfd, lbc_lnk_pt2pt or lbc_lnk_neicoll
MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_ext_sp
MODULE PROCEDURE lbc_nfd_dp, lbc_nfd_ext_dp
MODULE PROCEDURE lbc_nfd_sp, lbc_nfd_dp
END INTERFACE
INTERFACE lbc_nfd_ext ! called by mpp_lnk_2d_icb
MODULE PROCEDURE lbc_nfd_ext_sp, lbc_nfd_ext_dp
END INTERFACE
INTERFACE mpp_nfd ! called by lbc_lnk_pt2pt or lbc_lnk_neicoll
......@@ -33,11 +36,13 @@ MODULE lbcnfd
PUBLIC mpp_nfd ! mpi north fold conditions
PUBLIC lbc_nfd ! north fold conditions
PUBLIC lbc_nfd_ext ! north fold conditions, called by mpp_lnk_2d_icb
INTEGER, PUBLIC :: nfd_nbnei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_rksnd
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:) :: nfd_jisnd
INTEGER, PUBLIC :: nfd_nbnei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (: ) :: nfd_rknei
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:,:) :: nfd_rksnd
INTEGER, PUBLIC, ALLOCATABLE, DIMENSION (:,:,:) :: nfd_jisnd
LOGICAL, PUBLIC, ALLOCATABLE, DIMENSION (:,: ) :: lnfd_same
!!----------------------------------------------------------------------
!! NEMO/OCE 4.0 , NEMO Consortium (2018)
......
src/OCE/LBC/lib_mpp.F90
View file @ c72255b2
......@@ -142,10 +142,10 @@ MODULE lib_mpp
INTEGER :: MPI_SUMDD
! Neighbourgs informations
INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 3
INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg)
INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg)
INTEGER, DIMENSION(n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg)
INTEGER, PARAMETER, PUBLIC :: n_hlsmax = 2
INTEGER, DIMENSION( 8), PUBLIC :: mpinei !: 8-neighbourg MPI indexes (starting at 0, -1 if no neighbourg)
INTEGER, DIMENSION(0:n_hlsmax,8), PUBLIC :: mpiSnei !: 8-neighbourg Send MPI indexes (starting at 0, -1 if no neighbourg)
INTEGER, DIMENSION(0:n_hlsmax,8), PUBLIC :: mpiRnei !: 8-neighbourg Recv MPI indexes (starting at 0, -1 if no neighbourg)
INTEGER, PARAMETER, PUBLIC :: jpwe = 1 !: WEst
INTEGER, PARAMETER, PUBLIC :: jpea = 2 !: EAst
INTEGER, PARAMETER, PUBLIC :: jpso = 3 !: SOuth
......@@ -1127,7 +1127,7 @@ CONTAINS
INTEGER :: ierr
LOGICAL, PARAMETER :: ireord = .FALSE.
!!----------------------------------------------------------------------
#if ! defined key_mpi_off && ! defined key_mpi2
#if ! defined key_mpi_off
iScnt4 = COUNT( mpiSnei(khls,1:4) >= 0 )
iRcnt4 = COUNT( mpiRnei(khls,1:4) >= 0 )
......@@ -1141,10 +1141,19 @@ CONTAINS
iSnei8 = PACK( mpiSnei(khls,1:8), mask = mpiSnei(khls,1:8) >= 0 )
iRnei8 = PACK( mpiRnei(khls,1:8), mask = mpiRnei(khls,1:8) >= 0 )
! Isolated processes (i.e., processes WITH no outgoing or incoming edges, that is, processes that have specied
! indegree and outdegree as zero and thus DO not occur as source or destination rank in the graph specication)
! are allowed.
# if ! defined key_mpi2
CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt4, iSnei4, MPI_UNWEIGHTED, iRcnt4, iRnei4, MPI_UNWEIGHTED, &
& MPI_INFO_NULL, ireord, mpi_nc_com4(khls), ierr )
CALL MPI_Dist_graph_create_adjacent( mpi_comm_oce, iScnt8, iSnei8, MPI_UNWEIGHTED, iRcnt8, iRnei8, MPI_UNWEIGHTED, &
& MPI_INFO_NULL, ireord, mpi_nc_com8(khls), ierr)
# else
mpi_nc_com4(khls) = -1
mpi_nc_com8(khls) = -1
# endif
DEALLOCATE( iSnei4, iRnei4, iSnei8, iRnei8 )
#endif
......@@ -1307,7 +1316,7 @@ CONTAINS
IF ( ncomm_sequence(ji,1) .GT. 1 .AND. ncomm_sequence(ji,2) .GT. 1 ) jj = jj + 1
jh = MAX (jh, ncomm_sequence(ji,1)*ncomm_sequence(ji,2))
END DO
WRITE(numcom,'(A,I3)') ' 3D Exchanged halos : ', jk
WRITE(numcom,'(A,I3)') ' 3D or 4D Exchanged halos : ', jk
WRITE(numcom,'(A,I3)') ' Multi arrays exchanged halos : ', jf
WRITE(numcom,'(A,I3)') ' from which 3D : ', jj
WRITE(numcom,'(A,I10)') ' Array max size : ', jh*jpi*jpj
......
src/OCE/LBC/mpp_lbc_north_icb_generic.h90
View file @ c72255b2
......@@ -92,7 +92,7 @@
! 2. North-Fold boundary conditions
! ----------------------------------
CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
CALL lbc_nfd_ext( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
ij = 1 - kextj
!! Scatter back to pt2d
......
src/OCE/LBC/mpp_lnk_icb_generic.h90
View file @ c72255b2
......@@ -87,7 +87,7 @@
IF( l_IdoNFold ) THEN
!
SELECT CASE ( jpni )
CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
CASE ( 1 ) ; CALL lbc_nfd_ext ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
CASE DEFAULT ; CALL LBCNORTH ( pt2d(1:jpi,1:jpj+kextj), cd_type, psgn, kextj )
END SELECT
!
......
src/OCE/LBC/mpp_loc_generic.h90
View file @ c72255b2
......@@ -47,6 +47,7 @@
!
INTEGER :: ierror, ii, idim
INTEGER :: index0
INTEGER :: ihls, ipiglo, ipjglo
INTEGER , DIMENSION(:), ALLOCATABLE :: ilocs
REAL(PRECISION) :: zmin ! local minimum
REAL(PRECISION), DIMENSION(2,1) :: zain, zaout
......@@ -60,6 +61,9 @@
ENDIF
!
idim = SIZE(kindex)
ihls = ( SIZE(ARRAY_IN(:,:,:), 1) - Ni_0 ) / 2
ipiglo = Ni0glo + 2*ihls
ipjglo = Nj0glo + 2*ihls
!
IF ( ANY( MASK_IN(:,:,:) ) ) THEN ! there is at least 1 valid point...
!
......@@ -68,9 +72,9 @@
ilocs = LOC_OPERATION( ARRAY_IN(:,:,:) , mask= MASK_IN(:,:,:) )
zmin = ARRAY_IN(ilocs(1),ilocs(2),ilocs(3))
!
kindex(1) = mig( ilocs(1) )
kindex(1) = mig( ilocs(1), ihls )
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
kindex(2) = mjg( ilocs(2) )
kindex(2) = mjg( ilocs(2), ihls )
#endif
#if defined DIM_3d /* avoid warning when kindex has 2 elements */
kindex(3) = ilocs(3)
......@@ -80,10 +84,10 @@
!
index0 = kindex(1)-1 ! 1d index starting at 0
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
index0 = index0 + jpiglo * (kindex(2)-1)
index0 = index0 + ipiglo * (kindex(2)-1)
#endif
#if defined DIM_3d /* avoid warning when kindex has 2 elements */
index0 = index0 + jpiglo * jpjglo * (kindex(3)-1)
index0 = index0 + ipiglo * ipjglo * (kindex(3)-1)
#endif
ELSE
! special case for land processors
......@@ -105,20 +109,20 @@
pmin = zaout(1,1)
index0 = NINT( zaout(2,1) )
#if defined DIM_3d /* avoid warning when kindex has 2 elements */
kindex(3) = index0 / (jpiglo*jpjglo)
index0 = index0 - kindex(3) * (jpiglo*jpjglo)
kindex(3) = index0 / (ipiglo*ipjglo)
index0 = index0 - kindex(3) * (ipiglo*ipjglo)
#endif
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
kindex(2) = index0 / jpiglo
index0 = index0 - kindex(2) * jpiglo
kindex(2) = index0 / ipiglo
index0 = index0 - kindex(2) * ipiglo
#endif
kindex(1) = index0
kindex(:) = kindex(:) + 1 ! start indices at 1
IF( .NOT. llhalo ) THEN
kindex(1) = kindex(1) - nn_hls
kindex(1) = kindex(1) - ihls
#if defined DIM_2d || defined DIM_3d /* avoid warning when kindex has 1 element */
kindex(2) = kindex(2) - nn_hls
kindex(2) = kindex(2) - ihls
#endif
ENDIF
......
src/OCE/LBC/mpp_nfd_generic.h90
View file @ c72255b2
SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld )
SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, kfld )
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
CHARACTER(len=1), DIMENSION(kfld), INTENT(in ) :: cd_nat ! nature of array grid-points
REAL(PRECISION), DIMENSION(kfld), INTENT(in ) :: psgn ! sign used across the north fold boundary
INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
!
LOGICAL :: ll_add_line
INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices
INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ierr, ibuffsize, iis0, iie0, impp
INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin
INTEGER :: i0max
INTEGER :: ij, iproc, ipni, ijnr
INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather
INTEGER :: ipjtot ! sum of lines for all multi fields
INTEGER :: i012 ! 0, 1 or 2
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend
INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field
REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays
REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays
REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc
REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo
TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c.
INTEGER :: ierr, ibuffsize, impp, ipi0
INTEGER :: ii1, ii2, ij1, ij2, ij3, iig, inei
INTEGER :: i0max, ilntot, iisht, ijsht, ihsz
INTEGER :: iproc, ijnr, ipjtot, iFT, iFU, i012
INTEGER, DIMENSION(kfld) :: ipi, ipj, ipj1, ipj2, ipk, ipl ! dimension of the input array
INTEGER, DIMENSION(kfld) :: ihls ! halo size
INTEGER, DIMENSION(:) , ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather
INTEGER, DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field
REAL(PRECISION) :: zhuge, zztmp
REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays
REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: zbufr ! buffer, receive and work arrays
REAL(PRECISION), DIMENSION(:,:) , ALLOCATABLE :: znorthloc
REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE :: znorthall
TYPE(PTR_4D_/**/PRECISION), DIMENSION(1) :: ztabglo ! array or pointer of arrays on which apply the b.c.
!!----------------------------------------------------------------------
!
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
zhuge = HUGE(0._/**/PRECISION) ! avoid to call the huge function inside do loops
!
DO jf = 1, kfld
ipi(jf) = SIZE(ptab(jf)%pt4d,1)
ipj(jf) = SIZE(ptab(jf)%pt4d,2)
ipk(jf) = SIZE(ptab(jf)%pt4d,3)
ipl(jf) = SIZE(ptab(jf)%pt4d,4)
ihls(jf) = ( ipi(jf) - Ni_0 ) / 2
END DO
!
IF( ln_nnogather ) THEN !== no allgather exchanges ==!
......@@ -61,74 +62,43 @@
! also force it if not restart during the first 2 steps (leap frog?)
ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart )
ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field?
ALLOCATE(ipjfld(kfld)) ! how many lines do we send for each field?
IF( ll_add_line ) THEN
DO jf = 1, ipf ! Loop over the number of arrays to be processed
ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )
DO jf = 1, kfld ! Loop over the number of arrays to be processed
ipjfld(jf) = ihls(jf) + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) &
& + COUNT( (/ c_NFtype == 'F' .AND. cd_nat(jf) == 'T' .AND. ihls(jf) == 0 /) )
END DO
ELSE
ipjfld(:) = khls
ipjfld(:) = ihls(:)
ENDIF
ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers
ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged
! Index of modifying lines in input
ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) )
ij1 = 0
DO jf = 1, ipf ! Loop over the number of arrays to be processed
!
DO jj = 1, khls ! first khls lines (starting from top) must be fully defined
ii1st(jj, jf) = 1
iiend(jj, jf) = jpi
END DO
!
! what do we do with line khls+1 (starting from top)
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
SELECT CASE ( cd_nat(jf) )
CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls)
CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls)
CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi
CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi
END SELECT
ENDIF
IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
SELECT CASE ( cd_nat(jf) )
CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1
CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1
CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls )
CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1)
END SELECT
ENDIF
!
DO jj = 1, ipjfld(jf)
ij1 = ij1 + 1
ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines)
ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers
ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj)
END DO
!
END DO
!
i0max = jpimax - 2 * khls ! we are not sending the halos
ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array
ibuffsize = i0max * ipjtot * ipk * ipl
i0max = MAXVAL( nfni_0, mask = nfproc /= -1 ) ! largest value of Ni_0 among processors (we are not sending halos)
ilntot = SUM( ipjfld(:) * ipk(:) * ipl(:) )
ALLOCATE( zbufs(i0max,ilntot), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array
ibuffsize = i0max * ilntot ! must be the same for all processors -> use i0max
!
! fill the send buffer with all the lines
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipjfld(jf)
ij1 = ijbuf(jj,jf)
ij2 = ijsnd(jj,jf)
DO ji = Nis0, Nie0 ! should not use any other value
iib = ji - Nis0 + 1
zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl)
END DO
DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it)
zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! make sure we don't use it...
ij1 = 0
DO jf = 1, kfld
!
i012 = COUNT( (/ c_NFtype == 'T' /) ) + COUNT( (/ cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) &
& + COUNT( (/ ihls(jf) == 0 .AND. cd_nat(jf) == 'T' .AND. c_NFtype == 'F' /) ) ! 0, 1 OR 2
ijsht = ipj(jf) - 2*ihls(jf) - i012 ! j-position of the sent lines (from bottom of sent lines)
!
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
DO jj = 1, ipjfld(jf)
ij1 = ij1 + 1
ij2 = jj + ijsht
DO ji = 1, Ni_0 ! use only inner domain
ii2 = ji + ihls(jf)
zbufs(ji,ij1) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = Ni_0+1, i0max ! avoid sending uninitialized values and make sure we don't use it
zbufs(ji,ij1) = zhuge
END DO
END DO
END DO
END DO ; END DO ; END DO
END DO ; END DO
END DO ! jf
!
! start waiting time measurement
IF( ln_timing ) CALL tic_tac(.TRUE.)
......@@ -136,68 +106,62 @@
! send the same buffer data to all neighbourgs as soon as possible
DO jn = 1, nfd_nbnei
iproc = nfd_rknei(jn)
IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN ! it is neither me nor a land-only neighbourg
#if ! defined key_mpi_off
CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr )
#endif
ELSE
ireq_s(jn) = MPI_REQUEST_NULL
ireq_s(jn) = MPI_REQUEST_NULL ! must be defined for mpi_waitall
ENDIF
END DO
!
ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) )
ALLOCATE( zbufr(i0max,ilntot,nfd_nbnei), ireq_r(nfd_nbnei) )
!
DO jn = 1, nfd_nbnei
!
DO jn = 1, nfd_nbnei ! 1st loop: first get data which does not need any communication
! ! -> this gives more time to receive the communications
iproc = nfd_rknei(jn)
!
IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
IF( iproc == -1 ) THEN ! No neighbour (land-only neighbourg that was suppressed)
!
ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received
zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION) ! default: define it and make sure we don't use it...
ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received, must be defined for mpi_waitall
SELECT CASE ( kfillmode )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillcopy ) ! filling with inner domain values
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipjfld(jf)
ij1 = ijbuf(jj,jf)
ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom
zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point
END DO
END DO ; END DO ; END DO
CASE ( jpfillcopy ) ! filling with my inner domain values
! ! trick: we use only the 1st value, see init_nfdcom
zbufr(1,:,jn) = zbufs(1,:) ! chose to take the 1st inner domain point
CASE ( jpfillcst ) ! filling with constant value
zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom
zbufr(1,:,jn) = pfillval ! trick: we use only the 1st value, see init_nfdcom
END SELECT
!
ELSE IF( iproc == narea-1 ) THEN ! get data from myself!
ELSE IF( iproc == narea-1 ) THEN ! I get data from myself!
!
ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipjfld(jf)
ij1 = ijbuf(jj,jf)
ij2 = ijsnd(jj,jf)
DO ji = Nis0, Nie0 ! should not use any other value
iib = ji - Nis0 + 1
zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl)
END DO
END DO
END DO ; END DO ; END DO
ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received, must be defined for mpi_waitall
zbufr(:,:,jn) = zbufs(:,:) ! we can directly do: received buffer = sent buffer!
!
ELSE ! get data from a neighbour trough communication
ENDIF
!
END DO ! nfd_nbnei
!
DO jn = 1, nfd_nbnei ! 2nd loop: now get data from a neighbour trough communication
!
iproc = nfd_rknei(jn)
IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN ! it is neither me nor a land-only neighbourg
#if ! defined key_mpi_off
CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr )
CALL MPI_Irecv( zbufr(:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr )
#endif
ENDIF
!
END DO ! nfd_nbnei
!
#if ! defined key_mpi_off
CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv
#endif
!
IF( ln_timing ) CALL tic_tac(.FALSE.)
!
! North fold boundary condition
! Apply the North pole folding
!
DO jf = 1, ipf
ij2 = 0
DO jf = 1, kfld
!
SELECT CASE ( cd_nat(jf) ) ! which grid number?
CASE ('T','W') ; iig = 1 ! T-, W-point
......@@ -206,76 +170,43 @@
CASE ('F') ; iig = 4 ! F-point
END SELECT
!
DO jl = 1, ipl ; DO jk = 1, ipk
!
! if T point with F-point pivot : must be done first
! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless)
IF( c_NFtype == 'F' .AND. iig == 1 ) THEN
ij1 = jpj - khls ! j-index in the receiving array
ij2 = 1 ! only 1 line in the buffer
DO ji = mi0(khls), mi1(khls) ! change because of EW periodicity as we also change jpiglo-khls
iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer
iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
END DO
DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1)
iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer
iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
END DO
DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls)
iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer
iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
END DO
ENDIF
ihsz = ihls(jf) ! shorter name
iisht = nn_hls - ihsz
iFT = COUNT( (/ ihsz > 0 .AND. c_NFtype == 'F' .AND. cd_nat(jf) == 'T' /) ) ! F-folding and T grid
!
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
!
! Apply the North pole folding.
DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field
ij1 = ijrcv(jj,jf) ! j-index in the receiving array
ij2 = ijbuf(jj,jf) ! j-index in the buffer
iis = ii1st(jj,jf) ! stating i-index in the receiving array
iie = iiend(jj,jf) ! ending i-index in the receiving array
DO ji = iis, iie
iib = nfd_jisnd(ji,iig) ! i-index in the buffer
iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin)
DO jj = 1,ihsz ! NP folding for the last ihls(jf) lines of this field
ij1 = ipj(jf) - jj + 1 ! j-index in the receiving array (from the top -> reverse order for jj)
ij2 = ij2 + 1
ij3 = ihsz+1 - jj + 1
DO ji = 1, ipi(jf)
ii1 = ji + iisht
inei = nfd_rksnd(ii1,ij3,iig) ! neigbhour-index in the buffer
IF( nfd_rknei(inei) == -1 .AND. kfillmode == jpfillnothing ) CYCLE ! no neighbourg and do nothing to fill
ii2 = nfd_jisnd(ii1,ij3,iig) ! i-index in the buffer, starts at 1 in the inner domain
ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(ii2,ij2,inei)
END DO
END DO
!
! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line)
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo
ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged
ENDIF
ENDIF
IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do
ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo
ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1
ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do
ENDIF
ENDIF
jj = ipjfld(jf) ! only for the last line of this field
ij1 = ijrcv(jj,jf) ! j-index in the receiving array
ij2 = ijbuf(jj,jf) ! j-index in the buffer
DO ji = iis, iie
iib = nfd_jisnd(ji,iig) ! i-index in the buffer
iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin)
DO jj = ihsz+1, ipjfld(jf)+iFT ! NP folding for line ipj-ihsz that can be partially modified
ij1 = ipj(jf) - jj + 1 ! j-index in the receiving array (from the top -> reverse order for jj)
ij2 = ij2 + 1 - iFT
ij3 = 1
DO ji = 1, ipi(jf)
ii1 = ji + iisht
IF( lnfd_same(ii1,iig) ) CYCLE ! do nothing if should not be modified
inei = nfd_rksnd(ii1,ij3,iig) ! neigbhour-index in the buffer
IF( nfd_rknei(inei) == -1 .AND. kfillmode == jpfillnothing ) CYCLE ! no neighbourg and do nothing to fill
ii2 = nfd_jisnd(ii1,ij3,iig) ! i-index in the buffer, starts at 1 in the inner domain
ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(ii2,ij2,inei)
END DO
END DO
!
END DO ; END DO ! ipl ; ipk
END DO ; END DO ! jk ; jl
!
END DO ! ipf
END DO ! jf
!
DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld )
DEALLOCATE( zbufr, ireq_r, ipjfld )
!
CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend
!
......@@ -283,114 +214,128 @@
!
ELSE !== allgather exchanges ==!
!
! how many lines do we exchange at max? -> ipj (no further optimizations in this case...)
ipj = khls + 2
! how many lines do we need at max? -> ipj2 (no further optimizations in this case...)
ipj2 = 2 * khls + 2
DO jf = 1, kfld
! how many lines do we send for each field?
ipj1(jf) = ihls(jf) + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) &
& + COUNT( (/ c_NFtype == 'F' .AND. cd_nat(jf) == 'T' .AND. ihls(jf) == 0 /) )
! how many lines do we need for each field?
ipj2(jf) = 2 * ihls(jf) + COUNT( (/ c_NFtype == 'T' /) ) + COUNT( (/ cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) ) &
& + COUNT( (/ c_NFtype == 'F' .AND. cd_nat(jf) == 'T' .AND. ihls(jf) == 0 /) )
END DO
!
i0max = jpimax - 2 * khls
ibuffsize = i0max * ipj * ipk * ipl * ipf
ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) )
i0max = MAXVAL( nfni_0, mask = nfproc /= -1 ) ! largest value of Ni_0 among processors (we are not sending halos)
ibuffsize = i0max * SUM( ipj1(:) * ipk(:) * ipl(:) ) ! use i0max because each proc must have the same buffer size
ALLOCATE( znorthloc(i0max, ibuffsize/i0max), znorthall(i0max, ibuffsize/i0max, ndim_rank_north) )
!
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab
DO jj = 1, ipj
ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
ij1 = 0 ! initalize line index
DO jf = 1, kfld ; DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
DO jj = 1, ipj1(jf) ! put in znorthloc ipj1(jf) j-lines of ptab
ij2 = ipj(jf) - ipj2(jf) + jj ! the first ipj1 lines of the last ipj2 lines
ij1 = ij1 + 1
DO ji = 1, Ni_0
ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0
znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
ii2 = ihls(jf) + ji ! copy only the inner domain
znorthloc(ji,ij1) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = Ni_0+1, i0max
znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it)
DO ji = Ni_0+1, i0max ! avoid to send uninitialized values
znorthloc(ji,ij1) = zhuge ! and make sure we don't use it
END DO
END DO
END DO ; END DO ; END DO
!
! start waiting time measurement
IF( ln_timing ) CALL tic_tac(.TRUE.)
#if ! defined key_mpi_off
CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr )
IF( ln_timing ) CALL tic_tac( .TRUE.) ! start waiting time measurement
! fill znorthall with the znorthloc of each northern process
CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthall, ibuffsize, MPI_TYPE, ncomm_north, ierr )
IF( ln_timing ) CALL tic_tac(.FALSE.) ! stop waiting time measurement
#endif
! stop waiting time measurement
IF( ln_timing ) CALL tic_tac(.FALSE.)
DEALLOCATE( znorthloc )
ALLOCATE( ztabglo(ipf) )
DO jf = 1, ipf
ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) )
END DO
DEALLOCATE( znorthloc ) ! no more need of znorthloc
!
! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines
ijnr = 0
DO jr = 1, jpni ! recover the global north array
iproc = nfproc(jr)
impp = nfimpp(jr)
ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc
IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
!
SELECT CASE ( kfillmode )
CASE ( jpfillnothing ) ! no filling
CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F')
CASE ( jpfillcopy ) ! filling with inner domain values
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipj
ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
DO ji = 1, ipi
ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point
DO jf = 1, kfld
!
ihsz = ihls(jf) ! shorter name
iisht = nn_hls - ihsz
ALLOCATE( ztabglo(1)%pt4d(Ni0glo+2*ihsz,ipj2(jf),ipk(jf),ipl(jf)) )
!
iFU = COUNT( (/ c_NFtype == 'F' .AND. cd_nat(jf) == 'U' /) ) ! F-folding and U grid
IF( iFU == 0 ) ztabglo(1)%pt4d(:,ipj2(jf)-ihsz,:,:) = zhuge ! flag off the line that is not fully modified
!
! need to fill only the first ipj1(j) lines of ztabglo as lbc_nfd don't use the last ihsz lines
ijnr = 0
DO jr = 1, jpni ! recover the global north array using each northern process
iproc = nfproc(jr) ! process number
impp = nfimpp(jr) + ihsz ! ( = +nn_hls-iisht) ! inner domain position (without halos) of subdomain iproc
ipi0 = nfni_0(jr) ! Ni_0 but for subdomain iproc
!
IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
!
SELECT CASE ( kfillmode )
CASE ( jpfillnothing ) ! no filling
CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F')
CASE ( jpfillcopy ) ! filling with inner domain values
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
DO jj = 1, ipj1(jf)
ij2 = ipj(jf) - ipj2(jf) + jj ! the first ipj1(jf) lines of the last ipj2(jf) lines
DO ji = 1, ipi0
ii1 = impp + ji - 1 ! inner iproc-subdomain in the global domain with ihsz halos
ztabglo(1)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(ihsz+1,ij2,jk,jl) ! take the 1st inner domain point
END DO
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, ipj
DO ji = 1, ipi
ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval
END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
DO jj = 1, ipj1(jf)
DO ji = 1, ipi0
ii1 = impp + ji - 1 ! inner iproc-subdomain in the global domain with ihsz halos
ztabglo(1)%pt4d(ii1,jj,jk,jl) = pfillval
END DO
END DO
END DO ; END DO
END SELECT
!
ELSE ! use neighbour values
ijnr = ijnr + 1
ij1 = SUM( ipj1(1:jf-1) * ipk(1:jf-1) * ipl(1:jf-1) ) ! reset line offset, return 0 if jf = 1
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf)
DO jj = 1, ipj1(jf)
ij1 = ij1 + 1
DO ji = 1, ipi0
ii1 = impp + ji - 1 ! inner iproc-subdomain in the global domain with ihsz halos
ztabglo(1)%pt4d(ii1,jj,jk,jl) = znorthall(ji, ij1, ijnr)
END DO
END DO
END DO ; END DO ; END DO
END SELECT
END DO ; END DO
ENDIF
!
ELSE
ijnr = ijnr + 1
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipj
DO ji = 1, ipi
ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr)
END DO
END DO
END DO ; END DO ; END DO
ENDIF
END DO ! jpni
!
END DO ! jpni
DEALLOCATE( znorthglo )
!
DO jf = 1, ipf
CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition
DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity
DO jj = 1, khls + 1
ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2
ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl)
ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl)
CALL lbc_nfd( ztabglo, cd_nat(jf:jf), psgn(jf:jf), 1 ) ! North fold boundary condition
!
DO jl = 1, ipl(jf) ; DO jk = 1, ipk(jf) ! Scatter back to ARRAY_IN
DO jj = 0, ihsz-1
ij1 = ipj( jf) - jj ! last ihsz lines
ij2 = ipj2(jf) - jj ! last ihsz lines
DO ji= 1, ipi(jf)
ii2 = mig(ji+iisht,ihsz) ! warning, mig is expecting local domain indices related to nn_hls
ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(1)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
END DO ; END DO
END DO
!
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN
DO jj = 1, khls + 1
ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj
ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2
DO ji= 1, jpi
ii2 = mig(ji)
ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl)
DO jj = ihsz, ihsz - iFU
ij1 = ipj( jf) - jj ! last ihsz+1 line
ij2 = ipj2(jf) - jj ! last ihsz+1 line
DO ji= 1, ipi(jf)
ii2 = mig(ji+iisht,ihsz) ! warning, mig is expecting local domain indices related to nn_hls
zztmp = ztabglo(1)%pt4d(ii2,ij2,jk,jl)
IF( zztmp /= zhuge ) ptab(jf)%pt4d(ji,ij1,jk,jl) = zztmp ! apply it only if it was modified by lbc_nfd
END DO
END DO
END DO
END DO ; END DO ; END DO
END DO ; END DO
!
DEALLOCATE( ztabglo(1)%pt4d )
!
END DO ! jf
!
DO jf = 1, ipf
DEALLOCATE( ztabglo(jf)%pt4d )
END DO
DEALLOCATE( ztabglo )
DEALLOCATE( znorthall )
!
ENDIF ! ln_nnogather
!
......
src/OCE/LBC/mppini.F90
View file @ c72255b2
......@@ -165,6 +165,10 @@ CONTAINS
902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nammpp in configuration namelist' )
!
nn_hls = MAX(1, nn_hls) ! nn_hls must be > 0
# if defined key_mpi2
WRITE(numout,*) ' use key_mpi2, we force nn_comm = 1'
nn_comm = 1
# endif
IF(lwp) THEN
WRITE(numout,*) ' Namelist nammpp'
IF( jpni < 1 .OR. jpnj < 1 ) THEN
......@@ -303,7 +307,7 @@ CONTAINS
9002 FORMAT (a, i4, a)
9003 FORMAT (a, i5)
ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), &
ALLOCATE( nfimpp(jpni), nfproc(jpni), nfjpi(jpni), nfni_0(jpni), &
& iin(jpnij), ijn(jpnij), &
& iimppt(jpni,jpnj), ijmppt(jpni,jpnj), ijpi(jpni,jpnj), ijpj(jpni,jpnj), ipproc(jpni,jpnj), &
& inei(8,jpni,jpnj), llnei(8,jpni,jpnj), &
......@@ -375,7 +379,8 @@ CONTAINS
! Store informations for the north pole folding communications
nfproc(:) = ipproc(:,jpnj)
nfimpp(:) = iimppt(:,jpnj)
nfjpi (:) = ijpi(:,jpnj)
nfjpi (:) = ijpi(:,jpnj) ! needed only for mpp_lbc_north_icb_generic.h90
nfni_0(:) = ijpi(:,jpnj) - 2 * nn_hls
!
! 3. Define Western, Eastern, Southern and Northern neighbors + corners in the subdomain grid reference
! ------------------------------------------------------------------------------------------------------
......@@ -489,7 +494,9 @@ CONTAINS
! -----------------------------------------
!
! set default neighbours
mpinei(:) = impi(:,narea)
mpinei(:) = impi(:,narea) ! should be just local but is still used in icblbc and mpp_lnk_icb_generic.h90...
mpiSnei(0,:) = -1 ! no comm if no halo (but still need to call the NP Folding that may modify the last line)
mpiRnei(0,:) = -1
DO jh = 1, n_hlsmax
mpiSnei(jh,:) = impi(:,narea) ! default definition
mpiRnei(jh,:) = impi(:,narea)
......@@ -516,6 +523,7 @@ CONTAINS
!
! ! Prepare mpp north fold
!
l_NFold = l_NFold .AND. ANY( nfproc /= -1 ) ! make sure that we kept at least 1 proc along the last line
llmpiNFold = jpni > 1 .AND. l_NFold ! is the North fold done with an MPI communication?
l_IdoNFold = ijn(narea) == jpnj .AND. l_NFold ! is this process doing North fold?
!
......@@ -1179,7 +1187,7 @@ CONTAINS
!
ALLOCATE( zmsk0(ipi,ipj), zmsk(ipi,ipj) )
zmsk0(jh+1:jh+Ni_0,jh+1:jh+Nj_0) = REAL(COUNT(lloce, dim = 3), wp) ! define inner domain -> need REAL to use lbclnk
CALL lbc_lnk('mppini', zmsk0, 'T', 1._wp, khls = jh) ! fill halos
CALL lbc_lnk( ' mppini', zmsk0, 'T', 1._wp ) ! fill halos
! Beware about the mask we must use here :
DO jj = jh+1, jh+Nj_0
DO ji = jh+1, jh+Ni_0
......@@ -1192,7 +1200,7 @@ CONTAINS
& + zmsk0(ji+1,jj) + zmsk0(ji,jj+1) + zmsk0(ji+1,jj+1)
END DO
END DO
CALL lbc_lnk('mppini', zmsk, 'T', 1._wp, khls = jh) ! fill halos again!
CALL lbc_lnk( 'mppini', zmsk, 'T', 1._wp ) ! fill halos again!
!
iiwe = jh ; iiea = Ni_0 ! bottom-left corner - 1 of the sent data
ijso = jh ; ijno = Nj_0
......@@ -1265,7 +1273,7 @@ ENDIF
! used in IOM. This works even if jpnij .ne. jpni*jpnj.
iglo( :) = (/ Ni0glo, Nj0glo /)
iloc( :) = (/ Ni_0 , Nj_0 /)
iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig0(Nis0) but mig0 is not yet defined!
iabsf(:) = (/ Nis0 , Njs0 /) + (/ nimpp, njmpp /) - 1 - nn_hls ! corresponds to mig(Nis0,0) but mig is not yet defined!
iabsl(:) = iabsf(:) + iloc(:) - 1
ihals(:) = (/ 0 , 0 /)
ihale(:) = (/ 0 , 0 /)
......@@ -1300,10 +1308,10 @@ ENDIF
INTEGER, INTENT(in ) :: knum ! layout.dat unit
!
REAL(wp), DIMENSION(jpi,jpj,2,4) :: zinfo
INTEGER , DIMENSION(10) :: irknei ! too many elements but safe...
INTEGER , DIMENSION(0:10) :: irknei ! too many elements but safe...
INTEGER :: ji, jj, jg, jn ! dummy loop indices
INTEGER :: iitmp
LOGICAL :: lnew
LOGICAL :: llnew
!!----------------------------------------------------------------------
!
IF (lwp) THEN
......@@ -1317,29 +1325,28 @@ ENDIF
WRITE(knum,*)
WRITE(knum,*)
WRITE(knum,*) 'Number of subdomains located along the north fold : ', ndim_rank_north
WRITE(knum,*) 'Rank of the subdomains located along the north fold : ', ndim_rank_north
WRITE(knum,*) 'Rank of the subdomains located along the north fold : '
DO jn = 1, ndim_rank_north, 5
WRITE(knum,*) nrank_north( jn:MINVAL( (/jn+4,ndim_rank_north/) ) )
END DO
ENDIF
nfd_nbnei = 0 ! defaul def (useless?)
nfd_nbnei = 0 ! default def (useless?)
IF( ln_nnogather ) THEN
!
! Use the "gather nfd" to know how to do the nfd: for ji point, which process send data from which of its ji-index?
! Note that nfd is perfectly symetric: I receive data from X <=> I send data to X (-> no deadlock)
!
zinfo(:,:,:,:) = HUGE(0._wp) ! default def to make sure we don't use the halos
DO jg = 1, 4 ! grid type: T, U, V, F
DO jg = 1, 4 ! grid type: T, U, V, F
DO jj = nn_hls+1, jpj-nn_hls ! inner domain (warning do_loop_substitute not yet defined)
DO ji = nn_hls+1, jpi-nn_hls ! inner domain (warning do_loop_substitute not yet defined)
zinfo(ji,jj,1,jg) = REAL(narea, wp) ! mpi_rank + 1 (as default lbc_lnk fill is 0
zinfo(ji,jj,1,jg) = REAL(narea, wp) ! mpi_rank + 1 (note: lbc_lnk will put 0 if no neighbour)
zinfo(ji,jj,2,jg) = REAL(ji, wp) ! ji of this proc
END DO
END DO
END DO
!
ln_nnogather = .FALSE. ! force "classical" North pole folding to fill all halos -> should be no more HUGE values...
ln_nnogather = .FALSE. ! force "classical" North pole folding to fill all halos
CALL lbc_lnk( 'mppini', zinfo(:,:,:,1), 'T', 1._wp ) ! Do 4 calls instead of 1 to save memory as the nogather version
CALL lbc_lnk( 'mppini', zinfo(:,:,:,2), 'U', 1._wp ) ! creates buffer arrays with jpiglo as the first dimension
CALL lbc_lnk( 'mppini', zinfo(:,:,:,3), 'V', 1._wp ) !
......@@ -1348,24 +1355,52 @@ ENDIF
IF( l_IdoNFold ) THEN ! only the procs involed in the NFD must take care of this
ALLOCATE( nfd_rksnd(jpi,4), nfd_jisnd(jpi,4) ) ! neighbour rand and remote ji-index for each grid (T, U, V, F)
nfd_rksnd(:,:) = NINT( zinfo(:, jpj, 1, :) ) - 1 ! neighbour MPI rank
nfd_jisnd(:,:) = NINT( zinfo(:, jpj, 2, :) ) - nn_hls ! neighbour ji index (shifted as we don't send the halos)
WHERE( nfd_rksnd == -1 ) nfd_jisnd = 1 ! use ji=1 if no neighbour, see mpp_nfd_generic.h90
nfd_nbnei = 1 ! Number of neighbour sending data for the nfd. We have at least 1 neighbour!
irknei(1) = nfd_rksnd(1,1) ! which is the 1st one (I can be neighbour of myself, exclude land-proc are also ok)
ALLOCATE( nfd_rksnd(jpi,nn_hls+1,4), nfd_jisnd(jpi,nn_hls+1,4), lnfd_same(jpi,4) )
nfd_rksnd(:,:,:) = NINT( zinfo(:,jpj-nn_hls:jpj,1,:) ) - 1 ! neighbour MPI rank (-1 means no neighbour)
! Use some tricks for mpp_nfd_generic.h90:
! 1) neighbour ji index (shifted as we don't send the halos)
nfd_jisnd(:,:,:) = NINT( zinfo(:,jpj-nn_hls:jpj,2,:) ) - nn_hls
! 2) use ji=1 if no neighbour
WHERE( nfd_rksnd == -1 ) nfd_jisnd = 1
! 3) control which points must be modified by the NP folding on line jpjglo-nn_hls
lnfd_same(:,:) = .TRUE.
IF( c_NFtype == 'T' ) THEN
lnfd_same(mi0(jpiglo/2+2,nn_hls):mi1(jpiglo-nn_hls,nn_hls), 1) = .FALSE.
lnfd_same(mi0(jpiglo/2+1,nn_hls):mi1(jpiglo-nn_hls,nn_hls), 2) = .FALSE.
lnfd_same(mi0( nn_hls+1,nn_hls):mi1(jpiglo-nn_hls,nn_hls),3:4) = .FALSE.
IF( l_Iperio ) THEN ! in case the ew-periodicity was done before calling the NP folding
lnfd_same(mi0( 1,nn_hls):mi1(nn_hls,nn_hls),1:4) = .FALSE.
lnfd_same(mi0(jpiglo-nn_hls+1,nn_hls):mi1(jpiglo,nn_hls),3:4) = .FALSE.
ENDIF
ELSEIF( c_NFtype == 'F' ) THEN
lnfd_same(mi0(jpiglo/2+1 ,nn_hls):mi1(jpiglo/2+1 ,nn_hls),1) = .FALSE.
lnfd_same(mi0(jpiglo-nn_hls,nn_hls):mi1(jpiglo-nn_hls ,nn_hls),1) = .FALSE.
lnfd_same(mi0(jpiglo/2+1 ,nn_hls):mi1(jpiglo-nn_hls ,nn_hls),3) = .FALSE.
lnfd_same(mi0(jpiglo/2+1 ,nn_hls):mi1(jpiglo-nn_hls-1,nn_hls),4) = .FALSE.
IF( l_Iperio ) THEN ! in case the ew-periodicity was done before calling the NP folding
lnfd_same(mi0(nn_hls,nn_hls):mi1(nn_hls ,nn_hls),1) = .FALSE.
lnfd_same(mi0( 1,nn_hls):mi1(nn_hls ,nn_hls),3) = .FALSE.
IF( nn_hls > 1 ) lnfd_same(mi0( 1,nn_hls):mi1(nn_hls-1,nn_hls),4) = .FALSE.
ENDIF
ENDIF
WHERE( lnfd_same ) nfd_jisnd(:,1,:) = HUGE(0) ! make sure we dont use it
nfd_nbnei = 0
irknei(0) = HUGE(0)
DO jg = 1, 4
DO ji = 1, jpi ! we must be able to fill the full line including halos
lnew = .TRUE. ! new neighbour?
DO jn = 1, nfd_nbnei
IF( irknei(jn) == nfd_rksnd(ji,jg) ) lnew = .FALSE. ! already found
DO jj = 1, nn_hls+1
DO ji = 1, jpi ! we must be able to fill the full line including halos
IF( jj == 1 .AND. lnfd_same(ji,jg) ) CYCLE
llnew = .TRUE. ! new neighbour?
DO jn = 0, nfd_nbnei
IF( irknei(jn) == nfd_rksnd(ji,jj,jg) ) llnew = .FALSE. ! already found
END DO
IF( llnew ) THEN
jn = nfd_nbnei + 1
nfd_nbnei = jn
irknei(jn) = nfd_rksnd(ji,jj,jg)
ENDIF
END DO
IF( lnew ) THEN
jn = nfd_nbnei + 1
nfd_nbnei = jn
irknei(jn) = nfd_rksnd(ji,jg)
ENDIF
END DO
END DO
......@@ -1373,14 +1408,20 @@ ENDIF
nfd_rknei(:) = irknei(1:nfd_nbnei)
! re-number nfd_rksnd according to the indexes of nfd_rknei
DO jg = 1, 4
DO ji = 1, jpi
iitmp = nfd_rksnd(ji,jg) ! must store a copy of nfd_rksnd(ji,jg) to make sure we don't change it twice
DO jn = 1, nfd_nbnei
IF( iitmp == nfd_rknei(jn) ) nfd_rksnd(ji,jg) = jn
DO jj = 1, nn_hls+1
DO ji = 1, jpi
IF( jj == 1 .AND. lnfd_same(ji,jg) ) THEN
nfd_rksnd(ji,jj,jg) = HUGE(0) ! make sure we don't use it
ELSE
iitmp = nfd_rksnd(ji,jj,jg) ! must store a copy of nfd_rksnd(ji,jj,jg) so we don't change it twice
DO jn = 1, nfd_nbnei
IF( iitmp == nfd_rknei(jn) ) nfd_rksnd(ji,jj,jg) = jn
END DO
ENDIF
END DO
END DO
END DO
IF( ldwrtlay ) THEN
WRITE(knum,*)
WRITE(knum,*) 'north fold exchanges with explicit point-to-point messaging :'
......@@ -1411,7 +1452,18 @@ ENDIF
Ni_0 = Nie0 - Nis0 + 1
Nj_0 = Nje0 - Njs0 + 1
!
jpkm1 = jpk-1 ! " "
jpkm1 = jpk-1
!
ntile = 0 ! Initialise "no tile" by default
nijtile = 1
ntsi = Nis0
ntsj = Njs0
ntei = Nie0
ntej = Nje0
nthl = 0
nthr = 0
nthb = 0
ntht = 0
!
END SUBROUTINE init_doloop
......@@ -1424,38 +1476,74 @@ ENDIF
!!
!! ** Method :
!!
!! ** Action : - mig , mjg : local domain indices ==> global domain, including halos, indices
!! - mig0, mjg0: local domain indices ==> global domain, excluding halos, indices
!! Local domain indices: Same values for the same point, different upper/lower bounds
!! e.g. with nn_hls = 2
!! jh = 0 x,x,3,...,jpi-2, x, x
!! jh = 1 x,2,3,...,jpi-2,jpi-1, x
!! jh = 2 1,2,3,...,jpi-2,jpi-1,jpi
!!
!! or jh = 0 x,x,3,...,Ni_0+2, x, x
!! jh = 1 x,2,3,...,Ni_0+2,Ni_0+3, x
!! jh = 2 1,2,3,...,Ni_0+2,Ni_0+3,Ni_0+4
!!
!! Global domain indices: different values for the same point, all starts at 1
!! e.g. with nn_hls = 2
!! jh = 0 1,2,3, ...,jpiglo-4, x, x,x,x
!! jh = 1 1,2,3, ...,jpiglo-4,jpiglo-3,jpiglo-2, x,x
!! jh = 2 1,2,3,...,jpiglo-4,jpiglo-3,jpiglo-2,jpiglo-1,jpiglo
!!
!! or jh = 0 1,2,3, ...,Ni0glo , x, x,x,x
!! jh = 1 1,2,3, ...,Ni0glo ,Ni0glo+1,Ni0glo+2, x,x
!! jh = 2 1,2,3,...,Ni0glo,Ni0glo+1,Ni0glo+2,Ni0glo+3,Ni0glo+4
!! ^
!! |
!! |
!! iimpp
!!
!! ** Action : - mig , mjg : local domain indices ==> global domain indices
!! - mi0 , mi1 : global domain indices ==> local domain indices
!! - mj0 , mj1 (if global point not in the local domain ==> mi0>mi1 and/or mj0>mj1)
!!----------------------------------------------------------------------
INTEGER :: ji, jj ! dummy loop argument
INTEGER :: ji, jj, jh ! dummy loop argument
INTEGER :: ipi, ipj, ipiglo, ipjglo, iimpp, ijmpp, ishft
!!----------------------------------------------------------------------
!
ALLOCATE( mig(jpi), mjg(jpj), mig0(jpi), mjg0(jpj) )
ALLOCATE( mi0(jpiglo), mi1(jpiglo), mj0(jpjglo), mj1(jpjglo) )
ALLOCATE( mig(jpi , 0:nn_hls), mjg(jpj , 0:nn_hls) )
ALLOCATE( mi0(jpiglo, 0:nn_hls), mi1(jpiglo, 0:nn_hls), mj0(jpjglo, 0:nn_hls), mj1(jpjglo, 0:nn_hls) )
!
DO ji = 1, jpi ! local domain indices ==> global domain indices, including halos
mig(ji) = ji + nimpp - 1
END DO
DO jj = 1, jpj
mjg(jj) = jj + njmpp - 1
END DO
! ! local domain indices ==> global domain indices, excluding halos
!
mig0(:) = mig(:) - nn_hls
mjg0(:) = mjg(:) - nn_hls
! ! global domain, including halos, indices ==> local domain indices
! ! (return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the
! ! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain.
DO ji = 1, jpiglo
mi0(ji) = MAX( 1 , MIN( ji - nimpp + 1, jpi+1 ) )
mi1(ji) = MAX( 0 , MIN( ji - nimpp + 1, jpi ) )
END DO
DO jj = 1, jpjglo
mj0(jj) = MAX( 1 , MIN( jj - njmpp + 1, jpj+1 ) )
mj1(jj) = MAX( 0 , MIN( jj - njmpp + 1, jpj ) )
END DO
DO jh = 0, nn_hls
!
ishft = nn_hls - jh
!
ipi = Ni_0 + 2*jh ; ipj = Nj_0 + 2*jh
ipiglo = Ni0glo + 2*jh ; ipjglo = Nj0glo + 2*jh
iimpp = nimpp - ishft ; ijmpp = njmpp - ishft
!
! local domain indices ==> global domain indices, including jh halos
!
DO ji = ishft + 1, ishft + ipi
mig(ji,jh) = ji + iimpp - 1
END DO
!
DO jj = ishft + 1, ishft + ipj
mjg(jj,jh) = jj + ijmpp - 1
END DO
!
! global domain, including jh halos, indices ==> local domain indices
! return (m.0,m.1)=(1,0) if data domain gridpoint is to the west/south of the
! local domain, or (m.0,m.1)=(jp.+1,jp.) to the east/north of local domain.
!
DO ji = 1, ipiglo
mi0(ji,jh) = MAX( 1 , MIN( ji - iimpp + 1, ipi+ishft+1 ) )
mi1(ji,jh) = MAX( 0 , MIN( ji - iimpp + 1, ipi+ishft ) )
END DO
!
DO jj = 1, ipjglo
mj0(jj,jh) = MAX( 1 , MIN( jj - ijmpp + 1, ipj+ishft+1 ) )
mj1(jj,jh) = MAX( 0 , MIN( jj - ijmpp + 1, ipj+ishft ) )
END DO
!
END DO ! jh
!
END SUBROUTINE init_locglo
......
src/OCE/OBS/mpp_map.F90
View file @ c72255b2
......@@ -10,8 +10,8 @@ MODULE mpp_map
!! mppmap_init : Initialize mppmap.
!!----------------------------------------------------------------------
USE par_kind, ONLY : wp ! Precision variables
USE par_oce , ONLY : jpi, jpj, Nis0, Nie0, Njs0, Nje0 ! Ocean parameters
USE dom_oce , ONLY : mig, mjg, narea ! Ocean space and time domain variables
USE par_oce , ONLY : jpi, jpj, Nis0, Nie0, Njs0, Nje0, nn_hls ! Ocean parameters
USE dom_oce , ONLY : mig, mjg, narea ! Ocean space and time domain variables
#if ! defined key_mpi_off
USE lib_mpp , ONLY : mpi_comm_oce ! MPP library
#endif
......@@ -64,7 +64,7 @@ INCLUDE 'mpif.h'
imppmap(:,:) = 0
! ! Setup local grid points
imppmap(mig(1):mig(jpi),mjg(1):mjg(jpj)) = narea
imppmap(mig(1,nn_hls):mig(jpi,nn_hls),mjg(1,nn_hls):mjg(jpj,nn_hls)) = narea
! Get global data
......
src/OCE/OBS/obs_grd_bruteforce.h90
View file @ c72255b2
......@@ -111,9 +111,9 @@
zmskg(:,:) = -1.e+10
DO jj = kldj, klej
DO ji = kldi, klei
zlamg(mig(ji),mjg(jj)) = pglam(ji,jj)
zphig(mig(ji),mjg(jj)) = pgphi(ji,jj)
zmskg(mig(ji),mjg(jj)) = pmask(ji,jj)
zlamg(mig(ji,nn_hls),mjg(jj,nn_hls)) = pglam(ji,jj)
zphig(mig(ji,nn_hls),mjg(jj,nn_hls)) = pgphi(ji,jj)
zmskg(mig(ji,nn_hls),mjg(jj,nn_hls)) = pmask(ji,jj)
END DO
END DO
CALL mpp_global_max( zlamg )
......
src/OCE/OBS/obs_grid.F90
View file @ c72255b2
......@@ -280,9 +280,9 @@ CONTAINS
! Add various grids here.
DO jj = 1, jpj
DO ji = 1, jpi
zlamg(mig(ji),mjg(jj)) = glamt(ji,jj)
zphig(mig(ji),mjg(jj)) = gphit(ji,jj)
zmskg(mig(ji),mjg(jj)) = tmask(ji,jj,1)
zlamg(mig(ji,nn_hls),mjg(jj,nn_hls)) = glamt(ji,jj)
zphig(mig(ji,nn_hls),mjg(jj,nn_hls)) = gphit(ji,jj)
zmskg(mig(ji,nn_hls),mjg(jj,nn_hls)) = tmask(ji,jj,1)
END DO
END DO
CALL mpp_global_max( zlamg )
......
src/OCE/OBS/obs_inter_sup.F90
View file @ c72255b2
......@@ -279,8 +279,8 @@ CONTAINS
! Pack interpolation data to be sent
DO ji = 1, itot
ii = mi1(igrdij_recv(2*ji-1))
ij = mj1(igrdij_recv(2*ji))
ii = mi1(igrdij_recv(2*ji-1),nn_hls)
ij = mj1(igrdij_recv(2*ji ),nn_hls)
DO jk = 1, kpk
zsend(jk,ji) = pval(ii,ij,jk)
END DO
......
src/OCE/OBS/obs_write.F90
View file @ c72255b2
......@@ -245,8 +245,8 @@ CONTAINS
fbdata%iobsi(jo,jvar) = profdata%mi(jo,jvar)
fbdata%iobsj(jo,jvar) = profdata%mj(jo,jvar)
ELSE
fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar))
fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar))
fbdata%iobsi(jo,jvar) = mig(profdata%mi(jo,jvar),nn_hls)
fbdata%iobsj(jo,jvar) = mjg(profdata%mj(jo,jvar),nn_hls)
ENDIF
END DO
CALL greg2jul( 0, &
......@@ -511,8 +511,8 @@ CONTAINS
fbdata%iobsi(jo,1) = surfdata%mi(jo)
fbdata%iobsj(jo,1) = surfdata%mj(jo)
ELSE
fbdata%iobsi(jo,1) = mig(surfdata%mi(jo))
fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo))
fbdata%iobsi(jo,1) = mig(surfdata%mi(jo),nn_hls)
fbdata%iobsj(jo,1) = mjg(surfdata%mj(jo),nn_hls)
ENDIF
CALL greg2jul( 0, &
& surfdata%nmin(jo), &
......