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 NEMO/branches/UKMO/dev_r9950_GO8_package/src/OCE/LBC – NEMO

source: NEMO/branches/UKMO/dev_r9950_GO8_package/src/OCE/LBC/mpp_nfd_generic.h90 @ 10012

Last change on this file since 10012 was 10012, checked in by davestorkey, 6 years ago

UKMO dev_r9950_GO8_package branch : update to be relative to rev 10011 of NEMO4_beta_mirror branch.

  • Property svn:mime-type set to text/x-fortran
File size: 10.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, ilci, 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(jpimax,4,ipk,ipl,ipf) )
95         ALLOCATE( ztabl(jpimax   ,4,ipk,ipl,ipf) , ztabr(jpimax*jpmaxngh,4,ipk,ipl,ipf) ) 
96         !
97         ! when some processors of the north fold are suppressed,
98         ! values of ztab* arrays corresponding to these suppressed domain won't be defined
99         ! and we need a default definition to 0.
100         ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding
101         IF ( jpni*jpnj /= jpnij ) THEN
102            ztabr(:,:,:,:,:) = 0._wp
103            ztabl(:,:,:,:,:) = 0._wp
104         END IF
105         !
106         DO jf = 1, ipf
107            DO jl = 1, ipl
108               DO jk = 1, ipk
109                  DO jj = nlcj-ipj+1, nlcj          ! First put local values into the global array
110                     ij = jj - nlcj + ipj
111                     DO ji = nfsloop, nfeloop
112                        ztabl(ji,ij,jk,jl,jf) = ARRAY_IN(ji,jj,jk,jl,jf)
113                     END DO
114                  END DO
115               END DO
116            END DO
117         END DO
118         !
119         DO jr = 1, nsndto
120            IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
121              CALL mppsend( 5, znorthloc, itaille, nfipproc(isendto(jr),jpnj), ml_req_nf(jr) )
122            ENDIF
123         END DO
124         DO jr = 1,nsndto
125            iproc = nfipproc(isendto(jr),jpnj)
126            IF(iproc /= -1) THEN
127               iilb = nimppt(iproc+1)
128               ilci = nlcit (iproc+1)
129               ildi = nldit (iproc+1)
130               ilei = nleit (iproc+1)
131               IF( iilb            ==      1 )   ildi = 1      ! e-w boundary already done -> force to take 1st column
132               IF( iilb + ilci - 1 == jpiglo )   ilei = ilci   ! e-w boundary already done -> force to take last column
133               iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj)
134            ENDIF
135            IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
136              CALL mpprecv(5, zfoldwk, itaille, iproc)
137               DO jf = 1, ipf
138                  DO jl = 1, ipl
139                     DO jk = 1, ipk
140                        DO jj = 1, ipj
141                           DO ji = ildi, ilei
142                              ztabr(iilb+ji,jj,jk,jl,jf) = zfoldwk(ji,jj,jk,jl,jf)
143                           END DO
144                        END DO
145                     END DO
146                  END DO
147               END DO
148            ELSE IF( iproc == narea-1 ) THEN
149               DO jf = 1, ipf
150                  DO jl = 1, ipl
151                     DO jk = 1, ipk
152                        DO jj = 1, ipj
153                           DO ji = ildi, ilei
154                              ztabr(iilb+ji,jj,jk,jl,jf) = ARRAY_IN(ji,nlcj-ipj+jj,jk,jl,jf)
155                           END DO
156                        END DO
157                     END DO
158                  END DO
159               END DO
160            ENDIF
161         END DO
162         IF( l_isend ) THEN
163            DO jr = 1,nsndto
164               IF( nfipproc(isendto(jr),jpnj) /= narea-1 .AND. nfipproc(isendto(jr),jpnj) /= -1 ) THEN
165                  CALL mpi_wait( ml_req_nf(jr), ml_stat, ml_err )
166               ENDIF   
167            END DO
168         ENDIF
169         DO jf = 1, ipf
170            CALL lbc_nfd_nogather( ztabl(:,:,:,:,jf), ztabr(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition
171         END DO
172         DO jf = 1, ipf
173            DO jl = 1, ipl
174               DO jk = 1, ipk
175                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
176                     ij = jj - nlcj + ipj
177                     DO ji= 1, nlci
178                        ARRAY_IN(ji,jj,jk,jl,jf) = ztabl(ji,ij,jk,jl,jf)
179                     END DO
180                  END DO
181               END DO
182            END DO
183         END DO
184         !
185         DEALLOCATE( zfoldwk )
186         DEALLOCATE( ztabl, ztabr ) 
187      ELSE                             !==  ????  ==!
188         ALLOCATE( ztab       (jpiglo,4,ipk,ipl,ipf     ) )
189         ALLOCATE( znorthgloio(jpimax,4,ipk,ipl,ipf,jpni) )
190         !
191         ! when some processors of the north fold are suppressed,
192         ! values of ztab* arrays corresponding to these suppressed domain won't be defined
193         ! and we need a default definition to 0.
194         ! a better test should be: a testing if "suppressed land-processors" belongs to the north-pole folding
195         IF ( jpni*jpnj /= jpnij ) ztab(:,:,:,:,:)=0._wp
196         !
197         CALL MPI_ALLGATHER( znorthloc  , itaille, MPI_DOUBLE_PRECISION,                &
198            &                znorthgloio, itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr )
199         !
200         DO jr = 1, ndim_rank_north         ! recover the global north array
201            iproc = nrank_north(jr) + 1
202            iilb  = nimppt(iproc)
203            ilci  = nlcit (iproc)
204            ildi  = nldit (iproc)
205            ilei  = nleit (iproc)
206            IF( iilb            ==      1 )   ildi = 1      ! e-w boundary already done -> force to take 1st column
207            IF( iilb + ilci - 1 == jpiglo )   ilei = ilci   ! e-w boundary already done -> force to take last column
208            DO jf = 1, ipf
209               DO jl = 1, ipl
210                  DO jk = 1, ipk
211                     DO jj = 1, ipj
212                        DO ji = ildi, ilei
213                           ztab(ji+iilb-1,jj,jk,jl,jf) = znorthgloio(ji,jj,jk,jl,jf,jr)
214                        END DO
215                     END DO
216                  END DO
217               END DO
218            END DO
219         END DO
220         DO jf = 1, ipf
221            CALL lbc_nfd( ztab(:,:,:,:,jf), cd_nat LBC_ARG, psgn LBC_ARG )   ! North fold boundary condition
222         END DO
223         !
224         DO jf = 1, ipf
225            DO jl = 1, ipl
226               DO jk = 1, ipk
227                  DO jj = nlcj-ipj+1, nlcj             ! Scatter back to ARRAY_IN
228                     ij = jj - nlcj + ipj
229                     DO ji= 1, nlci
230                        ARRAY_IN(ji,jj,jk,jl,jf) = ztab(ji+nimpp-1,ij,jk,jl,jf)
231                     END DO
232                  END DO
233               END DO
234            END DO
235         END DO
236         !
237      !
238         DEALLOCATE( ztab )
239         DEALLOCATE( znorthgloio )
240      ENDIF
241      !
242      DEALLOCATE( znorthloc )
243      !
244   END SUBROUTINE ROUTINE_NFD
245
246#undef ARRAY_TYPE
247#undef NAT_IN
248#undef SGN_IN
249#undef ARRAY_IN
250#undef K_SIZE
251#undef L_SIZE
252#undef F_SIZE
253#undef LBC_ARG
Note: See TracBrowser for help on using the repository browser.