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_nfd_generic.h90 in branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC – NEMO

source: branches/2017/dev_r8126_ROBUST08_no_ghost/NEMOGCM/NEMO/OPA_SRC/LBC/mpp_nfd_generic.h90 @ 8186

Last change on this file since 8186 was 8186, checked in by acc, 8 years ago

Branch 2017/dev_r8126_ROBUST08_no_ghost. Incorporation of re-written lbc routines. This introduces generic routines for: lbc_lnk, lbc_lnk_multi, lbc_nfd, mpp_bdy, mpp_lnk and mpp_nfd in .h90 files which are pre-processor included multiple times (with different arguments) to recreate equivalences to all the original variants from a much smaller code base (more than 2000 lines shorter). These changes have been SETTE tested and shown to reproduce identical results to the branch base revision. There are a few caveats: the ice cavity routine: iscplhsb.F90, needs to be rewritten to avoid sums over the overlap regions; this will be done elsewhere and has merely been disabled on this branch. The work is not yet complete for the nogather option for the north-fold. The default MPI ALLGATHER option is working but do not activate ln_nogather until further notice.
File size: 9.4 KB
Line 
1#if defined MULTI
2#   define NAT_IN(k)                cd_nat(k)   
3#   define SGN_IN(k)                psgn(k)
4#   define F_SIZE(ptab)             kfld
5#   define LBC_ARG                  (jf)
6#   if defined DIM_2d
7#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_2D)     , INTENT(inout) ::   ptab(f)
8#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt2d(i,j)
9#      define K_SIZE(ptab)             1
10#      define L_SIZE(ptab)             1
11#   endif
12#   if defined DIM_3d
13#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_3D)     , INTENT(inout) ::   ptab(f)
14#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt3d(i,j,k)
15#      define K_SIZE(ptab)             SIZE(ptab(1)%pt3d,3)
16#      define L_SIZE(ptab)             1
17#   endif
18#   if defined DIM_4d
19#      define ARRAY_TYPE(i,j,k,l,f)    TYPE(PTR_4D)     , INTENT(inout) ::   ptab(f)
20#      define ARRAY_IN(i,j,k,l,f)      ptab(f)%pt4d(i,j,k,l)
21#      define K_SIZE(ptab)             SIZE(ptab(1)%pt4d,3)
22#      define L_SIZE(ptab)             SIZE(ptab(1)%pt4d,4)
23#   endif
24#else
25!                          !==  IN: ptab is an array  ==!
26#   define ARRAY_TYPE(i,j,k,l,f)    REAL(wp)         , INTENT(inout) ::   ARRAY_IN(i,j,k,l,f)
27#   define NAT_IN(k)                cd_nat
28#   define SGN_IN(k)                psgn
29#   define F_SIZE(ptab)             1
30#   define LBC_ARG
31#   if defined DIM_2d
32#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j)
33#      define K_SIZE(ptab)          1
34#      define L_SIZE(ptab)          1
35#   endif
36#   if defined DIM_3d
37#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k)
38#      define K_SIZE(ptab)          SIZE(ptab,3)
39#      define L_SIZE(ptab)          1
40#   endif
41#   if defined DIM_4d
42#      define ARRAY_IN(i,j,k,l,f)   ptab(i,j,k,l)
43#      define K_SIZE(ptab)          SIZE(ptab,3)
44#      define L_SIZE(ptab)          SIZE(ptab,4)
45#   endif
46#endif
47
48   SUBROUTINE ROUTINE_NFD( ptab, cd_nat, psgn, kfld )
49      !!----------------------------------------------------------------------
50      ARRAY_TYPE(:,:,:,:,:)   ! array or pointer of arrays on which the boundary condition is applied
51      CHARACTER(len=1) , INTENT(in   ) ::   NAT_IN(:)   ! nature of array grid-points
52      REAL(wp)         , INTENT(in   ) ::   SGN_IN(:)   ! sign used across the north fold boundary
53      INTEGER, OPTIONAL, INTENT(in   ) ::   kfld        ! number of pt3d arrays
54      !
55      INTEGER  ::   ji,  jj,  jk,  jl, jh, jf, jr   ! dummy loop indices
56      INTEGER  ::   ipi, ipj, ipk, ipl, ipf         ! dimension of the input array
57      INTEGER  ::   imigr, iihom, ijhom             ! local integers
58      INTEGER  ::   ierr, itaille, ildi, ilei, iilb
59      INTEGER  ::   ij, iproc
60      INTEGER, DIMENSION (jpmaxngh)       ::   ml_req_nf   ! for mpi_isend when avoiding mpi_allgather
61      INTEGER                             ::   ml_err      ! for mpi_isend when avoiding mpi_allgather
62      INTEGER, DIMENSION(MPI_STATUS_SIZE) ::   ml_stat     ! for mpi_isend when avoiding mpi_allgather
63      !                                                    ! Workspace for message transfers avoiding mpi_allgather
64      REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   ztab, ztabl, ztabr
65      REAL(wp), DIMENSION(:,:,:,:,:)  , ALLOCATABLE ::   znorthloc, zfoldwk     
66      REAL(wp), DIMENSION(:,:,:,:,:,:), ALLOCATABLE ::   znorthgloio
67      !!----------------------------------------------------------------------
68      !
69      ipk = K_SIZE(ptab)   ! 3rd dimension
70      ipl = L_SIZE(ptab)   ! 4th    -
71      ipf = F_SIZE(ptab)   ! 5th    -      use in "multi" case (array of pointers)
72      !
73      ipj   = 4            ! 2nd dimension of message transfers (last j-lines)
74      !
75      ALLOCATE( ztab   (jpiglo,4,ipk,ipl,ipf) , znorthloc  (jpi         ,4,ipk,ipl,ipf)      )
76      ALLOCATE( zfoldwk(jpi   ,4,ipk,ipl,ipf) , znorthgloio(jpi         ,4,ipk,ipl,ipf,jpni) )
77      ALLOCATE( ztabl  (jpi   ,4,ipk,ipl,ipf) , ztabr      (jpi*jpmaxngh,4,ipk,ipl,ipf)      )
78      !
79      znorthloc(:,:,:,:,:) = 0._wp
80      !
81      DO jf = 1, ipf                ! put in xnorthloc the last ipj j-lines of ptab
82         DO jl = 1, ipl
83            DO jk = 1, ipk
84               DO jj = nlcj - ipj +1, nlcj
85                  ij = jj - nlcj + ipj
86                  znorthloc(:,ij,jk,jl,jf) = ARRAY_IN(:,jj,jk,jl,jf)
87               END DO
88            END DO
89         END DO
90      END DO
91      !
92      !                             ! Build in procs of ncomm_north the znorthgloio
93      !
94      itaille = jpi * ipj * ipk * ipl * ipf
95      !
96      IF( l_north_nogather ) THEN      !==  ????  ==!
97         !
98         ztabr(:,:,:,:,:) = 0._wp
99         ztabl(:,:,:,:,:) = 0._wp
100         !
101         DO jf = 1, ipf
102            DO jl = 1, ipl
103               DO jk = 1, ipk
104                  DO jj = nlcj-ipj+1, nlcj          ! First put local values into the global array
105                     ij = jj - nlcj + ipj
106                     DO ji = nfsloop, nfeloop
107                        ztabl(ji,ij,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf)
108                     END DO
109                  END DO
110               END DO
111            END DO
112         END DO
113         !
114         DO jr = 1, nsndto
115            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
116              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
117            ENDIF
118         END DO
119         DO jr = 1,nsndto
120            iproc = nfipproc(isendto(jr),jpnj)
121            IF(iproc /= -1) THEN
122               ilei = nleit (iproc+1)
123               ildi = nldit (iproc+1)
124               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
125            ENDIF
126            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
127              CALL mpprecv(5, zfoldwk, itaille, iproc)
128               DO jf = 1, ipf
129                  DO jl = 1, ipl
130                     DO jk = 1, ipk
131                        DO jj = 1, ipj
132                           DO ji = ildi, ilei
133                              ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,jj,jk,jl,jf)
134                           END DO
135                        END DO
136                     END DO
137                  END DO
138               END DO
139            ELSE IF( iproc == narea-1 ) THEN
140               DO jf = 1, ipf
141                  DO jl = 1, ipl
142                     DO jk = 1, ipk
143                        DO jj = 1, ipj
144                           DO ji = ildi, ilei
145                              ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,nlcj-ipj+jj,jk,jl,jf)
146                           END DO
147                        END DO
148                     END DO
149                  END DO
150               END DO
151            ENDIF
152         END DO
153         IF( l_isend ) THEN
154            DO jr = 1,nsndto
155               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
156                  CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
157               ENDIF   
158            END DO
159         ENDIF
160!!gm ERROR         CALL mpp_lbc_nfd( ztabl, ztabr, cd_nat, psgn )   ! North fold boundary condition
161         DO jf = 1, ipf
162            DO jl = 1, ipl
163               DO jk = 1, ipk
164                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
165                     ij = jj - nlcj + ipj
166                     DO ji= 1, nlci
167                        ARRAY_IN(ji,jj,jk,jl,jf) = ztabl(ji,ij,jk,jl,jf)
168                     END DO
169                  END DO
170               END DO
171            END DO
172         END DO
173         !
174      ELSE                             !==  ????  ==!
175         !
176         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
177            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
178         !
179         ztab(:,:,:,:,:) = 0._wp
180         DO jr = 1, ndim_rank_north         ! recover the global north array
181            iproc = nrank_north(jr) + 1
182            ildi  = nldit (iproc)
183            ilei  = nleit (iproc)
184            iilb  = nimppt(iproc)
185            DO jf = 1, ipf
186               DO jl = 1, ipl
187                  DO jk = 1, ipk
188                     DO jj = 1, ipj
189                        DO ji = ildi, ilei
190                           ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr)
191                        END DO
192                     END DO
193                  END DO
194               END DO
195            END DO
196         END DO
197         DO jf = 1, ipf
198            CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition
199         END DO
200         !
201         DO jf = 1, ipf
202            DO jl = 1, ipl
203               DO jk = 1, ipk
204                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
205                     ij = jj - nlcj + ipj
206                     DO ji= 1, nlci
207                        ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf)
208                     END DO
209                  END DO
210               END DO
211            END DO
212         END DO
213         !
214      ENDIF
215      !
216      ! The ztab array has been either:
217      !  a. Fully populated by the mpi_allgather operation or
218      !  b. Had the active points for this domain and northern neighbours populated
219      !     by peer to peer exchanges
220      ! Either way the array may be folded by lbc_nfd and the result for the span of
221      ! this domain will be identical.
222      !
223      DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio )
224      DEALLOCATE( ztabl, ztabr )
225      !
226   END SUBROUTINE ROUTINE_NFD
227
228#undef ARRAY_TYPE
229#undef NAT_IN
230#undef SGN_IN
231#undef ARRAY_IN
232#undef K_SIZE
233#undef L_SIZE
234#undef F_SIZE
235#undef LBC_ARG
Note: See TracBrowser for help on using the repository browser.