Newer
Older
sparonuz
committed
SUBROUTINE mpp_nfd_/**/PRECISION( ptab, cd_nat, psgn, kfillmode, pfillval, khls, kfld )
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
TYPE(PTR_4d_/**/PRECISION), DIMENSION(:), INTENT(inout) :: ptab ! pointer of arrays on which apply the b.c.
CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_nat ! nature of array grid-points
REAL(PRECISION), DIMENSION(:), INTENT(in ) :: psgn ! sign used across the north fold boundary
INTEGER , INTENT(in ) :: kfillmode ! filling method for halo over land
REAL(PRECISION) , INTENT(in ) :: pfillval ! background value (used at closed boundaries)
INTEGER , INTENT(in ) :: khls ! halo size, default = nn_hls
INTEGER , INTENT(in ) :: kfld ! number of pt3d arrays
!
LOGICAL :: ll_add_line
INTEGER :: ji, jj, jk, jl, jf, jr, jg, jn ! dummy loop indices
INTEGER :: ipi, ipj, ipj2, ipk, ipl, ipf ! dimension of the input array
INTEGER :: ierr, ibuffsize, iis0, iie0, impp
INTEGER :: ii1, ii2, ij1, ij2, iis, iie, iib, iig, iin
INTEGER :: i0max
INTEGER :: ij, iproc, ipni, ijnr
INTEGER, DIMENSION (:), ALLOCATABLE :: ireq_s, ireq_r ! for mpi_isend when avoiding mpi_allgather
INTEGER :: ipjtot ! sum of lines for all multi fields
INTEGER :: i012 ! 0, 1 or 2
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijsnd ! j-position of sent lines for each field
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijbuf ! j-position of send buffer lines for each field
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ijrcv ! j-position of recv buffer lines for each field
INTEGER , DIMENSION(:,:) , ALLOCATABLE :: ii1st, iiend
INTEGER , DIMENSION(:) , ALLOCATABLE :: ipjfld ! number of sent lines for each field
REAL(PRECISION), DIMENSION(:,:,:,:) , ALLOCATABLE :: zbufs ! buffer, receive and work arrays
REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: zbufr ! buffer, receive and work arrays
REAL(PRECISION), DIMENSION(:,:,:,:,:) , ALLOCATABLE :: znorthloc
REAL(PRECISION), DIMENSION(:,:,:,:,:,:), ALLOCATABLE :: znorthglo
TYPE(PTR_4D_/**/PRECISION), DIMENSION(:), ALLOCATABLE :: ztabglo ! array or pointer of arrays on which apply the b.c.
!!----------------------------------------------------------------------
!
ipk = SIZE(ptab(1)%pt4d,3)
ipl = SIZE(ptab(1)%pt4d,4)
ipf = kfld
!
IF( ln_nnogather ) THEN !== no allgather exchanges ==!
! --- define number of exchanged lines ---
!
! In theory we should exchange only nn_hls lines.
!
! However, some other points are duplicated in the north pole folding:
! - c_NFtype='T', grid=T : half of the last line (jpiglo/2+2:jpiglo-nn_hls)
! - c_NFtype='T', grid=U : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
! - c_NFtype='T', grid=V : all the last line nn_hls+1 and (nn_hls+2:jpiglo-nn_hls)
! - c_NFtype='T', grid=F : all the last line (nn_hls+1:jpiglo-nn_hls)
! - c_NFtype='F', grid=T : 2 points of the last line (jpiglo/2+1 and jpglo-nn_hls)
! - c_NFtype='F', grid=U : no points are duplicated
! - c_NFtype='F', grid=V : half of the last line (jpiglo/2+1:jpiglo-nn_hls)
! - c_NFtype='F', grid=F : half of the last line (jpiglo/2+1:jpiglo-nn_hls-1)
! The order of the calculations may differ for these duplicated points (as, for example jj+1 becomes jj-1)
! This explain why these duplicated points may have different values even if they are at the exact same location.
! In consequence, we may want to force the folding on these points by setting l_full_nf_update = .TRUE.
! This is slightly slower but necessary to avoid different values on identical grid points!!
!
!!!!!!!!! temporary switch off this optimisation ==> force TRUE !!!!!!!!
!!!!!!!!! needed to get the same results without agrif and with agrif and no zoom !!!!!!!!
!!!!!!!!! I don't know why we must do that... !!!!!!!!
l_full_nf_update = .TRUE.
! also force it if not restart during the first 2 steps (leap frog?)
ll_add_line = l_full_nf_update .OR. ( ncom_stp <= nit000+1 .AND. .NOT. ln_rstart )
ALLOCATE(ipjfld(ipf)) ! how many lines do we exchange for each field?
IF( ll_add_line ) THEN
DO jf = 1, ipf ! Loop over the number of arrays to be processed
ipjfld(jf) = khls + COUNT( (/ c_NFtype == 'T' .OR. cd_nat(jf) == 'V' .OR. cd_nat(jf) == 'F' /) )
END DO
ELSE
ipjfld(:) = khls
ENDIF
ipj = MAXVAL(ipjfld(:)) ! Max 2nd dimension of message transfers
ipjtot = SUM( ipjfld(:)) ! Total number of lines to be exchanged
! Index of modifying lines in input
ALLOCATE( ijsnd(ipj, ipf), ijbuf(ipj, ipf), ijrcv(ipj, ipf), ii1st(ipj, ipf), iiend(ipj, ipf) )
ij1 = 0
DO jf = 1, ipf ! Loop over the number of arrays to be processed
!
DO jj = 1, khls ! first khls lines (starting from top) must be fully defined
ii1st(jj, jf) = 1
iiend(jj, jf) = jpi
END DO
!
! what do we do with line khls+1 (starting from top)
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
SELECT CASE ( cd_nat(jf) )
CASE ('T','W') ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+2) ; iiend(khls+1, jf) = mi1(jpiglo-khls)
CASE ('U' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls)
CASE ('V' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi
CASE ('F' ) ; i012 = 2 ; ii1st(khls+1, jf) = 1 ; iiend(khls+1, jf) = jpi
END SELECT
ENDIF
IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
SELECT CASE ( cd_nat(jf) )
CASE ('T','W') ; i012 = 0 ! we don't touch line khls+1
CASE ('U' ) ; i012 = 0 ! we don't touch line khls+1
CASE ('V' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls )
CASE ('F' ) ; i012 = 1 ; ii1st(khls+1, jf) = mi0(jpiglo/2+1) ; iiend(khls+1, jf) = mi1(jpiglo-khls-1)
END SELECT
ENDIF
!
DO jj = 1, ipjfld(jf)
ij1 = ij1 + 1
ijsnd(jj,jf) = jpj - 2*khls + jj - i012 ! sent lines (from bottom of sent lines)
ijbuf(jj,jf) = ij1 ! gather all lines in the snd/rcv buffers
ijrcv(jj,jf) = jpj - jj + 1 ! recv lines (from the top -> reverse order for jj)
END DO
!
END DO
!
i0max = jpimax - 2 * khls ! we are not sending the halos
ALLOCATE( zbufs(i0max,ipjtot,ipk,ipl), ireq_s(nfd_nbnei) ) ! store all the data to be sent in a buffer array
ibuffsize = i0max * ipjtot * ipk * ipl
!
! fill the send buffer with all the lines
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipjfld(jf)
ij1 = ijbuf(jj,jf)
ij2 = ijsnd(jj,jf)
DO ji = Nis0, Nie0 ! should not use any other value
iib = ji - Nis0 + 1
zbufs(iib,ij1,jk,jl) = ptab(jf)%pt4d(ji,ij2,jk,jl)
END DO
DO ji = Ni_0+1, i0max ! avoid sending uninitialized values (make sure we don't use it)
zbufs(ji,ij1,jk,jl) = HUGE(0._/**/PRECISION) ! make sure we don't use it...
END DO
END DO
END DO ; END DO ; END DO
!
! start waiting time measurement
IF( ln_timing ) CALL tic_tac(.TRUE.)
!
! send the same buffer data to all neighbourgs as soon as possible
DO jn = 1, nfd_nbnei
iproc = nfd_rknei(jn)
IF( iproc /= narea-1 .AND. iproc /= -1 ) THEN
#if ! defined key_mpi_off
CALL MPI_Isend( zbufs, ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_s(jn), ierr )
#endif
ELSE
ireq_s(jn) = MPI_REQUEST_NULL
ENDIF
END DO
!
ALLOCATE( zbufr(i0max,ipjtot,ipk,ipl,nfd_nbnei), ireq_r(nfd_nbnei) )
!
DO jn = 1, nfd_nbnei
!
iproc = nfd_rknei(jn)
!
IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
!
ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received
zbufr(:,:,:,:,jn) = HUGE(0._/**/PRECISION) ! default: define it and make sure we don't use it...
SELECT CASE ( kfillmode )
CASE ( jpfillnothing ) ! no filling
CASE ( jpfillcopy ) ! filling with inner domain values
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipjfld(jf)
ij1 = ijbuf(jj,jf)
ij2 = ijsnd(jj,jf) ! we will use only the first value, see init_nfdcom
zbufr(1,ij1,jk,jl,jn) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point
END DO
END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
zbufr(1,:,:,:,jn) = pfillval ! we will use only the first value, see init_nfdcom
END SELECT
!
ELSE IF( iproc == narea-1 ) THEN ! get data from myself!
!
ireq_r(jn) = MPI_REQUEST_NULL ! no message to be received
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipjfld(jf)
ij1 = ijbuf(jj,jf)
ij2 = ijsnd(jj,jf)
DO ji = Nis0, Nie0 ! should not use any other value
iib = ji - Nis0 + 1
zbufr(iib,ij1,jk,jl,jn) = ptab(jf)%pt4d(ji,ij2,jk,jl)
END DO
END DO
END DO ; END DO ; END DO
!
ELSE ! get data from a neighbour trough communication
#if ! defined key_mpi_off
CALL MPI_Irecv( zbufr(:,:,:,:,jn), ibuffsize, MPI_TYPE, iproc, 5, mpi_comm_oce, ireq_r(jn), ierr )
#endif
ENDIF
!
END DO ! nfd_nbnei
!
CALL mpi_waitall(nfd_nbnei, ireq_r, MPI_STATUSES_IGNORE, ierr) ! wait for all Irecv
!
IF( ln_timing ) CALL tic_tac(.FALSE.)
!
! North fold boundary condition
!
DO jf = 1, ipf
!
SELECT CASE ( cd_nat(jf) ) ! which grid number?
CASE ('T','W') ; iig = 1 ! T-, W-point
CASE ('U') ; iig = 2 ! U-point
CASE ('V') ; iig = 3 ! V-point
CASE ('F') ; iig = 4 ! F-point
END SELECT
!
DO jl = 1, ipl ; DO jk = 1, ipk
!
! if T point with F-point pivot : must be done first
! --> specific correction of 3 points near the 2 pivots (to be clean, usually masked -> so useless)
IF( c_NFtype == 'F' .AND. iig == 1 ) THEN
ij1 = jpj - khls ! j-index in the receiving array
ij2 = 1 ! only 1 line in the buffer
DO ji = mi0(khls), mi1(khls) ! change because of EW periodicity as we also change jpiglo-khls
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
iib = nfd_jisnd(mi0( khls),iig) ! i-index in the buffer
iin = nfd_rksnd(mi0( khls),iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
END DO
DO ji = mi0(jpiglo/2+1), mi1(jpiglo/2+1)
iib = nfd_jisnd(mi0( jpiglo/2+1),iig) ! i-index in the buffer
iin = nfd_rksnd(mi0( jpiglo/2+1),iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
END DO
DO ji = mi0(jpiglo-khls), mi1(jpiglo-khls)
iib = nfd_jisnd(mi0(jpiglo-khls),iig) ! i-index in the buffer
iin = nfd_rksnd(mi0(jpiglo-khls),iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = zbufr(iib,ij2,jk,jl,iin) ! no psgn(jf)
END DO
ENDIF
!
! Apply the North pole folding.
DO jj = 1, ipjfld(jf) ! for all lines to be exchanged for this field
ij1 = ijrcv(jj,jf) ! j-index in the receiving array
ij2 = ijbuf(jj,jf) ! j-index in the buffer
iis = ii1st(jj,jf) ! stating i-index in the receiving array
iie = iiend(jj,jf) ! ending i-index in the receiving array
DO ji = iis, iie
iib = nfd_jisnd(ji,iig) ! i-index in the buffer
iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin)
END DO
END DO
!
! re-apply periodocity when we modified the eastern side of the inner domain (and not the full line)
IF( c_NFtype == 'T' ) THEN ! * North fold T-point pivot
IF( iig <= 2 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'T','W','U': update west halo
ELSE ; iis = 1 ; iie = 0 ! 'V','F' : full line already exchanged
ENDIF
ENDIF
IF( c_NFtype == 'F' ) THEN ! * North fold F-point pivot
IF( iig <= 2 ) THEN ; iis = 1 ; iie = 0 ! 'T','W','U': nothing to do
ELSEIF( iig == 3 ) THEN ; iis = mi0(1) ; iie = mi1(khls) ! 'V' : update west halo
ELSEIF( khls > 1 ) THEN ; iis = mi0(1) ; iie = mi1(khls-1) ! 'F' and khls > 1
ELSE ; iis = 1 ; iie = 0 ! 'F' and khls == 1 : nothing to do
ENDIF
ENDIF
jj = ipjfld(jf) ! only for the last line of this field
ij1 = ijrcv(jj,jf) ! j-index in the receiving array
ij2 = ijbuf(jj,jf) ! j-index in the buffer
DO ji = iis, iie
iib = nfd_jisnd(ji,iig) ! i-index in the buffer
iin = nfd_rksnd(ji,iig) ! neigbhour-index in the buffer
IF( nfd_rknei(iin) == -1 .AND. kfillmode == jpfillnothing ) CYCLE
ptab(jf)%pt4d(ji,ij1,jk,jl) = psgn(jf) * zbufr(iib,ij2,jk,jl,iin)
END DO
!
END DO ; END DO ! ipl ; ipk
!
END DO ! ipf
!
DEALLOCATE( zbufr, ireq_r, ijsnd, ijbuf, ijrcv, ii1st, iiend, ipjfld )
!
CALL mpi_waitall(nfd_nbnei, ireq_s, MPI_STATUSES_IGNORE, ierr) ! wait for all Isend
!
DEALLOCATE( zbufs, ireq_s )
!
ELSE !== allgather exchanges ==!
!
! how many lines do we exchange at max? -> ipj (no further optimizations in this case...)
ipj = khls + 2
! how many lines do we need at max? -> ipj2 (no further optimizations in this case...)
ipj2 = 2 * khls + 2
!
i0max = jpimax - 2 * khls
ibuffsize = i0max * ipj * ipk * ipl * ipf
ALLOCATE( znorthloc(i0max,ipj,ipk,ipl,ipf), znorthglo(i0max,ipj,ipk,ipl,ipf,ndim_rank_north) )
!
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! put in znorthloc ipj j-lines of ptab
DO jj = 1, ipj
ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
DO ji = 1, Ni_0
ii2 = Nis0 - 1 + ji ! inner domain: Nis0 to Nie0
znorthloc(ji,jj,jk,jl,jf) = ptab(jf)%pt4d(ii2,ij2,jk,jl)
END DO
DO ji = Ni_0+1, i0max
znorthloc(ji,jj,jk,jl,jf) = HUGE(0._/**/PRECISION) ! avoid sending uninitialized values (make sure we don't use it)
END DO
END DO
END DO ; END DO ; END DO
!
! start waiting time measurement
IF( ln_timing ) CALL tic_tac(.TRUE.)
#if ! defined key_mpi_off
CALL MPI_ALLGATHER( znorthloc, ibuffsize, MPI_TYPE, znorthglo, ibuffsize, MPI_TYPE, ncomm_north, ierr )
#endif
! stop waiting time measurement
IF( ln_timing ) CALL tic_tac(.FALSE.)
DEALLOCATE( znorthloc )
ALLOCATE( ztabglo(ipf) )
DO jf = 1, ipf
ALLOCATE( ztabglo(jf)%pt4d(jpiglo,ipj2,ipk,ipl) )
END DO
!
! need to fill only the first ipj lines of ztabglo as lbc_nfd don't use the last khls lines
ijnr = 0
DO jr = 1, jpni ! recover the global north array
iproc = nfproc(jr)
impp = nfimpp(jr)
ipi = nfjpi( jr) - 2 * khls ! corresponds to Ni_0 but for subdomain iproc
IF( iproc == -1 ) THEN ! No neighbour (land proc that was suppressed)
!
SELECT CASE ( kfillmode )
CASE ( jpfillnothing ) ! no filling
CALL ctl_stop( 'STOP', 'mpp_nfd_generic : cannot use jpfillnothing with ln_nnogather = F')
CASE ( jpfillcopy ) ! filling with inner domain values
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipj
ij2 = jpj - ipj2 + jj ! the first ipj lines of the last ipj2 lines
DO ji = 1, ipi
ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
ztabglo(jf)%pt4d(ii1,jj,jk,jl) = ptab(jf)%pt4d(Nis0,ij2,jk,jl) ! chose to take the 1st inner domain point
END DO
END DO
END DO ; END DO ; END DO
CASE ( jpfillcst ) ! filling with constant value
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipj
DO ji = 1, ipi
ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
ztabglo(jf)%pt4d(ii1,jj,jk,jl) = pfillval
END DO
END DO
END DO ; END DO ; END DO
END SELECT
!
ELSE
ijnr = ijnr + 1
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk
DO jj = 1, ipj
DO ji = 1, ipi
ii1 = impp + khls + ji - 1 ! corresponds to mig(khls + ji) but for subdomain iproc
ztabglo(jf)%pt4d(ii1,jj,jk,jl) = znorthglo(ji,jj,jk,jl,jf,ijnr)
END DO
END DO
END DO ; END DO ; END DO
ENDIF
!
END DO ! jpni
DEALLOCATE( znorthglo )
!
DO jf = 1, ipf
CALL lbc_nfd( ztabglo(jf:jf), cd_nat(jf:jf), psgn(jf:jf), khls, 1 ) ! North fold boundary condition
DO jl = 1, ipl ; DO jk = 1, ipk ! e-w periodicity
DO jj = 1, khls + 1
ij1 = ipj2 - (khls + 1) + jj ! need only the last khls + 1 lines until ipj2
ztabglo(jf)%pt4d( 1: khls,ij1,jk,jl) = ztabglo(jf)%pt4d(jpiglo-2*khls+1:jpiglo-khls,ij1,jk,jl)
ztabglo(jf)%pt4d(jpiglo-khls+1:jpiglo,ij1,jk,jl) = ztabglo(jf)%pt4d( khls+1: 2*khls,ij1,jk,jl)
END DO
END DO ; END DO
END DO
!
DO jf = 1, ipf ; DO jl = 1, ipl ; DO jk = 1, ipk ! Scatter back to ARRAY_IN
DO jj = 1, khls + 1
ij1 = jpj - (khls + 1) + jj ! last khls + 1 lines until jpj
ij2 = ipj2 - (khls + 1) + jj ! last khls + 1 lines until ipj2
DO ji= 1, jpi
ii2 = mig(ji)
ptab(jf)%pt4d(ji,ij1,jk,jl) = ztabglo(jf)%pt4d(ii2,ij2,jk,jl)
END DO
END DO
END DO ; END DO ; END DO
!
DO jf = 1, ipf
DEALLOCATE( ztabglo(jf)%pt4d )
END DO
DEALLOCATE( ztabglo )
!
ENDIF ! ln_nnogather
!
END SUBROUTINE mpp_nfd_/**/PRECISION