New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
mpp_lbc_north_icb_generic.h90 in NEMO/trunk/src/OCE/LBC – NEMO

source: NEMO/trunk/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 @ 13438

Last change on this file since 13438 was 13438, checked in by smasson, 4 years ago

trunk: bugfix to compile and run the code without key_mpp_mpi, see #2495

File size: 4.3 KB
Line 
1# if defined SINGLE_PRECISION
2#    define PRECISION sp
3#    define SENDROUTINE mppsend_sp
4#    define RECVROUTINE mpprecv_sp
5#    define MPI_TYPE MPI_REAL
6# else
7#    define PRECISION dp
8#    define SENDROUTINE mppsend_dp
9#    define RECVROUTINE mpprecv_dp
10#    define MPI_TYPE MPI_DOUBLE_PRECISION
11# endif
12
13   SUBROUTINE ROUTINE_LNK( pt2d, cd_type, psgn, kextj)
14      !!---------------------------------------------------------------------
15      !!                   ***  routine mpp_lbc_north_icb  ***
16      !!
17      !! ** Purpose :   Ensure proper north fold horizontal bondary condition
18      !!              in mpp configuration in case of jpn1 > 1 and for 2d
19      !!              array with outer extra halo
20      !!
21      !! ** Method  :   North fold condition and mpp with more than one proc
22      !!              in i-direction require a specific treatment. We gather
23      !!              the 4+kextj northern lines of the global domain on 1
24      !!              processor and apply lbc north-fold on this sub array.
25      !!              Then we scatter the north fold array back to the processors.
26      !!              This routine accounts for an extra halo with icebergs
27      !!              and assumes ghost rows and columns have been suppressed.
28      !!
29      !!----------------------------------------------------------------------
30      REAL(PRECISION), DIMENSION(:,:), INTENT(inout) ::   pt2d     ! 2D array with extra halo
31      CHARACTER(len=1)        , INTENT(in   ) ::   cd_type  ! nature of pt3d grid-points
32      !                                                     !   = T ,  U , V , F or W -points
33      REAL(wp)                , INTENT(in   ) ::   psgn     ! = -1. the sign change across the
34      !!                                                    ! north fold, =  1. otherwise
35      INTEGER                 , INTENT(in   ) ::   kextj    ! Extra halo width at north fold
36      !
37      INTEGER ::   ji, jj, jr
38      INTEGER ::   ierr, itaille
39      INTEGER ::   ipj, ij, iproc, ijnr, ii1, ipi, impp
40      !
41      REAL(PRECISION), DIMENSION(:,:)  , ALLOCATABLE  ::  ztab_e, znorthloc_e
42      REAL(PRECISION), DIMENSION(:,:,:), ALLOCATABLE  ::  znorthgloio_e
43      !!----------------------------------------------------------------------
44#if defined key_mpp_mpi
45      !
46      ipj=4
47      ALLOCATE(        ztab_e(jpiglo, 1-kextj:ipj+kextj)       ,       &
48     &            znorthloc_e(jpimax, 1-kextj:ipj+kextj)       ,       &
49     &          znorthgloio_e(jpimax, 1-kextj:ipj+kextj,ndim_rank_north)    )
50      !
51# if defined SINGLE_PRECISION
52      ztab_e(:,:)      = 0._sp
53      znorthloc_e(:,:) = 0._sp
54# else
55      ztab_e(:,:)      = 0._dp
56      znorthloc_e(:,:) = 0._dp
57# endif
58      !
59      ij = 1 - kextj
60      ! put the last ipj+2*kextj lines of pt2d into znorthloc_e
61      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
62         znorthloc_e(1:jpi,ij)=pt2d(1:jpi,jj)
63         ij = ij + 1
64      END DO
65      !
66      itaille = jpimax * ( ipj + 2*kextj )
67      !
68      IF( ln_timing ) CALL tic_tac(.TRUE.)
69#if defined key_mpp_mpi
70      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_TYPE,    &
71         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE,    &
72         &                ncomm_north, ierr )
73#endif
74      !
75      IF( ln_timing ) CALL tic_tac(.FALSE.)
76      !
77      ijnr = 0
78      DO jr = 1, ndim_rank_north            ! recover the global north array
79         iproc = nfproc(jr)
80         IF( iproc /= -1 ) THEN
81            impp = nfimpp(jr)
82            ipi  = nfjpi(jr)
83            ijnr = ijnr + 1
84            DO jj = 1-kextj, ipj+kextj
85               DO ji = 1, ipi
86                  ii1 = impp + ji - 1       ! corresponds to mig(ji) but for subdomain iproc
87                  ztab_e(ii1,jj) = znorthgloio_e(ji,jj,ijnr)
88               END DO
89            END DO
90         ENDIF
91      END DO
92
93      ! 2. North-Fold boundary conditions
94      ! ----------------------------------
95      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
96
97      ij = 1 - kextj
98      !! Scatter back to pt2d
99      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
100         DO ji= 1, jpi
101            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
102         END DO
103         ij  = ij +1
104      END DO
105      !
106      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
107      !
108#endif
109   END SUBROUTINE ROUTINE_LNK
110
111#    undef PRECISION
112#    undef SENDROUTINE
113#    undef RECVROUTINE
114#    undef MPI_TYPE
Note: See TracBrowser for help on using the repository browser.