source: NEMO/branches/2020/dev_r12558_HPC-08_epico_Extra_Halo/src/OCE/LBC/mpp_lbc_north_icb_generic.h90 @ 13247

Last change on this file since 13247 was 13247, checked in by francesca, 3 months ago

dev_r12558_HPC-08_epico_Extra_Halo: merge with trunk@13227, see #2366

File size: 4.1 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, iis0, iie0, iilb
39      INTEGER ::   ipj, ij, iproc
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,jpni)    )
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      CALL MPI_ALLGATHER( znorthloc_e(1,1-kextj)    , itaille, MPI_TYPE,    &
70         &                znorthgloio_e(1,1-kextj,1), itaille, MPI_TYPE,    &
71         &                ncomm_north, ierr )
72      !
73      IF( ln_timing ) CALL tic_tac(.FALSE.)
74      !
75      DO jr = 1, ndim_rank_north            ! recover the global north array
76         iproc = nrank_north(jr) + 1
77    iis0 = nis0all(iproc)
78    iie0 = nie0all(iproc)
79         iilb = nimppt(iproc)
80         DO jj = 1-kextj, ipj+kextj
81            DO ji = iis0, iie0
82               ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr)
83            END DO
84         END DO
85      END DO
86
87      ! 2. North-Fold boundary conditions
88      ! ----------------------------------
89      CALL lbc_nfd( ztab_e(:,1-kextj:ipj+kextj), cd_type, psgn, kextj )
90
91      ij = 1 - kextj
92      !! Scatter back to pt2d
93      DO jj = jpj - ipj + 1 - kextj , jpj + kextj
94         DO ji= 1, jpi
95            pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij)
96         END DO
97         ij  = ij +1
98      END DO
99      !
100      DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e )
101      !
102#endif
103   END SUBROUTINE ROUTINE_LNK
104
105#    undef PRECISION
106#    undef SENDROUTINE
107#    undef RECVROUTINE
108#    undef MPI_TYPE
Note: See TracBrowser for help on using the repository browser.