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

Last change on this file since 8758 was 8758, checked in by acc, 3 years ago

Branch 2017/dev_r8126_ROBUST08_no_ghost. Changes to eliminate ghost rows and columns. Currently the halo width is still fixed as 1 but a single variable (nn_hls) has been introduced for the halo-size in preparation for allowing this to vary. nn_hls replaces jpreci and jprecj. These changes have passed full SETTE tests but iceberg exchanges across the north-fold remain untested (SETTE tests only release bergs in the SO) and will require further attention. Note layout.dat now reports the jpi and jpj values for the reporting processor only.

File size: 9.1 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( znorthloc(jpimax,4,ipk,ipl,ipf) )
76      !
77      znorthloc(:,:,:,:,:) = 0._wp
78      !
79      DO jf = 1, ipf                ! put in znorthloc the last ipj j-lines of ptab
80         DO jl = 1, ipl
81            DO jk = 1, ipk
82               DO jj = nlcj - ipj +1, nlcj
83                  ij = jj - nlcj + ipj
84                  znorthloc(1:jpi,ij,jk,jl,jf) = ARRAY_IN(1:jpi,jj,jk,jl,jf)
85               END DO
86            END DO
87         END DO
88      END DO
89      !
90      !
91      itaille = jpimax * ipj * ipk * ipl * ipf
92      !
93      IF( l_north_nogather ) THEN      !==  ????  ==!
94         ALLOCATE( zfoldwk(jpi,4,ipk,ipl,ipf) )
95         ALLOCATE( ztabl(jpi   ,4,ipk,ipl,ipf) , ztabr(jpi*jpmaxngh,4,ipk,ipl,ipf) )
96         !
97         ztabr(:,:,:,:,:) = 0._wp
98         ztabl(:,:,:,:,:) = 0._wp
99         !
100         DO jf = 1, ipf
101            DO jl = 1, ipl
102               DO jk = 1, ipk
103                  DO jj = nlcj-ipj+1, nlcj          ! First put local values into the global array
104                     ij = jj - nlcj + ipj
105                     DO ji = nfsloop, nfeloop
106                        ztabl(ji,ij,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf)
107                     END DO
108                  END DO
109               END DO
110            END DO
111         END DO
112         !
113         DO jr = 1, nsndto
114            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
115              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
116            ENDIF
117         END DO
118         DO jr = 1,nsndto
119            iproc = nfipproc(isendto(jr),jpnj)
120            IF(iproc /= -1) THEN
121               ilei = nleit (iproc+1)
122               ildi = nldit (iproc+1)
123               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
124            ENDIF
125            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
126              CALL mpprecv(5, zfoldwk, itaille, iproc)
127               DO jf = 1, ipf
128                  DO jl = 1, ipl
129                     DO jk = 1, ipk
130                        DO jj = 1, ipj
131                           DO ji = ildi, ilei
132                              ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,jj,jk,jl,jf)
133                           END DO
134                        END DO
135                     END DO
136                  END DO
137               END DO
138            ELSE IF( iproc == narea-1 ) THEN
139               DO jf = 1, ipf
140                  DO jl = 1, ipl
141                     DO jk = 1, ipk
142                        DO jj = 1, ipj
143                           DO ji = ildi, ilei
144                              ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,nlcj-ipj+jj,jk,jl,jf)
145                           END DO
146                        END DO
147                     END DO
148                  END DO
149               END DO
150            ENDIF
151         END DO
152         IF( l_isend ) THEN
153            DO jr = 1,nsndto
154               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
155                  CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
156               ENDIF   
157            END DO
158         ENDIF
159         DO jf = 1, ipf
160            CALL lbc_nfd_nogather( ztabl(:,:,:,:,jf), ztabr(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition
161         END DO
162         DO jf = 1, ipf
163            DO jl = 1, ipl
164               DO jk = 1, ipk
165                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
166                     ij = jj - nlcj + ipj
167                     DO ji= 1, nlci
168                        ARRAY_IN(ji,jj,jk,jl,jf) = ztabl(ji,ij,jk,jl,jf)
169                     END DO
170                  END DO
171               END DO
172            END DO
173         END DO
174         !
175         DEALLOCATE( zfoldwk )
176         DEALLOCATE( ztabl, ztabr )
177      ELSE                             !==  ????  ==!
178         ALLOCATE( ztab       (jpiglo,4,ipk,ipl,ipf     ) )
179         ALLOCATE( znorthgloio(jpimax,4,ipk,ipl,ipf,jpni) )
180         !
181         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
182            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
183         !
184         ztab(:,:,:,:,:) = 0._wp
185         DO jr = 1, ndim_rank_north         ! recover the global north array
186            iproc = nrank_north(jr) + 1
187            ildi  = nldit (iproc)
188            ilei  = nleit (iproc)
189            iilb  = nimppt(iproc)
190            DO jf = 1, ipf
191               DO jl = 1, ipl
192                  DO jk = 1, ipk
193                     DO jj = 1, ipj
194                        DO ji = ildi, ilei
195                           ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr)
196                        END DO
197                     END DO
198                  END DO
199               END DO
200            END DO
201         END DO
202         DO jf = 1, ipf
203            CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition
204         END DO
205         !
206         DO jf = 1, ipf
207            DO jl = 1, ipl
208               DO jk = 1, ipk
209                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
210                     ij = jj - nlcj + ipj
211                     DO ji= 1, nlci
212                        ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf)
213                     END DO
214                  END DO
215               END DO
216            END DO
217         END DO
218         !
219      !
220         DEALLOCATE( ztab )
221         DEALLOCATE( znorthgloio )
222      ENDIF
223      !
224      DEALLOCATE( znorthloc )
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.