ROMS
Loading...
Searching...
No Matches
normalization.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE normalization_mod
3
4#if defined FOUR_DVAR
5!
6!git $Id$
7!================================================== Hernan G. Arango ===
8! Copyright (c) 2002-2025 The ROMS Group !
9! Licensed under a MIT/X style license !
10! See License_ROMS.md !
11!=======================================================================
12! !
13! This routine computes the background covariance, B, normalization !
14! factors using the exact or approximated approach. These factors !
15! ensure that the diagonal elements of B are equal to unity. Notice !
16! that in applications with land/sea masking, it will produce large !
17! changes in the covariance structures near the boundary. !
18! !
19! The exact method is very expensive: the normalization factors are !
20! computed by perturbing each model grid cell with a delta function !
21! scaled by the area (2D factors) or volume (3D factors), and then !
22! convolving with the squared-root adjoint and tangent diffusion !
23! operators. !
24! !
25! The approximated method is cheaper: the normalization factors are !
26! computed using the randomization approach of Fisher and Courtier !
27! (1995). The factors are initialized with randon numbers having a !
28! uniform distribution (drawn from a normal distribution with zero !
29! mean and unity variance). Then, they scaled the inverse, squared !
30! root cell area (2D factors) or volume (3D factors) and convoluted !
31! with the squared-root adjoint and tangent diffuse operators over !
32! a specified number of iterations, Nrandom. !
33! !
34! References: !
35! !
36! Fisher, M. and. P. Courtier, 1995: Estimating the covariance !
37! matrices of analysis and forecast error in variational data !
38! assimilation, ECMWF Technical Memo N. 220, ECMWF, Reading, !
39! UK. !
40! !
41! www.ecmwf.int/publications/library/ecpublications/_pdf/tm/ !
42! 001-300/tm220.pdf !
43! !
44! Weaver, A. and P. Courtier, 2001: Correlation modeling on the !
45! sphere using a generalized diffusion equation, Q.J.R. Meteo. !
46! Soc, 127, 1815-1846. !
47! !
48!======================================================================!
49!
50 USE mod_kinds
51 USE mod_param
52 USE mod_parallel
53# ifdef ADJUST_BOUNDARY
54 USE mod_boundary
55# endif
56 USE mod_grid
57# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
58 USE mod_forces
59# endif
60 USE mod_fourdvar
61 USE mod_iounits
62 USE mod_ncparam
63 USE mod_netcdf
64 USE mod_mixing
65 USE mod_ocean
66# if defined PIO_LIB && defined DISTRIBUTE
67 USE mod_pio_netcdf
68# endif
69 USE mod_scalars
70# if defined SEDIMENT && defined SED_MORPH && defined SOLVE3D
71 USE mod_sedbed
72# endif
73 USE mod_stepping
74!
75 USE ad_conv_2d_mod
76# ifdef SOLVE3D
77 USE ad_conv_3d_mod
78# endif
79# ifdef ADJUST_BOUNDARY
80 USE ad_conv_bry2d_mod
81# ifdef SOLVE3D
82 USE ad_conv_bry3d_mod
83# endif
84# endif
85 USE bc_2d_mod
86# ifdef SOLVE3D
87 USE bc_3d_mod
88# endif
89# ifdef ADJUST_BOUNDARY
90 USE bc_bry2d_mod
91# ifdef SOLVE3D
92 USE bc_bry3d_mod
93# endif
94# endif
95# ifdef DISTRIBUTE
96 USE mp_exchange_mod
97# endif
98 USE set_depth_mod
99 USE tl_conv_2d_mod
100# ifdef SOLVE3D
101 USE tl_conv_3d_mod
102# endif
103# ifdef ADJUST_BOUNDARY
104 USE tl_conv_bry2d_mod
105# ifdef SOLVE3D
106 USE tl_conv_bry3d_mod
107# endif
108# endif
109 USE white_noise_mod
110!
111# ifdef DISTRIBUTE
112# ifdef ADJUST_BOUNDARY
113 USE distribute_mod, ONLY : mp_collect
114# endif
115 USE distribute_mod, ONLY : mp_reduce
116# endif
117 USE nf_fwrite2d_mod, ONLY : nf_fwrite2d
118 USE nf_fwrite3d_mod, ONLY : nf_fwrite3d
119 USE strings_mod, ONLY : founderror
120!
121 implicit none
122!
123 PUBLIC :: normalization
124 PRIVATE :: normalization_tile
125 PRIVATE :: randomization_tile
126 PRIVATE :: wrt_norm2d_nf90
127# if defined PIO_LIB && defined DISTRIBUTE
128 PRIVATE :: wrt_norm2d_pio
129# endif
130 PRIVATE :: wrt_norm3d_nf90
131# if defined PIO_LIB && defined DISTRIBUTE
132 PRIVATE :: wrt_norm3d_pio
133# endif
134!
135 CONTAINS
136!
137!***********************************************************************
138 SUBROUTINE normalization (ng, tile, ifac)
139!***********************************************************************
140!
141! Imported variable declarations.
142!
143 integer, intent(in) :: ng, tile, ifac
144!
145! Local variable declarations.
146!
147# include "tile.h"
148!
149! Compute background error covariance normalization factors using
150! the very expensive exact method.
151!
152 IF (nmethod(ng).eq.0) THEN
153 CALL normalization_tile (ng, tile, &
154 & lbi, ubi, lbj, ubj, lbij, ubij, &
155 & imins, imaxs, jmins, jmaxs, &
156 & nstp(ng), nnew(ng), ifac, &
157 & grid(ng) % pm, &
158 & grid(ng) % om_p, &
159 & grid(ng) % om_r, &
160 & grid(ng) % om_u, &
161 & grid(ng) % om_v, &
162 & grid(ng) % pn, &
163 & grid(ng) % on_p, &
164 & grid(ng) % on_r, &
165 & grid(ng) % on_u, &
166 & grid(ng) % on_v, &
167 & grid(ng) % pmon_p, &
168 & grid(ng) % pmon_r, &
169 & grid(ng) % pmon_u, &
170 & grid(ng) % pnom_p, &
171 & grid(ng) % pnom_r, &
172 & grid(ng) % pnom_v, &
173# ifdef MASKING
174 & grid(ng) % pmask, &
175 & grid(ng) % rmask, &
176 & grid(ng) % umask, &
177 & grid(ng) % vmask, &
178# endif
179# ifdef SOLVE3D
180 & grid(ng) % h, &
181# ifdef ICESHELF
182 & grid(ng) % zice, &
183# endif
184# if defined SEDIMENT && defined SED_MORPH
185 & sedbed(ng) % bed_thick, &
186# endif
187 & grid(ng) % Hz, &
188 & grid(ng) % z_r, &
189 & grid(ng) % z_w, &
190# endif
191 & mixing(ng) % Kh, &
192# ifdef SOLVE3D
193 & mixing(ng) % Kv, &
194# endif
195# ifdef ADJUST_BOUNDARY
196# ifdef SOLVE3D
197 & boundary(ng) % b_t_obc, &
198 & boundary(ng) % b_u_obc, &
199 & boundary(ng) % b_v_obc, &
200# endif
201 & boundary(ng) % b_ubar_obc, &
202 & boundary(ng) % b_vbar_obc, &
203 & boundary(ng) % b_zeta_obc, &
204# endif
205# ifdef ADJUST_WSTRESS
206 & forces(ng) % b_sustr, &
207 & forces(ng) % b_svstr, &
208# endif
209# if defined ADJUST_STFLUX && defined SOLVE3D
210 & forces(ng) % b_stflx, &
211# endif
212# ifdef SOLVE3D
213 & ocean(ng) % b_t, &
214 & ocean(ng) % b_u, &
215 & ocean(ng) % b_v, &
216# endif
217 & ocean(ng) % b_zeta, &
218 & ocean(ng) % b_ubar, &
219 & ocean(ng) % b_vbar)
220!
221! Compute background error covariance normalization factors using
222! the approximated randomization method.
223!
224 ELSE IF (nmethod(ng).eq.1) THEN
225 CALL randomization_tile (ng, tile, &
226 & lbi, ubi, lbj, ubj, lbij, ubij, &
227 & imins, imaxs, jmins, jmaxs, &
228 & nstp(ng), nnew(ng), ifac, &
229 & grid(ng) % pm, &
230 & grid(ng) % om_p, &
231 & grid(ng) % om_r, &
232 & grid(ng) % om_u, &
233 & grid(ng) % om_v, &
234 & grid(ng) % pn, &
235 & grid(ng) % on_p, &
236 & grid(ng) % on_r, &
237 & grid(ng) % on_u, &
238 & grid(ng) % on_v, &
239 & grid(ng) % pmon_p, &
240 & grid(ng) % pmon_r, &
241 & grid(ng) % pmon_u, &
242 & grid(ng) % pnom_p, &
243 & grid(ng) % pnom_r, &
244 & grid(ng) % pnom_v, &
245# ifdef MASKING
246 & grid(ng) % pmask, &
247 & grid(ng) % rmask, &
248 & grid(ng) % umask, &
249 & grid(ng) % vmask, &
250# endif
251# ifdef SOLVE3D
252 & grid(ng) % h, &
253# ifdef ICESHELF
254 & grid(ng) % zice, &
255# endif
256# if defined SEDIMENT && defined SED_MORPH
257 & sedbed(ng) % bed_thick, &
258# endif
259 & grid(ng) % Hz, &
260 & grid(ng) % z_r, &
261 & grid(ng) % z_w, &
262# endif
263 & mixing(ng) % Kh, &
264# ifdef SOLVE3D
265 & mixing(ng) % Kv, &
266# endif
267# ifdef ADJUST_BOUNDARY
268# ifdef SOLVE3D
269 & boundary(ng) % b_t_obc, &
270 & boundary(ng) % b_u_obc, &
271 & boundary(ng) % b_v_obc, &
272# endif
273 & boundary(ng) % b_ubar_obc, &
274 & boundary(ng) % b_vbar_obc, &
275 & boundary(ng) % b_zeta_obc, &
276# endif
277# ifdef ADJUST_WSTRESS
278 & forces(ng) % b_sustr, &
279 & forces(ng) % b_svstr, &
280# endif
281# if defined ADJUST_STFLUX && defined SOLVE3D
282 & forces(ng) % b_stflx, &
283# endif
284# ifdef SOLVE3D
285 & ocean(ng) % b_t, &
286 & ocean(ng) % b_u, &
287 & ocean(ng) % b_v, &
288# endif
289 & ocean(ng) % b_zeta, &
290 & ocean(ng) % b_ubar, &
291 & ocean(ng) % b_vbar)
292 END IF
293!
294 RETURN
295 END SUBROUTINE normalization
296!
297!***********************************************************************
298 SUBROUTINE normalization_tile (ng, tile, &
299 & LBi, UBi, LBj, UBj, LBij, UBij, &
300 & IminS, ImaxS, JminS, JmaxS, &
301 & nstp, nnew, ifac, &
302 & pm, om_p, om_r, om_u, om_v, &
303 & pn, on_p, on_r, on_u, on_v, &
304 & pmon_p, pmon_r, pmon_u, &
305 & pnom_p, pnom_r, pnom_v, &
306# ifdef MASKING
307 & pmask, rmask, &
308 & umask, vmask, &
309# endif
310# ifdef SOLVE3D
311 & h, &
312# ifdef ICESHELF
313 & zice, &
314# endif
315# if defined SEDIMENT && defined SED_MORPH
316 & bed_thick, &
317# endif
318 & Hz, z_r, z_w, &
319# endif
320 & Kh, &
321# ifdef SOLVE3D
322 & Kv, &
323# endif
324# ifdef ADJUST_BOUNDARY
325# ifdef SOLVE3D
326 & VnormRobc, VnormUobc, VnormVobc, &
327# endif
328 & HnormRobc, HnormUobc, HnormVobc, &
329# endif
330# ifdef ADJUST_WSTRESS
331 & HnormSUS, HnormSVS, &
332# endif
333# if defined ADJUST_STFLUX && defined SOLVE3D
334 & HnormSTF, &
335# endif
336# ifdef SOLVE3D
337 & VnormR, VnormU, VnormV, &
338# endif
339 & HnormR, HnormU, HnormV)
340!***********************************************************************
341!
342! Imported variable declarations.
343!
344 integer, intent(in) :: ng, tile
345 integer, intent(in) :: lbi, ubi, lbj, ubj, lbij, ubij
346 integer, intent(in) :: imins, imaxs, jmins, jmaxs
347 integer, intent(in) :: nstp, nnew, ifac
348!
349# ifdef ASSUMED_SHAPE
350 real(r8), intent(in) :: pm(lbi:,lbj:)
351 real(r8), intent(in) :: om_p(lbi:,lbj:)
352 real(r8), intent(in) :: om_r(lbi:,lbj:)
353 real(r8), intent(in) :: om_u(lbi:,lbj:)
354 real(r8), intent(in) :: om_v(lbi:,lbj:)
355 real(r8), intent(in) :: pn(lbi:,lbj:)
356 real(r8), intent(in) :: on_p(lbi:,lbj:)
357 real(r8), intent(in) :: on_r(lbi:,lbj:)
358 real(r8), intent(in) :: on_u(lbi:,lbj:)
359 real(r8), intent(in) :: on_v(lbi:,lbj:)
360 real(r8), intent(in) :: pmon_p(lbi:,lbj:)
361 real(r8), intent(in) :: pmon_r(lbi:,lbj:)
362 real(r8), intent(in) :: pmon_u(lbi:,lbj:)
363 real(r8), intent(in) :: pnom_p(lbi:,lbj:)
364 real(r8), intent(in) :: pnom_r(lbi:,lbj:)
365 real(r8), intent(in) :: pnom_v(lbi:,lbj:)
366# ifdef MASKING
367 real(r8), intent(in) :: pmask(lbi:,lbj:)
368 real(r8), intent(in) :: rmask(lbi:,lbj:)
369 real(r8), intent(in) :: umask(lbi:,lbj:)
370 real(r8), intent(in) :: vmask(lbi:,lbj:)
371# endif
372 real(r8), intent(in) :: kh(lbi:,lbj:)
373# ifdef SOLVE3D
374 real(r8), intent(in) :: kv(lbi:,lbj:,0:)
375# ifdef ICESHELF
376 real(r8), intent(in) :: zice(lbi:,lbj:)
377# endif
378# if defined SEDIMENT && defined SED_MORPH
379 real(r8), intent(in):: bed_thick(lbi:,lbj:,:)
380# endif
381 real(r8), intent(inout) :: h(lbi:,lbj:)
382# endif
383# ifdef ADJUST_BOUNDARY
384# ifdef SOLVE3D
385 real(r8), intent(out) :: vnormrobc(lbij:,:,:,:)
386 real(r8), intent(out) :: vnormuobc(lbij:,:,:)
387 real(r8), intent(out) :: vnormvobc(lbij:,:,:)
388# endif
389 real(r8), intent(out) :: hnormrobc(lbij:,:)
390 real(r8), intent(out) :: hnormuobc(lbij:,:)
391 real(r8), intent(out) :: hnormvobc(lbij:,:)
392# endif
393# ifdef ADJUST_WSTRESS
394 real(r8), intent(out) :: hnormsus(lbi:,lbj:)
395 real(r8), intent(out) :: hnormsvs(lbi:,lbj:)
396# endif
397# if defined ADJUST_STFLUX && defined SOLVE3D
398 real(r8), intent(out) :: hnormstf(lbi:,lbj:,:)
399# endif
400# ifdef SOLVE3D
401 real(r8), intent(out) :: vnormr(lbi:,lbj:,:,:,:)
402 real(r8), intent(out) :: vnormu(lbi:,lbj:,:,:)
403 real(r8), intent(out) :: vnormv(lbi:,lbj:,:,:)
404# endif
405 real(r8), intent(out) :: hnormr(lbi:,lbj:,:)
406 real(r8), intent(out) :: hnormu(lbi:,lbj:,:)
407 real(r8), intent(out) :: hnormv(lbi:,lbj:,:)
408# ifdef SOLVE3D
409 real(r8), intent(out) :: hz(lbi:,lbj:,:)
410 real(r8), intent(out) :: z_r(lbi:,lbj:,:)
411 real(r8), intent(out) :: z_w(lbi:,lbj:,0:)
412# endif
413# else
414 real(r8), intent(in) :: pm(lbi:ubi,lbj:ubj)
415 real(r8), intent(in) :: om_p(lbi:ubi,lbj:ubj)
416 real(r8), intent(in) :: om_r(lbi:ubi,lbj:ubj)
417 real(r8), intent(in) :: om_u(lbi:ubi,lbj:ubj)
418 real(r8), intent(in) :: om_v(lbi:ubi,lbj:ubj)
419 real(r8), intent(in) :: pn(lbi:ubi,lbj:ubj)
420 real(r8), intent(in) :: on_p(lbi:ubi,lbj:ubj)
421 real(r8), intent(in) :: on_r(lbi:ubi,lbj:ubj)
422 real(r8), intent(in) :: on_u(lbi:ubi,lbj:ubj)
423 real(r8), intent(in) :: on_v(lbi:ubi,lbj:ubj)
424 real(r8), intent(in) :: pmon_p(lbi:ubi,lbj:ubj)
425 real(r8), intent(in) :: pmon_r(lbi:ubi,lbj:ubj)
426 real(r8), intent(in) :: pmon_u(lbi:ubi,lbj:ubj)
427 real(r8), intent(in) :: pnom_p(lbi:ubi,lbj:ubj)
428 real(r8), intent(in) :: pnom_r(lbi:ubi,lbj:ubj)
429 real(r8), intent(in) :: pnom_v(lbi:ubi,lbj:ubj)
430# ifdef MASKING
431 real(r8), intent(in) :: pmask(lbi:ubi,lbj:ubj)
432 real(r8), intent(in) :: rmask(lbi:ubi,lbj:ubj)
433 real(r8), intent(in) :: umask(lbi:ubi,lbj:ubj)
434 real(r8), intent(in) :: vmask(lbi:ubi,lbj:ubj)
435# endif
436 real(r8), intent(in) :: kh(lbi:ubi,lbj:ubj)
437# ifdef SOLVE3D
438 real(r8), intent(in) :: kv(lbi:ubi,lbj:ubj,0:n(ng))
439# ifdef ICESHELF
440 real(r8), intent(in) :: zice(lbi:ubi,lbj:ubj)
441# endif
442# if defined SEDIMENT && defined SED_MORPH
443 real(r8), intent(in):: bed_thick0(lbi:ubi,lbj:ubj,3)
444# endif
445 real(r8), intent(inout) :: h(lbi:ubi,lbj:ubj)
446# endif
447# ifdef ADJUST_BOUNDARY
448# ifdef SOLVE3D
449 real(r8), intent(out) :: vnormrobc(lbij:ubij,n(ng),4,nt(ng))
450 real(r8), intent(out) :: vnormuobc(lbij:ubij,n(ng),4)
451 real(r8), intent(out) :: vnormvobc(lbij:ubij,n(ng),4)
452# endif
453 real(r8), intent(out) :: hnormrobc(lbij:ubij,4)
454 real(r8), intent(out) :: hnormuobc(lbij:ubij,4)
455 real(r8), intent(out) :: hnormvobc(lbij:ubij,4)
456# endif
457# ifdef ADJUST_WSTRESS
458 real(r8), intent(out) :: hnormsus(lbi:ubi,lbj:ubj)
459 real(r8), intent(out) :: hnormsvs(lbi:ubi,lbj:ubj)
460# endif
461# if defined ADJUST_STFLUX && defined SOLVE3D
462 real(r8), intent(out) :: hnormstf(lbi:ubi,lbj:ubj,nt(ng))
463# endif
464# ifdef SOLVE3D
465 real(r8), intent(out) :: vnormr(lbi:ubi,lbj:ubj,n(ng),nsa,nt(ng))
466 real(r8), intent(out) :: vnormu(lbi:ubi,lbj:ubj,n(ng),nsa)
467 real(r8), intent(out) :: vnormv(lbi:ubi,lbj:ubj,n(ng),nsa)
468# endif
469 real(r8), intent(out) :: hnormr(lbi:ubi,lbj:ubj,nsa)
470 real(r8), intent(out) :: hnormu(lbi:ubi,lbj:ubj,nsa)
471 real(r8), intent(out) :: hnormv(lbi:ubi,lbj:ubj,nsa)
472# ifdef SOLVE3D
473 real(r8), intent(out) :: hz(lbi:ubi,lbj:ubj,n(ng))
474 real(r8), intent(out) :: z_r(lbi:ubi,lbj:ubj,n(ng))
475 real(r8), intent(out) :: z_w(lbi:ubi,lbj:ubj,0:n(ng))
476# endif
477# endif
478!
479! Local variable declarations.
480!
481# ifdef SOLVE3D
482 logical :: ldiffer, lsame
483# endif
484# ifdef ADJUST_BOUNDARY
485 logical :: bounded
486 logical :: lconvolve(4)
487# endif
488!
489 integer :: imin, imax, jmin, jmax
490 integer :: i, ic, ifile, is, j, jc, rec
491 integer :: nsub
492# ifdef SOLVE3D
493 integer :: ubt, itrc, k, kc, ntrc
494# endif
495# ifdef ADJUST_BOUNDARY
496 integer :: bmin, bmax, ijlen, ijklen
497 integer :: ib, ibry, ifield, kb
498!
499 real(r8), parameter :: aspv = 0.0_r8
500# endif
501 real(dp) :: my_time
502 real(r8) :: cff, compute
503 real(r8) :: my_dot, gdotp
504!
505 real(r8), dimension(LBi:UBi,LBj:UBj) :: a2d
506 real(r8), dimension(LBi:UBi,LBj:UBj) :: hscale
507# ifdef SOLVE3D
508 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: a3d
509 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: vscale
510# endif
511# ifdef ADJUST_BOUNDARY
512 real(r8), dimension(LBij:UBij) :: b2d
513 real(r8), dimension(LBij:UBij) :: hscaleb
514# ifdef SOLVE3D
515 real(r8), dimension(LBij:UBij,1:N(ng)) :: b3d
516 real(r8), dimension(LBij:UBij,1:N(ng)) :: vscaleb
517# ifdef DISTRIBUTE
518 real(r8), dimension((UBij-LBij+1)*N(ng)) :: bwrk
519# endif
520# endif
521# endif
522!
523# ifdef DISTRIBUTE
524 character (len=3 ) :: op_handle
525# endif
526 character (len=40 ) :: text
527 character (len=256) :: ncname
528
529 character (len=*), parameter :: myfile = &
530 & __FILE__//", normalization_tile"
531
532# if defined PIO_LIB && defined DISTRIBUTE
533!
534 TYPE (io_desc_t), pointer :: iodesc
535# endif
536
537# include "set_bounds.h"
538!
539 sourcefile=myfile
540
541 my_time=tdays(ng)*day2sec
542
543# ifdef SOLVE3D
544!
545!-----------------------------------------------------------------------
546! Compute time invariant depths (use zero free-surface).
547!-----------------------------------------------------------------------
548!
549 DO i=lbi,ubi
550 DO j=lbj,ubj
551 a2d(i,j)=0.0_r8
552 END DO
553 END DO
554
555 CALL set_depth_tile (ng, tile, inlm, &
556 & lbi, ubi, lbj, ubj, &
557 & imins, imaxs, jmins, jmaxs, &
558 & nstp, nnew, &
559 & h, &
560# ifdef ICESHELF
561 & zice, &
562# endif
563# if defined SEDIMENT && defined SED_MORPH
564 & bed_thick, &
565# endif
566 & a2d, &
567 & hz, z_r, z_w)
568# endif
569!
570!-----------------------------------------------------------------------
571! Compute initial conditions and model error covariance, B,
572! normalization factors using the exact method. It involves
573! computing the filter variance (convolution) at each point
574! independenly. That is, each point is perturbed with a delta
575! function, scaled by the inverse squared root of the area (2D)
576! or volume (3D), and then convoluted.
577!-----------------------------------------------------------------------
578!
579 IF (master) WRITE (stdout,10)
580
581 file_loop : DO ifile=1,nsa
582
583 IF (lwrtnrm(ifile,ng)) THEN
584 IF (ifile.eq.1) THEN
585 text='initial conditions'
586 ELSE IF (ifile.eq.2) THEN
587 text='model'
588 END IF
589!
590! Set time record index to write in normalization NetCDF file.
591!
592 ncname=nrm(ifile,ng)%name
593 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
594 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
595!
596! Write out model time (s).
597!
598 SELECT CASE (nrm(ifile,ng)%IOtype)
599 CASE (io_nf90)
600 CALL netcdf_put_fvar (ng, itlm, ncname, &
601 & vname(1,idtime), my_time, &
602 & start = (/nrm(ifile,ng)%Rindex/), &
603 & total = (/1/), &
604 & ncid = nrm(ifile,ng)%ncid, &
605 & varid = nrm(ifile,ng)%Vid(idtime))
606
607# if defined PIO_LIB && defined DISTRIBUTE
608 CASE (io_pio)
609 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
610 & vname(1,idtime), my_time, &
611 & start = (/nrm(ifile,ng)%Rindex/), &
612 & total = (/1/), &
613 & piofile = nrm(ifile,ng)%pioFile, &
614 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
615# endif
616 END SELECT
617 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
618!
619! 2D norm at RHO-points.
620!
621 IF (cnorm(ifile,isfsur)) THEN
622 imin=1
623 imax=lm(ng)
624 jmin=1
625 jmax=mm(ng)
626 IF (master) THEN
627 WRITE (stdout,20) trim(text), &
628 & '2D normalization factors at RHO-points'
629 FLUSH (stdout)
630 END IF
631 DO j=jstrt,jendt
632 DO i=istrt,iendt
633 hscale(i,j)=1.0_r8/sqrt(om_r(i,j)*on_r(i,j))
634 END DO
635 END DO
636 DO jc=jmin,jmax
637 DO ic=imin,imax
638# ifdef MASKING
639 compute=0.0_r8
640 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
641 & ((istr.le.ic).and.(ic.le.iend))) THEN
642 IF (rmask(ic,jc).gt.0) compute=1.0_r8
643 END IF
644# ifdef DISTRIBUTE
645 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
646# endif
647# else
648 compute=1.0_r8
649# endif
650 IF (compute.gt.0.0_r8) THEN
651 DO j=lbj,ubj
652 DO i=lbi,ubi
653 a2d(i,j)=0.0_r8
654 END DO
655 END DO
656 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
657 & ((istr.le.ic).and.(ic.le.iend))) THEN
658 a2d(ic,jc)=1.0_r8
659 END IF
660 CALL ad_conv_r2d_tile (ng, tile, iadm, &
661 & lbi, ubi, lbj, ubj, &
662 & imins, imaxs, jmins, jmaxs, &
663 & nghostpoints, &
664 & nhsteps(ifile,isfsur)/ifac, &
665 & dtsizeh(ifile,isfsur), &
666 & kh, &
667 & pm, pn, pmon_u, pnom_v, &
668# ifdef MASKING
669 & rmask, umask, vmask, &
670# endif
671 & a2d)
672 DO j=jstrt,jendt
673 DO i=istrt,iendt
674 a2d(i,j)=a2d(i,j)*hscale(i,j)
675 END DO
676 END DO
677!
678 my_dot=0.0_r8
679 DO j=jstrt,jendt
680 DO i=istrt,iendt
681 my_dot=my_dot+a2d(i,j)*a2d(i,j)
682 END DO
683 END DO
684!
685! Perform parallel global reduction operation: dot product.
686!
687# ifdef DISTRIBUTE
688 nsub=1 ! distributed-memory
689# else
690 IF (domain(ng)%SouthWest_Corner(tile).and. &
691 & domain(ng)%NorthEast_Corner(tile)) THEN
692 nsub=1 ! non-tiled application
693 ELSE
694 nsub=ntilex(ng)*ntilee(ng) ! tiled application
695 END IF
696# endif
697!$OMP CRITICAL (R2_DOT)
698 IF (tile_count.eq.0) THEN
699 gdotp=my_dot
700 ELSE
701 gdotp=gdotp+my_dot
702 END IF
703 tile_count=tile_count+1
704 IF (tile_count.eq.nsub) THEN
705 tile_count=0
706# ifdef DISTRIBUTE
707 op_handle='SUM'
708 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
709# endif
710 cff=1.0_r8/sqrt(gdotp)
711 END IF
712!$OMP END CRITICAL (R2_DOT)
713 ELSE
714 cff=0.0_r8
715 END IF
716 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
717 & ((istr.le.ic).and.(ic.le.iend))) THEN
718 hnormr(ic,jc,ifile)=cff
719 END IF
720 END DO
721 END DO
722 CALL dabc_r2d_tile (ng, tile, &
723 & lbi, ubi, lbj, ubj, &
724 & hnormr(:,:,ifile))
725# ifdef DISTRIBUTE
726 CALL mp_exchange2d (ng, tile, itlm, 1, &
727 & lbi, ubi, lbj, ubj, &
728 & nghostpoints, &
729 & ewperiodic(ng), nsperiodic(ng), &
730 & hnormr(:,:,ifile))
731# endif
732!
733 SELECT CASE (nrm(ifile,ng)%IOtype)
734 CASE (io_nf90)
735 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
736 & lbi, ubi, lbj, ubj, idfsur, &
737 & nrm(ifile,ng)%ncid, &
738 & nrm(ifile,ng)%Vid(idfsur), &
739 & nrm(ifile,ng)%Rindex, &
740# ifdef MASKING
741 & rmask, &
742# endif
743 & hnormr(:,:,ifile))
744
745# if defined PIO_LIB && defined DISTRIBUTE
746 CASE (io_pio)
747 IF (nrm(ifile,ng)%pioVar(idfsur)%dkind.eq. &
748 & pio_double) THEN
749 iodesc => iodesc_dp_r2dvar(ng)
750 ELSE
751 iodesc => iodesc_sp_r2dvar(ng)
752 END IF
753 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
754 & lbi, ubi, lbj, ubj, idfsur, &
755 & nrm(ifile,ng)%pioFile, &
756 & nrm(ifile,ng)%pioVar(idfsur), &
757 & nrm(ifile,ng)%Rindex, &
758 & iodesc, &
759# ifdef MASKING
760 & rmask, &
761# endif
762 & hnormr(:,:,ifile))
763# endif
764 END SELECT
765 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
766 END IF
767!
768! 2D norm at U-points.
769!
770 IF (cnorm(ifile,isubar)) THEN
771 IF (ewperiodic(ng)) THEN
772 imin=1
773 imax=lm(ng)
774 jmin=1
775 jmax=mm(ng)
776 ELSE
777 imin=2
778 imax=lm(ng)
779 jmin=1
780 jmax=mm(ng)
781 END IF
782 IF (master) THEN
783 WRITE (stdout,20) trim(text), &
784 & '2D normalization factors at U-points'
785 FLUSH (stdout)
786 END IF
787 DO j=jstrt,jendt
788 DO i=istrp,iendt
789 hscale(i,j)=1.0_r8/sqrt(om_u(i,j)*on_u(i,j))
790 END DO
791 END DO
792 DO jc=jmin,jmax
793 DO ic=imin,imax
794# ifdef MASKING
795 compute=0.0_r8
796 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
797 & ((istr.le.ic).and.(ic.le.iend))) THEN
798 IF (umask(ic,jc).gt.0) compute=1.0_r8
799 END IF
800# ifdef DISTRIBUTE
801 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
802# endif
803# else
804 compute=1.0_r8
805# endif
806 IF (compute.gt.0.0_r8) THEN
807 DO j=lbj,ubj
808 DO i=lbi,ubi
809 a2d(i,j)=0.0_r8
810 END DO
811 END DO
812 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
813 & ((istr.le.ic).and.(ic.le.iend))) THEN
814 a2d(ic,jc)=1.0_r8
815 END IF
816 CALL ad_conv_u2d_tile (ng, tile, iadm, &
817 & lbi, ubi, lbj, ubj, &
818 & imins, imaxs, jmins, jmaxs, &
819 & nghostpoints, &
820 & nhsteps(ifile,isubar)/ifac, &
821 & dtsizeh(ifile,isubar), &
822 & kh, &
823 & pm, pn, pmon_r, pnom_p, &
824# ifdef MASKING
825 & umask, pmask, &
826# endif
827 & a2d)
828 DO j=jstrt,jendt
829 DO i=istrp,iendt
830 a2d(i,j)=a2d(i,j)*hscale(i,j)
831 END DO
832 END DO
833!
834 my_dot=0.0_r8
835 DO j=jstrt,jendt
836 DO i=istrp,iendt
837 my_dot=my_dot+a2d(i,j)*a2d(i,j)
838 END DO
839 END DO
840
841!
842! Perform parallel global reduction operation: dot product.
843!
844# ifdef DISTRIBUTE
845 nsub=1 ! distributed-memory
846# else
847 IF (domain(ng)%SouthWest_Corner(tile).and. &
848 & domain(ng)%NorthEast_Corner(tile)) THEN
849 nsub=1 ! non-tiled application
850 ELSE
851 nsub=ntilex(ng)*ntilee(ng) ! tiled application
852 END IF
853# endif
854!$OMP CRITICAL (U2_DOT)
855 IF (tile_count.eq.0) THEN
856 gdotp=my_dot
857 ELSE
858 gdotp=gdotp+my_dot
859 END IF
860 tile_count=tile_count+1
861 IF (tile_count.eq.nsub) THEN
862 tile_count=0
863# ifdef DISTRIBUTE
864 op_handle='SUM'
865 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
866# endif
867 cff=1.0_r8/sqrt(gdotp)
868 END IF
869!$OMP END CRITICAL (U2_DOT)
870 ELSE
871 cff=0.0_r8
872 END IF
873 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
874 & ((istr.le.ic).and.(ic.le.iend))) THEN
875 hnormu(ic,jc,ifile)=cff
876 END IF
877 END DO
878 END DO
879 CALL dabc_u2d_tile (ng, tile, &
880 & lbi, ubi, lbj, ubj, &
881 & hnormu(:,:,ifile))
882# ifdef DISTRIBUTE
883 CALL mp_exchange2d (ng, tile, itlm, 1, &
884 & lbi, ubi, lbj, ubj, &
885 & nghostpoints, &
886 & ewperiodic(ng), nsperiodic(ng), &
887 & hnormu(:,:,ifile))
888# endif
889!
890 SELECT CASE (nrm(ifile,ng)%IOtype)
891 CASE (io_nf90)
892 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
893 & lbi, ubi, lbj, ubj, idubar, &
894 & nrm(ifile,ng)%ncid, &
895 & nrm(ifile,ng)%Vid(idubar), &
896 & nrm(ifile,ng)%Rindex, &
897# ifdef MASKING
898 & umask, &
899# endif
900 & hnormu(:,:,ifile))
901
902# if defined PIO_LIB && defined DISTRIBUTE
903 CASE (io_pio)
904 IF (nrm(ifile,ng)%pioVar(idubar)%dkind.eq. &
905 & pio_double) THEN
906 iodesc => iodesc_dp_u2dvar(ng)
907 ELSE
908 iodesc => iodesc_sp_u2dvar(ng)
909 END IF
910 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
911 & lbi, ubi, lbj, ubj, idubar, &
912 & nrm(ifile,ng)%pioFile, &
913 & nrm(ifile,ng)%pioVar(idubar), &
914 & nrm(ifile,ng)%Rindex, &
915 & iodesc, &
916# ifdef MASKING
917 & umask, &
918# endif
919 & hnormu(:,:,ifile))
920# endif
921 END SELECT
922 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
923 END IF
924!
925! 2D norm at V-points.
926!
927 IF (cnorm(ifile,isvbar)) THEN
928 IF (nsperiodic(ng)) THEN
929 imin=1
930 imax=lm(ng)
931 jmin=1
932 jmax=mm(ng)
933 ELSE
934 imin=1
935 imax=lm(ng)
936 jmin=2
937 jmax=mm(ng)
938 END IF
939 IF (master) THEN
940 WRITE (stdout,20) trim(text), &
941 & '2D normalization factors at V-points'
942 FLUSH (stdout)
943 END IF
944 DO j=jstrp,jendt
945 DO i=istrt,iendt
946 hscale(i,j)=1.0_r8/sqrt(om_v(i,j)*on_v(i,j))
947 END DO
948 END DO
949 DO jc=jmin,jmax
950 DO ic=imin,imax
951# ifdef MASKING
952 compute=0.0_r8
953 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
954 & ((istr.le.ic).and.(ic.le.iend))) THEN
955 IF (vmask(ic,jc).gt.0) compute=1.0_r8
956 END IF
957# ifdef DISTRIBUTE
958 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
959# endif
960# else
961 compute=1.0_r8
962# endif
963 IF (compute.gt.0.0_r8) THEN
964 DO j=lbj,ubj
965 DO i=lbi,ubi
966 a2d(i,j)=0.0_r8
967 END DO
968 END DO
969 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
970 & ((istr.le.ic).and.(ic.le.iend))) THEN
971 a2d(ic,jc)=1.0_r8
972 END IF
973 CALL ad_conv_v2d_tile (ng, tile, iadm, &
974 & lbi, ubi, lbj, ubj, &
975 & imins, imaxs, jmins, jmaxs, &
976 & nghostpoints, &
977 & nhsteps(ifile,isvbar)/ifac, &
978 & dtsizeh(ifile,isvbar), &
979 & kh, &
980 & pm, pn, pmon_p, pnom_r, &
981# ifdef MASKING
982 & vmask, pmask, &
983# endif
984 & a2d)
985 DO j=jstrp,jendt
986 DO i=istrt,iendt
987 a2d(i,j)=a2d(i,j)*hscale(i,j)
988 END DO
989 END DO
990!
991 my_dot=0.0_r8
992 DO j=jstrp,jendt
993 DO i=istrt,iendt
994 my_dot=my_dot+a2d(i,j)*a2d(i,j)
995 END DO
996 END DO
997!
998! Perform parallel global reduction operation: dot product.
999!
1000# ifdef DISTRIBUTE
1001 nsub=1 ! distributed-memory
1002# else
1003 IF (domain(ng)%SouthWest_Corner(tile).and. &
1004 & domain(ng)%NorthEast_Corner(tile)) THEN
1005 nsub=1 ! non-tiled application
1006 ELSE
1007 nsub=ntilex(ng)*ntilee(ng) ! tiled application
1008 END IF
1009# endif
1010!$OMP CRITICAL (V2_DOT)
1011 IF (tile_count.eq.0) THEN
1012 gdotp=my_dot
1013 ELSE
1014 gdotp=gdotp+my_dot
1015 END IF
1016 tile_count=tile_count+1
1017 IF (tile_count.eq.nsub) THEN
1018 tile_count=0
1019# ifdef DISTRIBUTE
1020 op_handle='SUM'
1021 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
1022# endif
1023 cff=1.0_r8/sqrt(gdotp)
1024 END IF
1025!$OMP END CRITICAL (V2_DOT)
1026 ELSE
1027 cff=0.0_r8
1028 END IF
1029 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1030 & ((istr.le.ic).and.(ic.le.iend))) THEN
1031 hnormv(ic,jc,ifile)=cff
1032 END IF
1033 END DO
1034 END DO
1035 CALL dabc_v2d_tile (ng, tile, &
1036 & lbi, ubi, lbj, ubj, &
1037 & hnormv(:,:,ifile))
1038# ifdef DISTRIBUTE
1039 CALL mp_exchange2d (ng, tile, itlm, 1, &
1040 & lbi, ubi, lbj, ubj, &
1041 & nghostpoints, &
1042 & ewperiodic(ng), nsperiodic(ng), &
1043 & hnormv(:,:,ifile))
1044# endif
1045!
1046 SELECT CASE (nrm(ifile,ng)%IOtype)
1047 CASE (io_nf90)
1048 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
1049 & lbi, ubi, lbj, ubj, idvbar, &
1050 & nrm(ifile,ng)%ncid, &
1051 & nrm(ifile,ng)%Vid(idvbar), &
1052 & nrm(ifile,ng)%Rindex, &
1053# ifdef MASKING
1054 & vmask, &
1055# endif
1056 & hnormv(:,:,ifile))
1057
1058# if defined PIO_LIB && defined DISTRIBUTE
1059 CASE (io_pio)
1060 IF (nrm(ifile,ng)%pioVar(idvbar)%dkind.eq. &
1061 & pio_double) THEN
1062 iodesc => iodesc_dp_v2dvar(ng)
1063 ELSE
1064 iodesc => iodesc_sp_v2dvar(ng)
1065 END IF
1066 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
1067 & lbi, ubi, lbj, ubj, idvbar, &
1068 & nrm(ifile,ng)%pioFile, &
1069 & nrm(ifile,ng)%pioVar(idvbar), &
1070 & nrm(ifile,ng)%Rindex, &
1071 & iodesc, &
1072# ifdef MASKING
1073 & vmask, &
1074# endif
1075 & hnormv(:,:,ifile))
1076# endif
1077 END SELECT
1078 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1079 END IF
1080
1081# ifdef SOLVE3D
1082!
1083! 3D norm U-points.
1084!
1085 IF (cnorm(ifile,isuvel)) THEN
1086 IF (ewperiodic(ng)) THEN
1087 imin=1
1088 imax=lm(ng)
1089 jmin=1
1090 jmax=mm(ng)
1091 ELSE
1092 imin=2
1093 imax=lm(ng)
1094 jmin=1
1095 jmax=mm(ng)
1096 END IF
1097 IF (master) THEN
1098 WRITE (stdout,20) trim(text), &
1099 & '3D normalization factors at U-points'
1100 FLUSH (stdout)
1101 END IF
1102 DO j=jstrt,jendt
1103 DO i=istrp,iendt
1104 cff=om_u(i,j)*on_u(i,j)*0.5_r8
1105 DO k=1,n(ng)
1106 vscale(i,j,k)=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
1107 END DO
1108 END DO
1109 END DO
1110 DO kc=1,n(ng)
1111 DO jc=jmin,jmax
1112 DO ic=imin,imax
1113# ifdef MASKING
1114 compute=0.0_r8
1115 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1116 & ((istr.le.ic).and.(ic.le.iend))) THEN
1117 IF (umask(ic,jc).gt.0) compute=1.0_r8
1118 END IF
1119# ifdef DISTRIBUTE
1120 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
1121# endif
1122# else
1123 compute=1.0_r8
1124# endif
1125 IF (compute.gt.0.0_r8) THEN
1126 DO k=1,n(ng)
1127 DO j=lbj,ubj
1128 DO i=lbi,ubi
1129 a3d(i,j,k)=0.0_r8
1130 END DO
1131 END DO
1132 END DO
1133 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1134 & ((istr.le.ic).and.(ic.le.iend))) THEN
1135 a3d(ic,jc,kc)=1.0_r8
1136 END IF
1137 CALL ad_conv_u3d_tile (ng, tile, iadm, &
1138 & lbi, ubi, lbj, ubj, &
1139 & 1, n(ng), &
1140 & imins, imaxs, jmins, jmaxs, &
1141 & nghostpoints, &
1142 & nhsteps(ifile,isuvel)/ifac, &
1143 & nvsteps(ifile,isuvel)/ifac, &
1144 & dtsizeh(ifile,isuvel), &
1145 & dtsizev(ifile,isuvel), &
1146 & kh, kv, &
1147 & pm, pn, &
1148# ifdef GEOPOTENTIAL_HCONV
1149 & on_r, om_p, &
1150# else
1151 & pmon_r, pnom_p, &
1152# endif
1153# ifdef MASKING
1154# ifdef GEOPOTENTIAL_HCONV
1155 & pmask, rmask, umask, vmask, &
1156# else
1157 & umask, pmask, &
1158# endif
1159# endif
1160 & hz, z_r, &
1161 & a3d)
1162 DO k=1,n(ng)
1163 DO j=jstrt,jendt
1164 DO i=istrp,iendt
1165 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
1166 END DO
1167 END DO
1168 END DO
1169!
1170 my_dot=0.0_r8
1171 DO k=1,n(ng)
1172 DO j=jstrt,jendt
1173 DO i=istrp,iendt
1174 my_dot=my_dot+a3d(i,j,k)*a3d(i,j,k)
1175 END DO
1176 END DO
1177 END DO
1178!
1179! Perform parallel global reduction operation: dot product.
1180!
1181# ifdef DISTRIBUTE
1182 nsub=1 ! distributed-memory
1183# else
1184 IF (domain(ng)%SouthWest_Corner(tile).and. &
1185 & domain(ng)%NorthEast_Corner(tile)) THEN
1186 nsub=1 ! non-tiled application
1187 ELSE
1188 nsub=ntilex(ng)*ntilee(ng) ! tiled application
1189 END IF
1190# endif
1191!$OMP CRITICAL (R3_DOT)
1192 IF (tile_count.eq.0) THEN
1193 gdotp=my_dot
1194 ELSE
1195 gdotp=gdotp+my_dot
1196 END IF
1197 tile_count=tile_count+1
1198 IF (tile_count.eq.nsub) THEN
1199 tile_count=0
1200# ifdef DISTRIBUTE
1201 op_handle='SUM'
1202 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
1203# endif
1204 cff=1.0_r8/sqrt(gdotp)
1205 END IF
1206!$OMP END CRITICAL (R3_DOT)
1207 ELSE
1208 cff=0.0_r8
1209 END IF
1210 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1211 & ((istr.le.ic).and.(ic.le.iend))) THEN
1212 vnormu(ic,jc,kc,ifile)=cff
1213 END IF
1214 END DO
1215 END DO
1216 END DO
1217 CALL dabc_u3d_tile (ng, tile, &
1218 & lbi, ubi, lbj, ubj, 1, n(ng), &
1219 & vnormu(:,:,:,ifile))
1220# ifdef DISTRIBUTE
1221 CALL mp_exchange3d (ng, tile, itlm, 1, &
1222 & lbi, ubi, lbj, ubj, 1, n(ng), &
1223 & nghostpoints, &
1224 & ewperiodic(ng), nsperiodic(ng), &
1225 & vnormu(:,:,:,ifile))
1226# endif
1227!
1228 SELECT CASE (nrm(ifile,ng)%IOtype)
1229 CASE (io_nf90)
1230 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
1231 & lbi, ubi, lbj, ubj, 1, n(ng), &
1232 & iduvel, nrm(ifile,ng)%ncid, &
1233 & nrm(ifile,ng)%Vid(iduvel), &
1234 & nrm(ifile,ng)%Rindex, &
1235# ifdef MASKING
1236 & umask, &
1237# endif
1238 & vnormu(:,:,:,ifile))
1239
1240# if defined PIO_LIB && defined DISTRIBUTE
1241 CASE (io_pio)
1242 IF (nrm(ifile,ng)%pioVar(iduvel)%dkind.eq. &
1243 & pio_double) THEN
1244 iodesc => iodesc_dp_u3dvar(ng)
1245 ELSE
1246 iodesc => iodesc_sp_u3dvar(ng)
1247 END IF
1248 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
1249 & lbi, ubi, lbj, ubj, 1, n(ng), &
1250 & iduvel, nrm(ifile,ng)%pioFile, &
1251 & nrm(ifile,ng)%pioVar(iduvel), &
1252 & nrm(ifile,ng)%Rindex, &
1253 & iodesc, &
1254# ifdef MASKING
1255 & umask, &
1256# endif
1257 & vnormu(:,:,:,ifile))
1258# endif
1259 END SELECT
1260 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1261 END IF
1262!
1263! 3D norm at V-points.
1264!
1265 IF (cnorm(ifile,isvvel)) THEN
1266 IF (nsperiodic(ng)) THEN
1267 imin=1
1268 imax=lm(ng)
1269 jmin=1
1270 jmax=mm(ng)
1271 ELSE
1272 imin=1
1273 imax=lm(ng)
1274 jmin=2
1275 jmax=mm(ng)
1276 END IF
1277 IF (master) THEN
1278 WRITE (stdout,20) trim(text), &
1279 & '3D normalization factors at V-points'
1280 FLUSH (stdout)
1281 END IF
1282 DO j=jstrp,jendt
1283 DO i=istrt,iendt
1284 cff=om_v(i,j)*on_v(i,j)*0.5_r8
1285 DO k=1,n(ng)
1286 vscale(i,j,k)=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
1287 END DO
1288 END DO
1289 END DO
1290 DO kc=1,n(ng)
1291 DO jc=jmin,jmax
1292 DO ic=imin,imax
1293# ifdef MASKING
1294 compute=0.0_r8
1295 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1296 & ((istr.le.ic).and.(ic.le.iend))) THEN
1297 IF (vmask(ic,jc).gt.0) compute=1.0_r8
1298 END IF
1299# ifdef DISTRIBUTE
1300 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
1301# endif
1302# else
1303 compute=1.0_r8
1304# endif
1305 IF (compute.gt.0.0_r8) THEN
1306 DO k=1,n(ng)
1307 DO j=lbj,ubj
1308 DO i=lbi,ubi
1309 a3d(i,j,k)=0.0_r8
1310 END DO
1311 END DO
1312 END DO
1313 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1314 & ((istr.le.ic).and.(ic.le.iend))) THEN
1315 a3d(ic,jc,kc)=1.0_r8
1316 END IF
1317 CALL ad_conv_v3d_tile (ng, tile, iadm, &
1318 & lbi, ubi, lbj, ubj, &
1319 & 1, n(ng), &
1320 & imins, imaxs, jmins, jmaxs, &
1321 & nghostpoints, &
1322 & nhsteps(ifile,isvvel)/ifac, &
1323 & nvsteps(ifile,isvvel)/ifac, &
1324 & dtsizeh(ifile,isvvel), &
1325 & dtsizev(ifile,isvvel), &
1326 & kh, kv, &
1327 & pm, pn, &
1328# ifdef GEOPOTENTIAL_HCONV
1329 & on_p, om_r, &
1330# else
1331 & pmon_p, pnom_r, &
1332# endif
1333# ifdef MASKING
1334# ifdef GEOPOTENTIAL_HCONV
1335 & pmask, rmask, umask, vmask, &
1336# else
1337 & vmask, pmask, &
1338# endif
1339# endif
1340 & hz, z_r, &
1341 & a3d)
1342 DO k=1,n(ng)
1343 DO j=jstrp,jendt
1344 DO i=istrt,iendt
1345 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
1346 END DO
1347 END DO
1348 END DO
1349!
1350 my_dot=0.0_r8
1351 DO k=1,n(ng)
1352 DO j=jstrp,jendt
1353 DO i=istrt,iendt
1354 my_dot=my_dot+a3d(i,j,k)*a3d(i,j,k)
1355 END DO
1356 END DO
1357 END DO
1358!
1359! Perform parallel global reduction operation: dot product.
1360!
1361# ifdef DISTRIBUTE
1362 nsub=1 ! distributed-memory
1363# else
1364 IF (domain(ng)%SouthWest_Corner(tile).and. &
1365 & domain(ng)%NorthEast_Corner(tile)) THEN
1366 nsub=1 ! non-tiled application
1367 ELSE
1368 nsub=ntilex(ng)*ntilee(ng) ! tiled application
1369 END IF
1370# endif
1371!$OMP CRITICAL (V3_DOT)
1372 IF (tile_count.eq.0) THEN
1373 gdotp=my_dot
1374 ELSE
1375 gdotp=gdotp+my_dot
1376 END IF
1377 tile_count=tile_count+1
1378 IF (tile_count.eq.nsub) THEN
1379 tile_count=0
1380# ifdef DISTRIBUTE
1381 op_handle='SUM'
1382 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
1383# endif
1384 cff=1.0_r8/sqrt(gdotp)
1385 END IF
1386!$OMP END CRITICAL (V3_DOT)
1387 ELSE
1388 cff=0.0_r8
1389 END IF
1390 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1391 & ((istr.le.ic).and.(ic.le.iend))) THEN
1392 vnormv(ic,jc,kc,ifile)=cff
1393 END IF
1394 END DO
1395 END DO
1396 END DO
1397 CALL dabc_v3d_tile (ng, tile, &
1398 & lbi, ubi, lbj, ubj, 1, n(ng), &
1399 & vnormv(:,:,:,ifile))
1400# ifdef DISTRIBUTE
1401 CALL mp_exchange3d (ng, tile, itlm, 1, &
1402 & lbi, ubi, lbj, ubj, 1, n(ng), &
1403 & nghostpoints, &
1404 & ewperiodic(ng), nsperiodic(ng), &
1405 & vnormv(:,:,:,ifile))
1406# endif
1407!
1408 SELECT CASE (nrm(ifile,ng)%IOtype)
1409 CASE (io_nf90)
1410 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
1411 & lbi, ubi, lbj, ubj, 1, n(ng), &
1412 & idvvel, nrm(ifile,ng)%ncid, &
1413 & nrm(ifile,ng)%Vid(idvvel), &
1414 & nrm(ifile,ng)%Rindex, &
1415# ifdef MASKING
1416 & vmask, &
1417# endif
1418 & vnormv(:,:,:,ifile))
1419
1420# if defined PIO_LIB && defined DISTRIBUTE
1421 CASE (io_pio)
1422 IF (nrm(ifile,ng)%pioVar(idvvel)%dkind.eq. &
1423 & pio_double) THEN
1424 iodesc => iodesc_dp_v3dvar(ng)
1425 ELSE
1426 iodesc => iodesc_sp_v3dvar(ng)
1427 END IF
1428 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
1429 & lbi, ubi, lbj, ubj, 1, n(ng), &
1430 & idvvel, nrm(ifile,ng)%pioFile, &
1431 & nrm(ifile,ng)%pioVar(idvvel), &
1432 & nrm(ifile,ng)%Rindex, &
1433 & iodesc, &
1434# ifdef MASKING
1435 & vmask, &
1436# endif
1437 & vnormv(:,:,:,ifile))
1438# endif
1439 END SELECT
1440 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1441 END IF
1442!
1443! 3D norm at RHO-points.
1444!
1445 IF (master) THEN
1446 lsame=.false.
1447 DO itrc=1,nt(ng)
1448 is=istvar(itrc)
1449 IF (cnorm(ifile,is)) lsame=.true.
1450 END DO
1451 IF (lsame) THEN
1452 WRITE (stdout,20) trim(text), &
1453 & '3D normalization factors at RHO-points'
1454 FLUSH (stdout)
1455 END IF
1456 END IF
1457!
1458! Check if the decorrelation scales for all the tracers are different.
1459! If not, just compute the normalization factors for the first tracer
1460! and assign the same value to the rest. Recall that this computation
1461! is very expensive.
1462!
1463 ldiffer=.false.
1464 imin=1
1465 imax=lm(ng)
1466 jmin=1
1467 jmax=mm(ng)
1468 DO itrc=2,nt(ng)
1469 IF ((hdecay(ifile,istvar(itrc ),ng).ne. &
1470 & hdecay(ifile,istvar(itrc-1),ng)).or. &
1471 & (vdecay(ifile,istvar(itrc ),ng).ne. &
1472 & vdecay(ifile,istvar(itrc-1),ng))) THEN
1473 ldiffer=.true.
1474 END IF
1475 END DO
1476 IF (.not.ldiffer) THEN
1477 lsame=.true.
1478 ubt=1
1479 ELSE
1480 lsame=.false.
1481 ubt=nt(ng)
1482 END IF
1483!
1484 DO j=jstrt,jendt
1485 DO i=istrt,iendt
1486 cff=om_r(i,j)*on_r(i,j)
1487 DO k=1,n(ng)
1488 vscale(i,j,k)=1.0_r8/sqrt(cff*hz(i,j,k))
1489 END DO
1490 END DO
1491 END DO
1492 DO itrc=1,ubt
1493 is=istvar(itrc)
1494 IF (cnorm(ifile,is)) THEN
1495 DO kc=1,n(ng)
1496 DO jc=jmin,jmax
1497 DO ic=imin,imax
1498# ifdef MASKING
1499 compute=0.0_r8
1500 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1501 & ((istr.le.ic).and.(ic.le.iend))) THEN
1502 IF (rmask(ic,jc).gt.0) compute=1.0_r8
1503 END IF
1504# ifdef DISTRIBUTE
1505 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
1506# endif
1507# else
1508 compute=1.0_r8
1509# endif
1510 IF (compute.gt.0.0_r8) THEN
1511 DO k=1,n(ng)
1512 DO j=lbj,ubj
1513 DO i=lbi,ubi
1514 a3d(i,j,k)=0.0_r8
1515 END DO
1516 END DO
1517 END DO
1518 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1519 & ((istr.le.ic).and.(ic.le.iend))) THEN
1520 a3d(ic,jc,kc)=1.0_r8
1521 END IF
1522 CALL ad_conv_r3d_tile (ng, tile, iadm, &
1523 & lbi, ubi, lbj, ubj, &
1524 & 1, n(ng), &
1525 & imins, imaxs, jmins, jmaxs,&
1526 & nghostpoints, &
1527 & nhsteps(ifile,is)/ifac, &
1528 & nvsteps(ifile,is)/ifac, &
1529 & dtsizeh(ifile,is), &
1530 & dtsizev(ifile,is), &
1531 & kh, kv, &
1532 & pm, pn, &
1533# ifdef GEOPOTENTIAL_HCONV
1534 & on_u, om_v, &
1535# else
1536 & pmon_u, pnom_v, &
1537# endif
1538# ifdef MASKING
1539 & rmask, umask, vmask, &
1540# endif
1541 & hz, z_r, &
1542 & a3d)
1543 DO k=1,n(ng)
1544 DO j=jstrt,jendt
1545 DO i=istrt,iendt
1546 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
1547 END DO
1548 END DO
1549 END DO
1550!
1551 my_dot=0.0_r8
1552 DO k=1,n(ng)
1553 DO j=jstrt,jendt
1554 DO i=istrt,iendt
1555 my_dot=my_dot+a3d(i,j,k)*a3d(i,j,k)
1556 END DO
1557 END DO
1558 END DO
1559!
1560! Perform parallel global reduction operation: dot product.
1561!
1562# ifdef DISTRIBUTE
1563 nsub=1 ! distributed-memory
1564# else
1565 IF (domain(ng)%SouthWest_Corner(tile).and. &
1566 & domain(ng)%NorthEast_Corner(tile)) THEN
1567 nsub=1 ! non-tiled application
1568 ELSE
1569 nsub=ntilex(ng)*ntilee(ng) ! tiled application
1570 END IF
1571# endif
1572!$OMP CRITICAL (R3_DOT)
1573 IF (tile_count.eq.0) THEN
1574 gdotp=my_dot
1575 ELSE
1576 gdotp=gdotp+my_dot
1577 END IF
1578 tile_count=tile_count+1
1579 IF (tile_count.eq.nsub) THEN
1580 tile_count=0
1581# ifdef DISTRIBUTE
1582 op_handle='SUM'
1583 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
1584# endif
1585 cff=1.0_r8/sqrt(gdotp)
1586 END IF
1587!$OMP END CRITICAL (R3_DOT)
1588 ELSE
1589 cff=0.0_r8
1590 END IF
1591 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
1592 & ((istr.le.ic).and.(ic.le.iend))) THEN
1593 IF (lsame) THEN
1594 DO ntrc=1,nt(ng)
1595 vnormr(ic,jc,kc,ifile,ntrc)=cff
1596 END DO
1597 ELSE
1598 vnormr(ic,jc,kc,ifile,itrc)=cff
1599 END IF
1600 END IF
1601 END DO
1602 END DO
1603 END DO
1604 END IF
1605 END DO
1606 DO itrc=1,nt(ng)
1607 is=istvar(itrc)
1608 IF (cnorm(ifile,is)) THEN
1609 CALL dabc_r3d_tile (ng, tile, &
1610 & lbi, ubi, lbj, ubj, 1, n(ng), &
1611 & vnormr(:,:,:,ifile,itrc))
1612# ifdef DISTRIBUTE
1613 CALL mp_exchange3d (ng, tile, itlm, 1, &
1614 & lbi, ubi, lbj, ubj, 1, n(ng), &
1615 & nghostpoints, &
1616 & ewperiodic(ng), nsperiodic(ng), &
1617 & vnormr(:,:,:,ifile,itrc))
1618# endif
1619!
1620 SELECT CASE (nrm(ifile,ng)%IOtype)
1621 CASE (io_nf90)
1622 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
1623 & lbi, ubi, lbj, ubj, 1, n(ng), &
1624 & idtvar(itrc), &
1625 & nrm(ifile,ng)%ncid, &
1626 & nrm(ifile,ng)%Vid(idtvar(itrc)), &
1627 & nrm(ifile,ng)%Rindex, &
1628# ifdef MASKING
1629 & rmask, &
1630# endif
1631 & vnormr(:,:,:,ifile,itrc))
1632
1633# if defined PIO_LIB && defined DISTRIBUTE
1634 CASE (io_pio)
1635 IF (nrm(ifile,ng)%pioTrc(itrc)%dkind.eq. &
1636 & pio_double) THEN
1637 iodesc => iodesc_dp_r3dvar(ng)
1638 ELSE
1639 iodesc => iodesc_sp_r3dvar(ng)
1640 END IF
1641 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
1642 & lbi, ubi, lbj, ubj, 1, n(ng), &
1643 & idtvar(itrc), &
1644 & nrm(ifile,ng)%pioFile, &
1645 & nrm(ifile,ng)%pioTrc(itrc), &
1646 & nrm(ifile,ng)%Rindex, &
1647 & iodesc, &
1648# ifdef MASKING
1649 & rmask, &
1650# endif
1651 & vnormr(:,:,:,ifile,itrc))
1652# endif
1653 END SELECT
1654 IF (founderror(exit_flag, noerror, &
1655 & __line__, myfile)) RETURN
1656 END IF
1657 END DO
1658# endif
1659 END IF
1660 END DO file_loop
1661
1662# ifdef ADJUST_BOUNDARY
1663!
1664!-----------------------------------------------------------------------
1665! Compute open boundaries error covariance, B, normalization factors
1666! using the exact method.
1667!-----------------------------------------------------------------------
1668!
1669 ifile=3
1670 IF (lwrtnrm(ifile,ng)) THEN
1671 text='boundary conditions'
1672 ijlen=ubij-lbij+1
1673# ifdef SOLVE3D
1674 ijklen=ijlen*n(ng)
1675# endif
1676 lconvolve(iwest )=domain(ng)%Western_Edge (tile)
1677 lconvolve(ieast )=domain(ng)%Eastern_Edge (tile)
1678 lconvolve(isouth)=domain(ng)%Southern_Edge(tile)
1679 lconvolve(inorth)=domain(ng)%Northern_Edge(tile)
1680!
1681! Set time record index to write in normalization NetCDF file.
1682!
1683 ncname=nrm(ifile,ng)%name
1684 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
1685 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
1686!
1687! Write out model time (s).
1688!
1689 my_time=tdays(ng)*day2sec
1690
1691 SELECT CASE (nrm(ifile,ng)%IOtype)
1692 CASE (io_nf90)
1693 CALL netcdf_put_fvar (ng, itlm, ncname, &
1694 & vname(1,idtime), my_time, &
1695 & start = (/nrm(ifile,ng)%Rindex/), &
1696 & total = (/1/), &
1697 & ncid = nrm(ifile,ng)%ncid, &
1698 & varid = nrm(ifile,ng)%Vid(idtime))
1699
1700# if defined PIO_LIB && defined DISTRIBUTE
1701 CASE (io_pio)
1702 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
1703 & vname(1,idtime), my_time, &
1704 & start = (/nrm(ifile,ng)%Rindex/), &
1705 & total = (/1/), &
1706 & piofile = nrm(ifile,ng)%pioFile, &
1707 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
1708# endif
1709 END SELECT
1710 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1711!
1712! 2D boundary norm at RHO-points.
1713!
1714 hnormrobc=aspv
1715
1716 IF (master.and.any(cnormb(isfsur,:))) THEN
1717 WRITE (stdout,20) trim(text), &
1718 & '2D normalization factors at RHO-points'
1719 FLUSH (stdout)
1720 END IF
1721
1722 DO ibry=1,4
1723 hscaleb=0.0_r8
1724 IF (cnormb(isfsur,ibry)) THEN
1725 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1726 i=bounds(ng)%edge(ibry,r2dvar)
1727 bmin=1
1728 bmax=mm(ng)
1729 IF (lconvolve(ibry)) THEN
1730 DO j=jstrt,jendt
1731 hscaleb(j)=1.0_r8/sqrt(on_r(i,j))
1732 END DO
1733 END IF
1734 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1735 j=bounds(ng)%edge(ibry,r2dvar)
1736 bmin=1
1737 bmax=lm(ng)
1738 IF (lconvolve(ibry)) THEN
1739 DO i=istrt,iendt
1740 hscaleb(i)=1.0_r8/sqrt(om_r(i,j))
1741 END DO
1742 END IF
1743 END IF
1744 DO ib=bmin,bmax
1745 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1746 bounded=lconvolve(ibry).and. &
1747 & ((jstr.le.ib).and.(ib.le.jend))
1748 j=ib
1749 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1750 bounded=lconvolve(ibry).and. &
1751 & ((istr.le.ib).and.(ib.le.iend))
1752 i=ib
1753 END IF
1754# ifdef MASKING
1755 IF (bounded) THEN
1756 compute=rmask(i,j)
1757 ELSE
1758 compute=0.0_r8
1759 END IF
1760# ifdef DISTRIBUTE
1761 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
1762# endif
1763# else
1764 compute=1.0_r8
1765# endif
1766 IF (compute.gt.0.0_r8) THEN
1767 b2d=0.0_r8
1768 IF (bounded) THEN
1769 b2d(ib)=1.0_r8
1770 END IF
1771 CALL ad_conv_r2d_bry_tile (ng, tile, iadm, ibry, &
1772 & bounds(ng)%edge(:,r2dvar), &
1773 & lbij, ubij, &
1774 & lbi, ubi, lbj, ubj, &
1775 & imins, imaxs, jmins, jmaxs, &
1776 & nghostpoints, &
1777 & nhstepsb(ibry,isfsur)/ifac, &
1778 & dtsizehb(ibry,isfsur), &
1779 & kh, &
1780 & pm, pn, pmon_u, pnom_v, &
1781# ifdef MASKING
1782 & rmask, umask, vmask, &
1783# endif
1784 & b2d)
1785!
1786! HscaleB must be applied twice.
1787!
1788 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1789 DO j=jstrt,jendt
1790 b2d(j)=b2d(j)*hscaleb(j)
1791 END DO
1792 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1793 DO i=istrt,iendt
1794 b2d(i)=b2d(i)*hscaleb(i)
1795 END DO
1796 END IF
1797!
1798 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1799 DO j=jstrt,jendt
1800 b2d(j)=b2d(j)*hscaleb(j)
1801 END DO
1802 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1803 DO i=istrt,iendt
1804 b2d(i)=b2d(i)*hscaleb(i)
1805 END DO
1806 END IF
1807 CALL tl_conv_r2d_bry_tile (ng, tile, itlm, ibry, &
1808 & bounds(ng)%edge(:,r2dvar), &
1809 & lbij, ubij, &
1810 & lbi, ubi, lbj, ubj, &
1811 & imins, imaxs, jmins, jmaxs, &
1812 & nghostpoints, &
1813 & nhstepsb(ibry,isfsur)/ifac, &
1814 & dtsizehb(ibry,isfsur), &
1815 & kh, &
1816 & pm, pn, pmon_u, pnom_v, &
1817# ifdef MASKING
1818 & rmask, umask, vmask, &
1819# endif
1820 & b2d)
1821 IF (bounded) THEN
1822 cff=1.0_r8/sqrt(b2d(ib))
1823 END IF
1824 ELSE
1825 cff=0.0_r8
1826 END IF
1827 IF (bounded) THEN
1828 hnormrobc(ib,ibry)=cff
1829 END IF
1830 END DO
1831 CALL bc_r2d_bry_tile (ng, tile, ibry, &
1832 & lbij, ubij, &
1833 & hnormrobc(:,ibry))
1834# ifdef DISTRIBUTE
1835 CALL mp_collect (ng, itlm, ijlen, aspv, &
1836 & hnormrobc(lbij:,ibry))
1837# endif
1838 END IF
1839 END DO
1840 IF (any(cnormb(isfsur,:))) THEN
1841 ifield=idsbry(isfsur)
1842
1843 SELECT CASE (nrm(ifile,ng)%IOtype)
1844 CASE (io_nf90)
1845 CALL netcdf_put_fvar (ng, itlm, ncname, &
1846 & vname(1,ifield), &
1847 & hnormrobc(lbij:,:), &
1848 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
1849 & total = (/ijlen,4,1/), &
1850 & ncid = nrm(ifile,ng)%ncid, &
1851 & varid = nrm(ifile,ng)%Vid(ifield))
1852
1853# if defined PIO_LIB && defined DISTRIBUTE
1854 CASE (io_pio)
1855 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
1856 & vname(1,ifield), &
1857 & hnormrobc(lbij:,:), &
1858 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
1859 & total = (/ijlen,4,1/), &
1860 & piofile = nrm(ifile,ng)%pioFile, &
1861 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
1862
1863# endif
1864 END SELECT
1865 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1866 END IF
1867!
1868! 2D boundary norm at U-points.
1869!
1870 hnormuobc=aspv
1871
1872 IF (master.and.any(cnormb(isubar,:))) THEN
1873 WRITE (stdout,20) trim(text), &
1874 & '2D normalization factors at U-points'
1875 FLUSH (stdout)
1876 END IF
1877
1878 DO ibry=1,4
1879 hscaleb=0.0_r8
1880 IF (cnormb(isubar,ibry)) THEN
1881 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1882 i=bounds(ng)%edge(ibry,u2dvar)
1883 bmin=1
1884 bmax=mm(ng)
1885 IF (lconvolve(ibry)) THEN
1886 DO j=jstrt,jendt
1887 hscaleb(j)=1.0_r8/sqrt(on_u(i,j))
1888 END DO
1889 END IF
1890 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1891 j=bounds(ng)%edge(ibry,u2dvar)
1892 IF (ewperiodic(ng)) THEN
1893 bmin=1
1894 bmax=lm(ng)
1895 ELSE
1896 bmin=2
1897 bmax=lm(ng)
1898 END IF
1899 IF (lconvolve(ibry)) THEN
1900 DO i=istrp,iendt
1901 hscaleb(i)=1.0_r8/sqrt(om_u(i,j))
1902 END DO
1903 END IF
1904 END IF
1905 DO ib=bmin,bmax
1906 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1907 bounded=lconvolve(ibry).and. &
1908 & ((jstr.le.ib).and.(ib.le.jend))
1909 j=ib
1910 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1911 bounded=lconvolve(ibry).and. &
1912 & ((istr.le.ib).and.(ib.le.iend))
1913 i=ib
1914 END IF
1915# ifdef MASKING
1916 IF (bounded) THEN
1917 compute=umask(i,j)
1918 ELSE
1919 compute=0.0_r8
1920 END IF
1921# ifdef DISTRIBUTE
1922 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
1923# endif
1924# else
1925 compute=1.0_r8
1926# endif
1927 IF (compute.gt.0.0_r8) THEN
1928 b2d=0.0_r8
1929 IF (bounded) THEN
1930 b2d(ib)=1.0_r8
1931 END IF
1932 CALL ad_conv_u2d_bry_tile (ng, tile, iadm, ibry, &
1933 & bounds(ng)%edge(:,u2dvar), &
1934 & lbij, ubij, &
1935 & lbi, ubi, lbj, ubj, &
1936 & imins, imaxs, jmins, jmaxs, &
1937 & nghostpoints, &
1938 & nhstepsb(ibry,isubar)/ifac, &
1939 & dtsizehb(ibry,isubar), &
1940 & kh, &
1941 & pm, pn, pmon_r, pnom_p, &
1942# ifdef MASKING
1943 & umask, pmask, &
1944# endif
1945 & b2d)
1946!
1947! HscaleB must be applied twice.
1948!
1949 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1950 DO j=jstrt,jendt
1951 b2d(j)=b2d(j)*hscaleb(j)
1952 END DO
1953 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1954 DO i=istrp,iendt
1955 b2d(i)=b2d(i)*hscaleb(i)
1956 END DO
1957 END IF
1958!
1959 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
1960 DO j=jstrt,jendt
1961 b2d(j)=b2d(j)*hscaleb(j)
1962 END DO
1963 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
1964 DO i=istrp,iendt
1965 b2d(i)=b2d(i)*hscaleb(i)
1966 END DO
1967 END IF
1968 CALL tl_conv_u2d_bry_tile (ng, tile, itlm, ibry, &
1969 & bounds(ng)%edge(:,u2dvar), &
1970 & lbij, ubij, &
1971 & lbi, ubi, lbj, ubj, &
1972 & imins, imaxs, jmins, jmaxs, &
1973 & nghostpoints, &
1974 & nhstepsb(ibry,isubar)/ifac, &
1975 & dtsizehb(ibry,isubar), &
1976 & kh, &
1977 & pm, pn, pmon_r, pnom_p, &
1978# ifdef MASKING
1979 & umask, pmask, &
1980# endif
1981 & b2d)
1982 IF (bounded) THEN
1983 cff=1.0_r8/sqrt(b2d(ib))
1984 END IF
1985 ELSE
1986 cff=0.0_r8
1987 END IF
1988 IF (bounded) THEN
1989 hnormuobc(ib,ibry)=cff
1990 END IF
1991 END DO
1992 CALL bc_u2d_bry_tile (ng, tile, ibry, &
1993 & lbij, ubij, &
1994 & hnormuobc(:,ibry))
1995# ifdef DISTRIBUTE
1996 CALL mp_collect (ng, itlm, ijlen, aspv, &
1997 & hnormuobc(lbij:,ibry))
1998# endif
1999 END IF
2000 END DO
2001 IF (any(cnormb(isubar,:))) THEN
2002 ifield=idsbry(isubar)
2003
2004 SELECT CASE (nrm(ifile,ng)%IOtype)
2005 CASE (io_nf90)
2006 CALL netcdf_put_fvar (ng, itlm, ncname, &
2007 & vname(1,ifield), &
2008 & hnormuobc(lbij:,:), &
2009 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
2010 & total = (/ijlen,4,1/), &
2011 & ncid = nrm(ifile,ng)%ncid, &
2012 & varid = nrm(ifile,ng)%Vid(ifield))
2013
2014# if defined PIO_LIB && defined DISTRIBUTE
2015 CASE (io_pio)
2016 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
2017 & vname(1,ifield), &
2018 & hnormuobc(lbij:,:), &
2019 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
2020 & total = (/ijlen,4,1/), &
2021 & piofile = nrm(ifile,ng)%pioFile, &
2022 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
2023# endif
2024 END SELECT
2025 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2026 END IF
2027!
2028! 2D boundary norm at V-points.
2029!
2030 hnormvobc=aspv
2031
2032 IF (master.and.any(cnormb(isvbar,:))) THEN
2033 WRITE (stdout,20) trim(text), &
2034 & '2D normalization factors at V-points'
2035 FLUSH (stdout)
2036 END IF
2037
2038 DO ibry=1,4
2039 hscaleb=0.0_r8
2040 IF (cnormb(isvbar,ibry)) THEN
2041 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2042 i=bounds(ng)%edge(ibry,v2dvar)
2043 IF (nsperiodic(ng)) THEN
2044 bmin=1
2045 bmax=mm(ng)
2046 ELSE
2047 bmin=2
2048 bmax=mm(ng)
2049 END IF
2050 IF (lconvolve(ibry)) THEN
2051 DO j=jstrt,jendt
2052 hscaleb(j)=1.0_r8/sqrt(on_v(i,j))
2053 END DO
2054 END IF
2055 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2056 j=bounds(ng)%edge(ibry,v2dvar)
2057 bmin=1
2058 bmax=lm(ng)
2059 IF (lconvolve(ibry)) THEN
2060 DO i=istrt,iendt
2061 hscaleb(i)=1.0_r8/sqrt(om_v(i,j))
2062 END DO
2063 END IF
2064 END IF
2065 DO ib=bmin,bmax
2066 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2067 bounded=lconvolve(ibry).and. &
2068 & ((jstr.le.ib).and.(ib.le.jend))
2069 j=ib
2070 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2071 bounded=lconvolve(ibry).and. &
2072 & ((istr.le.ib).and.(ib.le.iend))
2073 i=ib
2074 END IF
2075# ifdef MASKING
2076 IF (bounded) THEN
2077 compute=vmask(i,j)
2078 ELSE
2079 compute=0.0_r8
2080 END IF
2081# ifdef DISTRIBUTE
2082 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
2083# endif
2084# else
2085 compute=1.0_r8
2086# endif
2087 IF (compute.gt.0.0_r8) THEN
2088 b2d=0.0_r8
2089 IF (bounded) THEN
2090 b2d(ib)=1.0_r8
2091 END IF
2092 CALL ad_conv_v2d_bry_tile (ng, tile, iadm, ibry, &
2093 & bounds(ng)%edge(:,v2dvar), &
2094 & lbij, ubij, &
2095 & lbi, ubi, lbj, ubj, &
2096 & imins, imaxs, jmins, jmaxs, &
2097 & nghostpoints, &
2098 & nhstepsb(ibry,isvbar)/ifac, &
2099 & dtsizehb(ibry,isvbar), &
2100 & kh, &
2101 & pm, pn, pmon_p, pnom_r, &
2102# ifdef MASKING
2103 & vmask, pmask, &
2104# endif
2105 & b2d)
2106!
2107! HscaleB must be applied twice.
2108!
2109 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2110 DO j=jstrp,jendt
2111 b2d(j)=b2d(j)*hscaleb(j)
2112 END DO
2113 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2114 DO i=istrt,iendt
2115 b2d(i)=b2d(i)*hscaleb(i)
2116 END DO
2117 END IF
2118!
2119 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2120 DO j=jstrp,jendt
2121 b2d(j)=b2d(j)*hscaleb(j)
2122 END DO
2123 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2124 DO i=istrt,iendt
2125 b2d(i)=b2d(i)*hscaleb(i)
2126 END DO
2127 END IF
2128 CALL tl_conv_v2d_bry_tile (ng, tile, itlm, ibry, &
2129 & bounds(ng)%edge(:,v2dvar), &
2130 & lbij, ubij, &
2131 & lbi, ubi, lbj, ubj, &
2132 & imins, imaxs, jmins, jmaxs, &
2133 & nghostpoints, &
2134 & nhstepsb(ibry,isvbar)/ifac, &
2135 & dtsizehb(ibry,isvbar), &
2136 & kh, &
2137 & pm, pn, pmon_p, pnom_r, &
2138# ifdef MASKING
2139 & vmask, pmask, &
2140# endif
2141 & b2d)
2142 IF (bounded) THEN
2143 cff=1.0_r8/sqrt(b2d(ib))
2144 END IF
2145 ELSE
2146 cff=0.0_r8
2147 END IF
2148 IF (bounded) THEN
2149 hnormvobc(ib,ibry)=cff
2150 END IF
2151 END DO
2152 CALL bc_v2d_bry_tile (ng, tile, ibry, &
2153 & lbij, ubij, &
2154 & hnormvobc(:,ibry))
2155# ifdef DISTRIBUTE
2156 CALL mp_collect (ng, itlm, ijlen, aspv, &
2157 & hnormvobc(lbij:,ibry))
2158# endif
2159 END IF
2160 END DO
2161 IF (any(cnormb(isvbar,:))) THEN
2162 ifield=idsbry(isvbar)
2163
2164 SELECT CASE (nrm(ifile,ng)%IOtype)
2165 CASE (io_nf90)
2166 CALL netcdf_put_fvar (ng, itlm, ncname, &
2167 & vname(1,ifield), &
2168 & hnormvobc(lbij:,:), &
2169 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
2170 & total = (/ijlen,4,1/), &
2171 & ncid = nrm(ifile,ng)%ncid, &
2172 & varid = nrm(ifile,ng)%Vid(ifield))
2173
2174# if defined PIO_LIB && defined DISTRIBUTE
2175 CASE (io_pio)
2176 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
2177 & vname(1,ifield), &
2178 & hnormvobc(lbij:,:), &
2179 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
2180 & total = (/ijlen,4,1/), &
2181 & piofile = nrm(ifile,ng)%pioFile, &
2182 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
2183# endif
2184 END SELECT
2185 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2186 END IF
2187
2188# ifdef SOLVE3D
2189!
2190! 3D boundary norm at U-points.
2191!
2192 vnormuobc=aspv
2193
2194 IF (master.and.any(cnormb(isuvel,:))) THEN
2195 WRITE (stdout,20) trim(text), &
2196 & '3D normalization factors at U-points'
2197 FLUSH (stdout)
2198 END IF
2199
2200 DO ibry=1,4
2201 vscaleb=0.0_r8
2202 IF (cnormb(isuvel,ibry)) THEN
2203 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2204 i=bounds(ng)%edge(ibry,u2dvar)
2205 bmin=1
2206 bmax=mm(ng)
2207 IF (lconvolve(ibry)) THEN
2208 DO j=jstrt,jendt
2209 cff=on_u(i,j)*0.5_r8
2210 DO k=1,n(ng)
2211 vscaleb(j,k)=1.0_r8/ &
2212 & sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
2213 END DO
2214 END DO
2215 END IF
2216 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2217 j=bounds(ng)%edge(ibry,u2dvar)
2218 IF (ewperiodic(ng)) THEN
2219 bmin=1
2220 bmax=lm(ng)
2221 ELSE
2222 bmin=2
2223 bmax=lm(ng)
2224 END IF
2225 IF (lconvolve(ibry)) THEN
2226 DO i=istrp,iendt
2227 cff=om_u(i,j)*0.5_r8
2228 DO k=1,n(ng)
2229 vscaleb(i,k)=1.0_r8/ &
2230 & sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
2231 END DO
2232 END DO
2233 END IF
2234 END IF
2235 DO kb=1,n(ng)
2236 DO ib=bmin,bmax
2237 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2238 bounded=lconvolve(ibry).and. &
2239 & ((jstr.le.ib).and.(ib.le.jend))
2240 j=ib
2241 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2242 bounded=lconvolve(ibry).and. &
2243 & ((istr.le.ib).and.(ib.le.iend))
2244 i=ib
2245 END IF
2246# ifdef MASKING
2247 IF (bounded) THEN
2248 compute=umask(i,j)
2249 ELSE
2250 compute=0.0_r8
2251 END IF
2252# ifdef DISTRIBUTE
2253 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
2254# endif
2255# else
2256 compute=1.0_r8
2257# endif
2258 IF (compute.gt.0.0_r8) THEN
2259 b3d=0.0_r8
2260 IF (bounded) THEN
2261 b3d(ib,kb)=1.0_r8
2262 END IF
2263 CALL ad_conv_u3d_bry_tile (ng, tile, iadm, ibry, &
2264 & bounds(ng)%edge(:,u2dvar), &
2265 & lbij, ubij, &
2266 & lbi, ubi, lbj, ubj, &
2267 & 1, n(ng), &
2268 & imins, imaxs, jmins, jmaxs,&
2269 & nghostpoints, &
2270 & nhstepsb(ibry,isuvel)/ifac,&
2271 & nvstepsb(ibry,isuvel)/ifac,&
2272 & dtsizehb(ibry,isuvel), &
2273 & dtsizevb(ibry,isuvel), &
2274 & kh, kv, &
2275 & pm, pn, pmon_r, pnom_p, &
2276# ifdef MASKING
2277 & umask, pmask, &
2278# endif
2279 & hz, z_r, &
2280 & b3d)
2281!
2282! VscaleB must be applied twice.
2283!
2284 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2285 DO k=1,n(ng)
2286 DO j=jstrt,jendt
2287 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
2288 END DO
2289 END DO
2290 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2291 DO k=1,n(ng)
2292 DO i=istrp,iendt
2293 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
2294 END DO
2295 END DO
2296 END IF
2297!
2298 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2299 DO k=1,n(ng)
2300 DO j=jstrt,jendt
2301 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
2302 END DO
2303 END DO
2304 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2305 DO k=1,n(ng)
2306 DO i=istrp,iendt
2307 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
2308 END DO
2309 END DO
2310 END IF
2311 CALL tl_conv_u3d_bry_tile (ng, tile, itlm, ibry, &
2312 & bounds(ng)%edge(:,u2dvar), &
2313 & lbij, ubij, &
2314 & lbi, ubi, lbj, ubj, &
2315 & 1, n(ng), &
2316 & imins, imaxs, jmins, jmaxs,&
2317 & nghostpoints, &
2318 & nhstepsb(ibry,isuvel)/ifac,&
2319 & nvstepsb(ibry,isuvel)/ifac,&
2320 & dtsizehb(ibry,isuvel), &
2321 & dtsizevb(ibry,isuvel), &
2322 & kh, kv, &
2323 & pm, pn, pmon_r, pnom_p, &
2324# ifdef MASKING
2325 & umask, pmask, &
2326# endif
2327 & hz, z_r, &
2328 & b3d)
2329 IF (bounded) THEN
2330 cff=1.0_r8/sqrt(b3d(ib,kb))
2331 END IF
2332 ELSE
2333 cff=0.0_r8
2334 END IF
2335 IF (bounded) THEN
2336 vnormuobc(ib,kb,ibry)=cff
2337 END IF
2338 END DO
2339 END DO
2340 CALL bc_u3d_bry_tile (ng, tile, ibry, &
2341 & lbij, ubij, 1, n(ng), &
2342 & vnormuobc(:,:,ibry))
2343# ifdef DISTRIBUTE
2344 bwrk=reshape(vnormuobc(:,:,ibry), (/ijklen/))
2345 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
2346 ic=0
2347 DO k=1,n(ng)
2348 DO ib=lbij,ubij
2349 ic=ic+1
2350 vnormuobc(ib,k,ibry)=bwrk(ic)
2351 END DO
2352 END DO
2353# endif
2354 END IF
2355 END DO
2356 IF (any(cnormb(isuvel,:))) THEN
2357 ifield=idsbry(isuvel)
2358
2359 SELECT CASE (nrm(ifile,ng)%IOtype)
2360 CASE (io_nf90)
2361 CALL netcdf_put_fvar (ng, itlm, ncname, &
2362 & vname(1,ifield), &
2363 & vnormuobc(lbij:,:,:), &
2364 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
2365 & total = (/ijlen,n(ng),4,1/), &
2366 & ncid = nrm(ifile,ng)%ncid, &
2367 & varid = nrm(ifile,ng)%Vid(ifield))
2368
2369# if defined PIO_LIB && defined DISTRIBUTE
2370 CASE (io_pio)
2371 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
2372 & vname(1,ifield), &
2373 & vnormuobc(lbij:,:,:), &
2374 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
2375 & total = (/ijlen,n(ng),4,1/), &
2376 & piofile = nrm(ifile,ng)%pioFile, &
2377 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
2378# endif
2379 END SELECT
2380 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2381 END IF
2382!
2383! 3D boundary norm at V-points.
2384!
2385 vnormvobc=aspv
2386
2387 IF (master.and.any(cnormb(isvvel,:))) THEN
2388 WRITE (stdout,20) trim(text), &
2389 & '3D normalization factors at V-points'
2390 FLUSH (stdout)
2391 END IF
2392
2393 DO ibry=1,4
2394 vscaleb=0.0_r8
2395 IF (cnormb(isvvel,ibry)) THEN
2396 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2397 i=bounds(ng)%edge(ibry,v2dvar)
2398 IF (nsperiodic(ng)) THEN
2399 bmin=1
2400 bmax=mm(ng)
2401 ELSE
2402 bmin=2
2403 bmax=mm(ng)
2404 END IF
2405 IF (lconvolve(ibry)) THEN
2406 DO j=jstrp,jendt
2407 cff=on_v(i,j)*0.5_r8
2408 DO k=1,n(ng)
2409 vscaleb(j,k)=1.0_r8/ &
2410 & sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
2411 END DO
2412 END DO
2413 END IF
2414 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2415 j=bounds(ng)%edge(ibry,v2dvar)
2416 bmin=1
2417 bmax=lm(ng)
2418 IF (lconvolve(ibry)) THEN
2419 DO i=istrt,iendt
2420 cff=om_v(i,j)*0.5_r8
2421 DO k=1,n(ng)
2422 vscaleb(i,k)=1.0_r8/ &
2423 & sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
2424 END DO
2425 END DO
2426 END IF
2427 END IF
2428 DO kb=1,n(ng)
2429 DO ib=bmin,bmax
2430 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2431 bounded=lconvolve(ibry).and. &
2432 & ((jstr.le.ib).and.(ib.le.jend))
2433 j=ib
2434 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2435 bounded=lconvolve(ibry).and. &
2436 & ((istr.le.ib).and.(ib.le.iend))
2437 i=ib
2438 END IF
2439# ifdef MASKING
2440 IF (bounded) THEN
2441 compute=vmask(i,j)
2442 ELSE
2443 compute=0.0_r8
2444 END IF
2445# ifdef DISTRIBUTE
2446 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
2447# endif
2448# else
2449 compute=1.0_r8
2450# endif
2451 IF (compute.gt.0.0_r8) THEN
2452 b3d=0.0_r8
2453 IF (bounded) THEN
2454 b3d(ib,kb)=1.0_r8
2455 END IF
2456 CALL ad_conv_v3d_bry_tile (ng, tile, iadm, ibry, &
2457 & bounds(ng)%edge(:,v2dvar), &
2458 & lbij, ubij, &
2459 & lbi, ubi, lbj, ubj, &
2460 & 1, n(ng), &
2461 & imins, imaxs, jmins, jmaxs,&
2462 & nghostpoints, &
2463 & nhstepsb(ibry,isvvel)/ifac,&
2464 & nvstepsb(ibry,isvvel)/ifac,&
2465 & dtsizehb(ibry,isvvel), &
2466 & dtsizevb(ibry,isvvel), &
2467 & kh, kv, &
2468 & pm, pn, pmon_p, pnom_r, &
2469# ifdef MASKING
2470 & vmask, pmask, &
2471# endif
2472 & hz, z_r, &
2473 & b3d)
2474!
2475! VscaleB must be applied twice.
2476!
2477 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2478 DO k=1,n(ng)
2479 DO j=jstrp,jendt
2480 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
2481 END DO
2482 END DO
2483 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2484 DO k=1,n(ng)
2485 DO i=istrt,iendt
2486 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
2487 END DO
2488 END DO
2489 END IF
2490!
2491 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2492 DO k=1,n(ng)
2493 DO j=jstrp,jendt
2494 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
2495 END DO
2496 END DO
2497 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2498 DO k=1,n(ng)
2499 DO i=istrt,iendt
2500 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
2501 END DO
2502 END DO
2503 END IF
2504 CALL tl_conv_v3d_bry_tile (ng, tile, itlm, ibry, &
2505 & bounds(ng)%edge(:,v2dvar), &
2506 & lbij, ubij, &
2507 & lbi, ubi, lbj, ubj, &
2508 & 1, n(ng), &
2509 & imins, imaxs, jmins, jmaxs,&
2510 & nghostpoints, &
2511 & nhstepsb(ibry,isvvel)/ifac,&
2512 & nvstepsb(ibry,isvvel)/ifac,&
2513 & dtsizehb(ibry,isvvel), &
2514 & dtsizevb(ibry,isvvel), &
2515 & kh, kv, &
2516 & pm, pn, pmon_p, pnom_r, &
2517# ifdef MASKING
2518 & vmask, pmask, &
2519# endif
2520 & hz, z_r, &
2521 & b3d)
2522 IF (bounded) THEN
2523 cff=1.0_r8/sqrt(b3d(ib,kb))
2524 END IF
2525 ELSE
2526 cff=0.0_r8
2527 END IF
2528 IF (bounded) THEN
2529 vnormvobc(ib,kb,ibry)=cff
2530 END IF
2531 END DO
2532 END DO
2533 CALL bc_v3d_bry_tile (ng, tile, ibry, &
2534 & lbij, ubij, 1, n(ng), &
2535 & vnormvobc(:,:,ibry))
2536# ifdef DISTRIBUTE
2537 bwrk=reshape(vnormvobc(:,:,ibry), (/ijklen/))
2538 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
2539 ic=0
2540 DO k=1,n(ng)
2541 DO ib=lbij,ubij
2542 ic=ic+1
2543 vnormvobc(ib,k,ibry)=bwrk(ic)
2544 END DO
2545 END DO
2546# endif
2547 END IF
2548 END DO
2549 IF (any(cnormb(isvvel,:))) THEN
2550 ifield=idsbry(isvvel)
2551
2552 SELECT CASE (nrm(ifile,ng)%IOtype)
2553 CASE (io_nf90)
2554 CALL netcdf_put_fvar (ng, itlm, ncname, &
2555 & vname(1,ifield), &
2556 & vnormvobc(lbij:,:,:), &
2557 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
2558 & total = (/ijlen,n(ng),4,1/), &
2559 & ncid = nrm(ifile,ng)%ncid, &
2560 & varid = nrm(ifile,ng)%Vid(ifield))
2561
2562# if defined PIO_LIB && defined DISTRIBUTE
2563 CASE (io_pio)
2564 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
2565 & vname(1,ifield), &
2566 & vnormvobc(lbij:,:,:), &
2567 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
2568 & total = (/ijlen,n(ng),4,1/), &
2569 & piofile = nrm(ifile,ng)%pioFile, &
2570 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
2571# endif
2572 END SELECT
2573 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2574 END IF
2575!
2576! 3D boundary norm at RHO-points.
2577!
2578 IF (master) THEN
2579 DO itrc=1,nt(ng)
2580 is=istvar(itrc)
2581 IF (any(cnormb(is,:))) THEN
2582 lsame=.true.
2583 EXIT
2584 END IF
2585 END DO
2586 IF (lsame) THEN
2587 WRITE (stdout,20) trim(text), &
2588 & '3D normalization factors at RHO-points'
2589 FLUSH (stdout)
2590 END IF
2591 END IF
2592
2593 DO itrc=1,nt(ng)
2594 vnormrobc=aspv
2595 is=istvar(itrc)
2596 DO ibry=1,4
2597 vscaleb=0.0_r8
2598 IF (cnormb(is,ibry)) THEN
2599 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2600 i=bounds(ng)%edge(ibry,r2dvar)
2601 bmin=2
2602 bmax=mm(ng)
2603 IF (lconvolve(ibry)) THEN
2604 DO j=jstrt,jendt
2605 cff=on_r(i,j)
2606 DO k=1,n(ng)
2607 vscaleb(j,k)=1.0_r8/sqrt(cff*hz(i,j,k))
2608 END DO
2609 END DO
2610 END IF
2611 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2612 j=bounds(ng)%edge(ibry,r2dvar)
2613 bmin=1
2614 bmax=lm(ng)
2615 IF (lconvolve(ibry)) THEN
2616 DO i=istrt,iendt
2617 cff=om_r(i,j)
2618 DO k=1,n(ng)
2619 vscaleb(i,k)=1.0_r8/sqrt(cff*hz(i,j,k))
2620 END DO
2621 END DO
2622 END IF
2623 END IF
2624 DO kb=1,n(ng)
2625 DO ib=bmin,bmax
2626 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2627 bounded=lconvolve(ibry).and. &
2628 & ((jstr.le.ib).and.(ib.le.jend))
2629 j=ib
2630 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2631 bounded=lconvolve(ibry).and. &
2632 & ((istr.le.ib).and.(ib.le.iend))
2633 i=ib
2634 END IF
2635# ifdef MASKING
2636 IF (bounded) THEN
2637 compute=rmask(i,j)
2638 ELSE
2639 compute=0.0_r8
2640 END IF
2641# ifdef DISTRIBUTE
2642 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
2643# endif
2644# else
2645 compute=1.0_r8
2646# endif
2647 IF (compute.gt.0.0_r8) THEN
2648 b3d=0.0_r8
2649 IF (bounded) THEN
2650 b3d(ib,kb)=1.0_r8
2651 END IF
2652 CALL ad_conv_r3d_bry_tile (ng, tile, iadm, ibry, &
2653 & bounds(ng)%edge(:, &
2654 & r2dvar), &
2655 & lbij, ubij, &
2656 & lbi, ubi, lbj, ubj, &
2657 & 1, n(ng), &
2658 & imins, imaxs, &
2659 & jmins, jmaxs, &
2660 & nghostpoints, &
2661 & nhstepsb(ibry,is)/ifac, &
2662 & nvstepsb(ibry,is)/ifac, &
2663 & dtsizehb(ibry,is), &
2664 & dtsizevb(ibry,is), &
2665 & kh, kv, &
2666 & pm, pn, pmon_u, pnom_v, &
2667# ifdef MASKING
2668 & rmask, umask, vmask, &
2669# endif
2670 & hz, z_r, &
2671 & b3d)
2672!
2673! VscaleB must be applied twice.
2674!
2675 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2676 DO k=1,n(ng)
2677 DO j=jstrt,jendt
2678 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
2679 END DO
2680 END DO
2681 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2682 DO k=1,n(ng)
2683 DO i=istrt,iendt
2684 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
2685 END DO
2686 END DO
2687 END IF
2688 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
2689 DO k=1,n(ng)
2690 DO j=jstrt,jendt
2691 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
2692 END DO
2693 END DO
2694 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
2695 DO k=1,n(ng)
2696 DO i=istrt,iendt
2697 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
2698 END DO
2699 END DO
2700 END IF
2701 CALL tl_conv_r3d_bry_tile (ng, tile, itlm, ibry, &
2702 & bounds(ng)%edge(:, &
2703 & r2dvar), &
2704 & lbij, ubij, &
2705 & lbi, ubi, lbj, ubj, &
2706 & 1, n(ng), &
2707 & imins, imaxs, &
2708 & jmins, jmaxs, &
2709 & nghostpoints, &
2710 & nhstepsb(ibry,is)/ifac, &
2711 & nvstepsb(ibry,is)/ifac, &
2712 & dtsizehb(ibry,is), &
2713 & dtsizevb(ibry,is), &
2714 & kh, kv, &
2715 & pm, pn, pmon_u, pnom_v, &
2716# ifdef MASKING
2717 & rmask, umask, vmask, &
2718# endif
2719 & hz, z_r, &
2720 & b3d)
2721 IF (bounded) THEN
2722 cff=1.0_r8/sqrt(b3d(ib,kb))
2723 END IF
2724 ELSE
2725 cff=0.0_r8
2726 END IF
2727 IF (bounded) THEN
2728 vnormrobc(ib,kb,ibry,itrc)=cff
2729 END IF
2730 END DO
2731 END DO
2732 CALL bc_r3d_bry_tile (ng, tile, ibry, &
2733 & lbij, ubij, 1, n(ng), &
2734 & vnormrobc(:,:,ibry,itrc))
2735# ifdef DISTRIBUTE
2736 bwrk=reshape(vnormrobc(:,:,ibry,itrc), (/ijklen/))
2737 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
2738 ic=0
2739 DO k=1,n(ng)
2740 DO ib=lbij,ubij
2741 ic=ic+1
2742 vnormrobc(ib,k,ibry,itrc)=bwrk(ic)
2743 END DO
2744 END DO
2745# endif
2746 END IF
2747 END DO
2748 IF (any(cnormb(is,:))) THEN
2749 ifield=idsbry(istvar(itrc))
2750
2751 SELECT CASE (nrm(ifile,ng)%IOtype)
2752 CASE (io_nf90)
2753 CALL netcdf_put_fvar (ng, itlm, ncname, &
2754 & vname(1,ifield), &
2755 & vnormrobc(lbij:,:,:,itrc), &
2756 & start =(/1,1,1,nrm(ifile,ng)%Rindex/), &
2757 & total = (/ijlen,n(ng),4,1/), &
2758 & ncid = nrm(ifile,ng)%ncid, &
2759 & varid = nrm(ifile,ng)%Vid(ifield))
2760
2761# if defined PIO_LIB && defined DISTRIBUTE
2762 CASE (io_pio)
2763 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
2764 & vname(1,ifield), &
2765 & vnormrobc(lbij:,:,:,itrc), &
2766 & start =(/1,1,1,nrm(ifile,ng)%Rindex/), &
2767 & total = (/ijlen,n(ng),4,1/), &
2768 & piofile = nrm(ifile,ng)%pioFile, &
2769 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
2770# endif
2771 END SELECT
2772 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2773 END IF
2774 END DO
2775# endif
2776!
2777! Synchronize open boundaries normalization NetCDF file to disk to
2778! allow other processes to access data immediately after it is
2779! written.
2780!
2781 SELECT CASE (nrm(ifile,ng)%IOtype)
2782 CASE (io_nf90)
2783 CALL netcdf_sync (ng, itlm, ncname, &
2784 & nrm(ifile,ng)%ncid)
2785# if defined PIO_LIB && defined DISTRIBUTE
2786 CASE (io_pio)
2787 CALL pio_netcdf_sync (ng, itlm, ncname, &
2788 & nrm(ifile,ng)%pioFile)
2789# endif
2790 END SELECT
2791 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2792 END IF
2793# endif
2794
2795# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
2796!
2797!-----------------------------------------------------------------------
2798! Compute surface forcing error covariance, B, normalization factors
2799! using the exact method.
2800!-----------------------------------------------------------------------
2801!
2802 ifile=4
2803 IF (lwrtnrm(ifile,ng)) THEN
2804 rec=1
2805 text='surface forcing'
2806!
2807! Set time record index to write in normalization NetCDF file.
2808!
2809 ncname=nrm(ifile,ng)%name
2810 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
2811 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
2812!
2813! Write out model time (s).
2814!
2815 my_time=tdays(ng)*day2sec
2816
2817 SELECT CASE (nrm(ifile,ng)%IOtype)
2818 CASE (io_nf90)
2819 CALL netcdf_put_fvar (ng, itlm, ncname, &
2820 & vname(1,idtime), my_time, &
2821 & start = (/nrm(ifile,ng)%Rindex/), &
2822 & total = (/1/), &
2823 & ncid = nrm(ifile,ng)%ncid, &
2824 & varid = nrm(ifile,ng)%Vid(idtime))
2825
2826# if defined PIO_LIB && defined DISTRIBUTE
2827 CASE (io_pio)
2828 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
2829 & vname(1,idtime), my_time, &
2830 & start = (/nrm(ifile,ng)%Rindex/), &
2831 & total = (/1/), &
2832 & piofile = nrm(ifile,ng)%pioFile, &
2833 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
2834# endif
2835 END SELECT
2836 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2837
2838# ifdef ADJUST_WSTRESS
2839!
2840! 2D norm at U-stress points.
2841!
2842 IF (cnorm(rec,isustr)) THEN
2843 IF (ewperiodic(ng)) THEN
2844 imin=1
2845 imax=lm(ng)
2846 jmin=1
2847 jmax=mm(ng)
2848 ELSE
2849 imin=2
2850 imax=lm(ng)
2851 jmin=1
2852 jmax=mm(ng)
2853 END IF
2854 IF (master) THEN
2855 WRITE (stdout,20) trim(text), &
2856 & '2D normalization factors at U-stress points'
2857 FLUSH (stdout)
2858 END IF
2859 DO j=jstrt,jendt
2860 DO i=istrp,iendt
2861 hscale(i,j)=1.0_r8/sqrt(om_u(i,j)*on_u(i,j))
2862 END DO
2863 END DO
2864 DO jc=jmin,jmax
2865 DO ic=imin,imax
2866# ifdef MASKING
2867 compute=0.0_r8
2868 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
2869 & ((istr.le.ic).and.(ic.le.iend))) THEN
2870 IF (umask(ic,jc).gt.0) compute=1.0_r8
2871 END IF
2872# ifdef DISTRIBUTE
2873 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
2874# endif
2875# else
2876 compute=1.0_r8
2877# endif
2878 IF (compute.gt.0.0_r8) THEN
2879 DO j=lbj,ubj
2880 DO i=lbi,ubi
2881 a2d(i,j)=0.0_r8
2882 END DO
2883 END DO
2884 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
2885 & ((istr.le.ic).and.(ic.le.iend))) THEN
2886 a2d(ic,jc)=1.0_r8
2887 END IF
2888 CALL ad_conv_u2d_tile (ng, tile, iadm, &
2889 & lbi, ubi, lbj, ubj, &
2890 & imins, imaxs, jmins, jmaxs, &
2891 & nghostpoints, &
2892 & nhsteps(rec,isustr)/ifac, &
2893 & dtsizeh(rec,isustr), &
2894 & kh, &
2895 & pm, pn, pmon_r, pnom_p, &
2896# ifdef MASKING
2897 & umask, pmask, &
2898# endif
2899 & a2d)
2900 DO j=jstrt,jendt
2901 DO i=istrp,iendt
2902 a2d(i,j)=a2d(i,j)*hscale(i,j)
2903 END DO
2904 END DO
2905!
2906 my_dot=0.0_r8
2907 DO j=jstrt,jendt
2908 DO i=istrp,iendt
2909 my_dot=my_dot+a2d(i,j)*a2d(i,j)
2910 END DO
2911 END DO
2912!
2913! Perform parallel global reduction operation: dot product.
2914!
2915# ifdef DISTRIBUTE
2916 nsub=1 ! distributed-memory
2917# else
2918 IF (domain(ng)%SouthWest_Corner(tile).and. &
2919 & domain(ng)%NorthEast_Corner(tile)) THEN
2920 nsub=1 ! non-tiled application
2921 ELSE
2922 nsub=ntilex(ng)*ntilee(ng) ! tiled application
2923 END IF
2924# endif
2925!$OMP CRITICAL (USTR_DOT)
2926 IF (tile_count.eq.0) THEN
2927 gdotp=my_dot
2928 ELSE
2929 gdotp=gdotp+my_dot
2930 END IF
2931 tile_count=tile_count+1
2932 IF (tile_count.eq.nsub) THEN
2933 tile_count=0
2934# ifdef DISTRIBUTE
2935 op_handle='SUM'
2936 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
2937# endif
2938 cff=1.0_r8/sqrt(gdotp)
2939 END IF
2940!$OMP END CRITICAL (USTR_DOT)
2941 ELSE
2942 cff=0.0_r8
2943 END IF
2944 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
2945 & ((istr.le.ic).and.(ic.le.iend))) THEN
2946 hnormsus(ic,jc)=cff
2947 END IF
2948 END DO
2949 END DO
2950 CALL dabc_u2d_tile (ng, tile, &
2951 & lbi, ubi, lbj, ubj, &
2952 & hnormsus)
2953# ifdef DISTRIBUTE
2954 CALL mp_exchange2d (ng, tile, itlm, 1, &
2955 & lbi, ubi, lbj, ubj, &
2956 & nghostpoints, &
2957 & ewperiodic(ng), nsperiodic(ng), &
2958 & hnormsus)
2959# endif
2960!
2961 SELECT CASE (nrm(ifile,ng)%IOtype)
2962 CASE (io_nf90)
2963 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
2964 & lbi, ubi, lbj, ubj, idusms, &
2965 & nrm(ifile,ng)%ncid, &
2966 & nrm(ifile,ng)%Vid(idusms), &
2967 & nrm(ifile,ng)%Rindex, &
2968# ifdef MASKING
2969 & umask, &
2970# endif
2971 & hnormsus)
2972
2973# if defined PIO_LIB && defined DISTRIBUTE
2974 CASE (io_pio)
2975 IF (nrm(ifile,ng)%pioVar(idusms)%dkind.eq. &
2976 & pio_double) THEN
2977 iodesc => iodesc_dp_u2dvar(ng)
2978 ELSE
2979 iodesc => iodesc_sp_u2dvar(ng)
2980 END IF
2981 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
2982 & lbi, ubi, lbj, ubj, idusms, &
2983 & nrm(ifile,ng)%pioFile, &
2984 & nrm(ifile,ng)%pioVar(idusms), &
2985 & nrm(ifile,ng)%Rindex, &
2986 & iodesc, &
2987# ifdef MASKING
2988 & umask, &
2989# endif
2990 & hnormsus)
2991# endif
2992 END SELECT
2993 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2994 END IF
2995!
2996! 2D norm at V-stress points.
2997!
2998 IF (cnorm(rec,isvstr)) THEN
2999 IF (nsperiodic(ng)) THEN
3000 imin=1
3001 imax=lm(ng)
3002 jmin=1
3003 jmax=mm(ng)
3004 ELSE
3005 imin=1
3006 imax=lm(ng)
3007 jmin=2
3008 jmax=mm(ng)
3009 END IF
3010 IF (master) THEN
3011 WRITE (stdout,20) trim(text), &
3012 & '2D normalization factors at V-stress points'
3013 FLUSH (stdout)
3014 END IF
3015 DO j=jstrp,jendt
3016 DO i=istrt,iendt
3017 hscale(i,j)=1.0_r8/sqrt(om_v(i,j)*on_v(i,j))
3018 END DO
3019 END DO
3020 DO jc=jmin,jmax
3021 DO ic=imin,imax
3022# ifdef MASKING
3023 compute=0.0_r8
3024 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
3025 & ((istr.le.ic).and.(ic.le.iend))) THEN
3026 IF (vmask(ic,jc).gt.0) compute=1.0_r8
3027 END IF
3028# ifdef DISTRIBUTE
3029 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
3030# endif
3031# else
3032 compute=1.0_r8
3033# endif
3034 IF (compute.gt.0.0_r8) THEN
3035 DO j=lbj,ubj
3036 DO i=lbi,ubi
3037 a2d(i,j)=0.0_r8
3038 END DO
3039 END DO
3040 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
3041 & ((istr.le.ic).and.(ic.le.iend))) THEN
3042 a2d(ic,jc)=1.0_r8
3043 END IF
3044 CALL ad_conv_v2d_tile (ng, tile, iadm, &
3045 & lbi, ubi, lbj, ubj, &
3046 & imins, imaxs, jmins, jmaxs, &
3047 & nghostpoints, &
3048 & nhsteps(rec,isvstr)/ifac, &
3049 & dtsizeh(rec,isvstr), &
3050 & kh, &
3051 & pm, pn, pmon_p, pnom_r, &
3052# ifdef MASKING
3053 & vmask, pmask, &
3054# endif
3055 & a2d)
3056 DO j=jstrp,jendt
3057 DO i=istrt,iendt
3058 a2d(i,j)=a2d(i,j)*hscale(i,j)
3059 END DO
3060 END DO
3061!
3062 my_dot=0.0_r8
3063 DO j=jstrp,jendt
3064 DO i=istrt,iendt
3065 my_dot=my_dot+a2d(i,j)*a2d(i,j)
3066 END DO
3067 END DO
3068!
3069! Perform parallel global reduction operation: dot product.
3070!
3071# ifdef DISTRIBUTE
3072 nsub=1 ! distributed-memory
3073# else
3074 IF (domain(ng)%SouthWest_Corner(tile).and. &
3075 & domain(ng)%NorthEast_Corner(tile)) THEN
3076 nsub=1 ! non-tiled application
3077 ELSE
3078 nsub=ntilex(ng)*ntilee(ng) ! tiled application
3079 END IF
3080# endif
3081!$OMP CRITICAL (VSTR_DOT)
3082 IF (tile_count.eq.0) THEN
3083 gdotp=my_dot
3084 ELSE
3085 gdotp=gdotp+my_dot
3086 END IF
3087 tile_count=tile_count+1
3088 IF (tile_count.eq.nsub) THEN
3089 tile_count=0
3090# ifdef DISTRIBUTE
3091 op_handle='SUM'
3092 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
3093# endif
3094 cff=1.0_r8/sqrt(gdotp)
3095 END IF
3096!$OMP END CRITICAL (VSTR_DOT)
3097 ELSE
3098 cff=0.0_r8
3099 END IF
3100 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
3101 & ((istr.le.ic).and.(ic.le.iend))) THEN
3102 hnormsvs(ic,jc)=cff
3103 END IF
3104 END DO
3105 END DO
3106 CALL dabc_v2d_tile (ng, tile, &
3107 & lbi, ubi, lbj, ubj, &
3108 & hnormsvs)
3109# ifdef DISTRIBUTE
3110 CALL mp_exchange2d (ng, tile, itlm, 1, &
3111 & lbi, ubi, lbj, ubj, &
3112 & nghostpoints, &
3113 & ewperiodic(ng), nsperiodic(ng), &
3114 & hnormsvs)
3115# endif
3116!
3117 SELECT CASE (nrm(ifile,ng)%IOtype)
3118 CASE (io_nf90)
3119 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3120 & lbi, ubi, lbj, ubj, idvsms, &
3121 & nrm(ifile,ng)%ncid, &
3122 & nrm(ifile,ng)%Vid(idvsms), &
3123 & nrm(ifile,ng)%Rindex, &
3124# ifdef MASKING
3125 & vmask, &
3126# endif
3127 & hnormsvs)
3128
3129# if defined PIO_LIB && defined DISTRIBUTE
3130 CASE (io_pio)
3131 IF (nrm(ifile,ng)%pioVar(idvsms)%dkind.eq. &
3132 & pio_double) THEN
3133 iodesc => iodesc_dp_v2dvar(ng)
3134 ELSE
3135 iodesc => iodesc_sp_v2dvar(ng)
3136 END IF
3137 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
3138 & lbi, ubi, lbj, ubj, idvsms, &
3139 & nrm(ifile,ng)%pioFile, &
3140 & nrm(ifile,ng)%pioVar(idvsms), &
3141 & nrm(ifile,ng)%Rindex, &
3142 & iodesc, &
3143# ifdef MASKING
3144 & vmask, &
3145# endif
3146 & hnormsvs)
3147# endif
3148 END SELECT
3149 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3150 END IF
3151# endif
3152# if defined ADJUST_STFLUX && defined SOLVE3D
3153!
3154! 2D norm at surface tracer fluxes points.
3155!
3156 IF (master) THEN
3157 lsame=.false.
3158 DO itrc=1,nt(ng)
3159 IF (lstflux(itrc,ng)) THEN
3160 is=istsur(itrc)
3161 IF (cnorm(rec,is)) lsame=.true.
3162 END IF
3163 END DO
3164 IF (lsame) THEN
3165 WRITE (stdout,20) trim(text), &
3166 '2D normalization factors at RHO-points'
3167 FLUSH (stdout)
3168 END IF
3169 END IF
3170!
3171! Check if the decorrelation scales for all the surface tracer fluxes
3172! are different. If not, just compute the normalization factors for the
3173! first tracer and assign the same value to the rest. Recall that this
3174! computation is very expensive.
3175!
3176 ldiffer=.false.
3177 imin=1
3178 imax=lm(ng)
3179 jmin=1
3180 jmax=mm(ng)
3181 DO itrc=2,nt(ng)
3182 IF (hdecay(rec,istsur(itrc ),ng).ne. &
3183 & hdecay(rec,istsur(itrc-1),ng)) THEN
3184 ldiffer=.true.
3185 END IF
3186 END DO
3187 IF (.not.ldiffer) THEN
3188 lsame=.true.
3189 ubt=1
3190 ELSE
3191 lsame=.false.
3192 ubt=nt(ng)
3193 END IF
3194!
3195 DO j=jstrt,jendt
3196 DO i=istrt,iendt
3197 hscale(i,j)=1.0_r8/sqrt(om_r(i,j)*on_r(i,j))
3198 END DO
3199 END DO
3200 DO itrc=1,ubt
3201 IF (lstflux(itrc,ng)) THEN
3202 is=istsur(itrc)
3203 IF (cnorm(rec,is)) THEN
3204 DO jc=jmin,jmax
3205 DO ic=imin,imax
3206# ifdef MASKING
3207 compute=0.0_r8
3208 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
3209 & ((istr.le.ic).and.(ic.le.iend))) THEN
3210 IF (rmask(ic,jc).gt.0) compute=1.0_r8
3211 END IF
3212# ifdef DISTRIBUTE
3213 CALL mp_reduce (ng, itlm, 1, compute, 'SUM')
3214# endif
3215# else
3216 compute=1.0_r8
3217# endif
3218 IF (compute.gt.0.0_r8) THEN
3219 DO j=lbj,ubj
3220 DO i=lbi,ubi
3221 a2d(i,j)=0.0_r8
3222 END DO
3223 END DO
3224 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
3225 & ((istr.le.ic).and.(ic.le.iend))) THEN
3226 a2d(ic,jc)=1.0_r8
3227 END IF
3228 CALL ad_conv_r2d_tile (ng, tile, iadm, &
3229 & lbi, ubi, lbj, ubj, &
3230 & imins, imaxs, jmins, jmaxs, &
3231 & nghostpoints, &
3232 & nhsteps(rec,is)/ifac, &
3233 & dtsizeh(rec,is), &
3234 & kh, &
3235 & pm, pn, pmon_u, pnom_v, &
3236# ifdef MASKING
3237 & rmask, umask, vmask, &
3238# endif
3239 & a2d)
3240 DO j=jstrt,jendt
3241 DO i=istrt,iendt
3242 a2d(i,j)=a2d(i,j)*hscale(i,j)
3243 END DO
3244 END DO
3245 my_dot=0.0_r8
3246 DO j=jstrt,jendt
3247 DO i=istrt,iendt
3248 my_dot=my_dot+a2d(i,j)*a2d(i,j)
3249 END DO
3250 END DO
3251!
3252! Perform parallel global reduction operation: dot product.
3253!
3254# ifdef DISTRIBUTE
3255 nsub=1 ! distributed-memory
3256# else
3257 IF (domain(ng)%SouthWest_Corner(tile).and. &
3258 & domain(ng)%NorthEast_Corner(tile)) THEN
3259 nsub=1 ! non-tiled application
3260 ELSE
3261 nsub=ntilex(ng)*ntilee(ng) ! tiled application
3262 END IF
3263# endif
3264!$OMP CRITICAL (STFLX_DOT)
3265 IF (tile_count.eq.0) THEN
3266 gdotp=my_dot
3267 ELSE
3268 gdotp=gdotp+my_dot
3269 END IF
3270 tile_count=tile_count+1
3271 IF (tile_count.eq.nsub) THEN
3272 tile_count=0
3273# ifdef DISTRIBUTE
3274 op_handle='SUM'
3275 CALL mp_reduce (ng, itlm, 1, gdotp, op_handle)
3276# endif
3277 cff=1.0_r8/sqrt(gdotp)
3278 END IF
3279!$OMP END CRITICAL (STFLX_DOT)
3280 ELSE
3281 cff=0.0_r8
3282 END IF
3283 IF (((jstr.le.jc).and.(jc.le.jend)).and. &
3284 & ((istr.le.ic).and.(ic.le.iend))) THEN
3285 IF (lsame) THEN
3286 DO ntrc=1,nt(ng)
3287 IF (lstflux(ntrc,ng)) THEN
3288 hnormstf(ic,jc,ntrc)=cff
3289 END IF
3290 END DO
3291 ELSE
3292 hnormstf(ic,jc,itrc)=cff
3293 END IF
3294 END IF
3295 END DO
3296 END DO
3297 END IF
3298 END IF
3299 END DO
3300 DO itrc=1,nt(ng)
3301 IF (lstflux(itrc,ng)) THEN
3302 is=istsur(itrc)
3303 IF (cnorm(rec,is)) THEN
3304 CALL dabc_r2d_tile (ng, tile, &
3305 & lbi, ubi, lbj, ubj, &
3306 & hnormstf(:,:,itrc))
3307# ifdef DISTRIBUTE
3308 CALL mp_exchange2d (ng, tile, itlm, 1, &
3309 & lbi, ubi, lbj, ubj, &
3310 & nghostpoints, &
3311 & ewperiodic(ng), nsperiodic(ng), &
3312 & hnormstf(:,:,itrc))
3313# endif
3314!
3315 SELECT CASE (nrm(ifile,ng)%IOtype)
3316 CASE (io_nf90)
3317 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3318 & lbi, ubi, lbj, ubj, &
3319 & idtsur(itrc), &
3320 & nrm(ifile,ng)%ncid, &
3321 & nrm(ifile,ng)%Vid(idtsur(itrc)), &
3322 & nrm(ifile,ng)%Rindex, &
3323# ifdef MASKING
3324 & rmask, &
3325# endif
3326 & hnormstf(:,:,itrc))
3327
3328# if defined PIO_LIB && defined DISTRIBUTE
3329 CASE (io_pio)
3330 IF (nrm(ifile,ng)%pioVar(idtsur(itrc))%dkind.eq. &
3331 & pio_double) THEN
3332 iodesc => iodesc_dp_r2dvar(ng)
3333 ELSE
3334 iodesc => iodesc_sp_r2dvar(ng)
3335 END IF
3336 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
3337 & lbi, ubi, lbj, ubj, &
3338 & idtsur(itrc), &
3339 & nrm(ifile,ng)%pioFile, &
3340 & nrm(ifile,ng)%pioVar(idtsur(itrc)), &
3341 & nrm(ifile,ng)%Rindex, &
3342 & iodesc, &
3343# ifdef MASKING
3344 & rmask, &
3345# endif
3346 & hnormstf(:,:,itrc))
3347# endif
3348 END SELECT
3349 IF (founderror(exit_flag, noerror, &
3350 & __line__, myfile)) RETURN
3351 END IF
3352 END IF
3353 END DO
3354# endif
3355 END IF
3356# endif
3357!
3358 IF (master) THEN
3359 WRITE (stdout,30)
3360 END IF
3361
3362 10 FORMAT (/,' Error Covariance Normalization Factors: ', &
3363 & 'Exact Method',/)
3364 20 FORMAT (4x,'Computing',1x,a,1x,a)
3365 30 FORMAT (/)
3366!
3367 RETURN
3368 END SUBROUTINE normalization_tile
3369
3370!
3371!***********************************************************************
3372 SUBROUTINE randomization_tile (ng, tile, &
3373 & LBi, UBi, LBj, UBj, LBij, UBij, &
3374 & IminS, ImaxS, JminS, JmaxS, &
3375 & nstp, nnew, ifac, &
3376 & pm, om_p, om_r, om_u, om_v, &
3377 & pn, on_p, on_r, on_u, on_v, &
3378 & pmon_p, pmon_r, pmon_u, &
3379 & pnom_p, pnom_r, pnom_v, &
3380# ifdef MASKING
3381 & pmask, rmask, &
3382 & umask, vmask, &
3383# endif
3384# ifdef SOLVE3D
3385 & h, &
3386# ifdef ICESHELF
3387 & zice, &
3388# endif
3389# if defined SEDIMENT && defined SED_MORPH
3390 & bed_thick, &
3391# endif
3392 & Hz, z_r, z_w, &
3393# endif
3394 & Kh, &
3395# ifdef SOLVE3D
3396 & Kv, &
3397# endif
3398# ifdef ADJUST_BOUNDARY
3399# ifdef SOLVE3D
3400 & VnormRobc, VnormUobc, VnormVobc, &
3401# endif
3402 & HnormRobc, HnormUobc, HnormVobc, &
3403# endif
3404# ifdef ADJUST_WSTRESS
3405 & HnormSUS, HnormSVS, &
3406# endif
3407# if defined ADJUST_STFLUX && defined SOLVE3D
3408 & HnormSTF, &
3409# endif
3410# ifdef SOLVE3D
3411 & VnormR, VnormU, VnormV, &
3412# endif
3413 & HnormR, HnormU, HnormV)
3414!***********************************************************************
3415!
3416! Imported variable declarations.
3417!
3418 integer, intent(in) :: ng, tile
3419 integer, intent(in) :: lbi, ubi, lbj, ubj, lbij, ubij
3420 integer, intent(in) :: imins, imaxs, jmins, jmaxs
3421 integer, intent(in) :: nstp, nnew, ifac
3422!
3423# ifdef ASSUMED_SHAPE
3424 real(r8), intent(in) :: pm(lbi:,lbj:)
3425 real(r8), intent(in) :: om_p(lbi:,lbj:)
3426 real(r8), intent(in) :: om_r(lbi:,lbj:)
3427 real(r8), intent(in) :: om_u(lbi:,lbj:)
3428 real(r8), intent(in) :: om_v(lbi:,lbj:)
3429 real(r8), intent(in) :: pn(lbi:,lbj:)
3430 real(r8), intent(in) :: on_p(lbi:,lbj:)
3431 real(r8), intent(in) :: on_r(lbi:,lbj:)
3432 real(r8), intent(in) :: on_u(lbi:,lbj:)
3433 real(r8), intent(in) :: on_v(lbi:,lbj:)
3434 real(r8), intent(in) :: pmon_p(lbi:,lbj:)
3435 real(r8), intent(in) :: pmon_r(lbi:,lbj:)
3436 real(r8), intent(in) :: pmon_u(lbi:,lbj:)
3437 real(r8), intent(in) :: pnom_p(lbi:,lbj:)
3438 real(r8), intent(in) :: pnom_r(lbi:,lbj:)
3439 real(r8), intent(in) :: pnom_v(lbi:,lbj:)
3440# ifdef MASKING
3441 real(r8), intent(in) :: pmask(lbi:,lbj:)
3442 real(r8), intent(in) :: rmask(lbi:,lbj:)
3443 real(r8), intent(in) :: umask(lbi:,lbj:)
3444 real(r8), intent(in) :: vmask(lbi:,lbj:)
3445# endif
3446 real(r8), intent(in) :: kh(lbi:,lbj:)
3447# ifdef SOLVE3D
3448 real(r8), intent(in) :: kv(lbi:,lbj:,0:)
3449# ifdef ICESHELF
3450 real(r8), intent(in) :: zice(lbi:,lbj:)
3451# endif
3452# if defined SEDIMENT && defined SED_MORPH
3453 real(r8), intent(in):: bed_thick(lbi:,lbj:,:)
3454# endif
3455 real(r8), intent(inout) :: h(lbi:,lbj:)
3456# endif
3457# ifdef ADJUST_BOUNDARY
3458# ifdef SOLVE3D
3459 real(r8), intent(out) :: vnormrobc(lbij:,:,:,:)
3460 real(r8), intent(out) :: vnormuobc(lbij:,:,:)
3461 real(r8), intent(out) :: vnormvobc(lbij:,:,:)
3462# endif
3463 real(r8), intent(out) :: hnormrobc(lbij:,:)
3464 real(r8), intent(out) :: hnormuobc(lbij:,:)
3465 real(r8), intent(out) :: hnormvobc(lbij:,:)
3466# endif
3467# ifdef ADJUST_WSTRESS
3468 real(r8), intent(out) :: hnormsus(lbi:,lbj:)
3469 real(r8), intent(out) :: hnormsvs(lbi:,lbj:)
3470# endif
3471# if defined ADJUST_STFLUX && defined SOLVE3D
3472 real(r8), intent(out) :: hnormstf(lbi:,lbj:,:)
3473# endif
3474# ifdef SOLVE3D
3475 real(r8), intent(out) :: vnormr(lbi:,lbj:,:,:,:)
3476 real(r8), intent(out) :: vnormu(lbi:,lbj:,:,:)
3477 real(r8), intent(out) :: vnormv(lbi:,lbj:,:,:)
3478# endif
3479 real(r8), intent(out) :: hnormr(lbi:,lbj:,:)
3480 real(r8), intent(out) :: hnormu(lbi:,lbj:,:)
3481 real(r8), intent(out) :: hnormv(lbi:,lbj:,:)
3482# ifdef SOLVE3D
3483 real(r8), intent(out) :: hz(lbi:,lbj:,:)
3484 real(r8), intent(out) :: z_r(lbi:,lbj:,:)
3485 real(r8), intent(out) :: z_w(lbi:,lbj:,0:)
3486# endif
3487# else
3488 real(r8), intent(in) :: pm(lbi:ubi,lbj:ubj)
3489 real(r8), intent(in) :: om_p(lbi:ubi,lbj:ubj)
3490 real(r8), intent(in) :: om_r(lbi:ubi,lbj:ubj)
3491 real(r8), intent(in) :: om_u(lbi:ubi,lbj:ubj)
3492 real(r8), intent(in) :: om_v(lbi:ubi,lbj:ubj)
3493 real(r8), intent(in) :: pn(lbi:ubi,lbj:ubj)
3494 real(r8), intent(in) :: on_p(lbi:ubi,lbj:ubj)
3495 real(r8), intent(in) :: on_r(lbi:ubi,lbj:ubj)
3496 real(r8), intent(in) :: on_u(lbi:ubi,lbj:ubj)
3497 real(r8), intent(in) :: on_v(lbi:ubi,lbj:ubj)
3498 real(r8), intent(in) :: pmon_p(lbi:ubi,lbj:ubj)
3499 real(r8), intent(in) :: pmon_r(lbi:ubi,lbj:ubj)
3500 real(r8), intent(in) :: pmon_u(lbi:ubi,lbj:ubj)
3501 real(r8), intent(in) :: pnom_p(lbi:ubi,lbj:ubj)
3502 real(r8), intent(in) :: pnom_r(lbi:ubi,lbj:ubj)
3503 real(r8), intent(in) :: pnom_v(lbi:ubi,lbj:ubj)
3504# ifdef MASKING
3505 real(r8), intent(in) :: pmask(lbi:ubi,lbj:ubj)
3506 real(r8), intent(in) :: rmask(lbi:ubi,lbj:ubj)
3507 real(r8), intent(in) :: umask(lbi:ubi,lbj:ubj)
3508 real(r8), intent(in) :: vmask(lbi:ubi,lbj:ubj)
3509# endif
3510 real(r8), intent(in) :: kh(lbi:ubi,lbj:ubj)
3511# ifdef SOLVE3D
3512 real(r8), intent(in) :: kv(lbi:ubi,lbj:ubj,0:n(ng))
3513# ifdef ICESHELF
3514 real(r8), intent(in) :: zice(lbi:ubi,lbj:ubj)
3515# endif
3516# if defined SEDIMENT && defined SED_MORPH
3517 real(r8), intent(in):: bed_thick(lbi:ubi,lbj:ubj,3)
3518# endif
3519 real(r8), intent(inout) :: h(lbi:ubi,lbj:ubj)
3520# endif
3521# ifdef ADJUST_BOUNDARY
3522# ifdef SOLVE3D
3523 real(r8), intent(out) :: vnormrobc(lbij:ubij,n(ng),4,nt(ng))
3524 real(r8), intent(out) :: vnormuobc(lbij:ubij,n(ng),4)
3525 real(r8), intent(out) :: vnormvobc(lbij:ubij,n(ng),4)
3526# endif
3527 real(r8), intent(out) :: hnormrobc(lbij:ubij,4)
3528 real(r8), intent(out) :: hnormuobc(lbij:ubij,4)
3529 real(r8), intent(out) :: hnormvobc(lbij:ubij,4)
3530# endif
3531# ifdef ADJUST_WSTRESS
3532 real(r8), intent(out) :: hnormsus(lbi:ubi,lbj:ubj)
3533 real(r8), intent(out) :: hnormsvs(lbi:ubi,lbj:ubj)
3534# endif
3535# if defined ADJUST_STFLUX && defined SOLVE3D
3536 real(r8), intent(out) :: hnormstf(lbi:ubi,lbj:ubj,nt(ng))
3537# endif
3538# ifdef SOLVE3D
3539 real(r8), intent(out) :: vnormr(lbi:ubi,lbj:ubj,n(ng),nsa,nt(ng))
3540 real(r8), intent(out) :: vnormu(lbi:ubi,lbj:ubj,n(ng),nsa)
3541 real(r8), intent(out) :: vnormv(lbi:ubi,lbj:ubj,n(ng),nsa)
3542# endif
3543 real(r8), intent(out) :: hnormr(lbi:ubi,lbj:ubj,nsa)
3544 real(r8), intent(out) :: hnormu(lbi:ubi,lbj:ubj,nsa)
3545 real(r8), intent(out) :: hnormv(lbi:ubi,lbj:ubj,nsa)
3546# ifdef SOLVE3D
3547 real(r8), intent(out) :: hz(lbi:ubi,lbj:ubj,n(ng))
3548 real(r8), intent(out) :: z_r(lbi:ubi,lbj:ubj,n(ng))
3549 real(r8), intent(out) :: z_w(lbi:ubi,lbj:ubj,0:n(ng))
3550# endif
3551# endif
3552!
3553! Local variable declarations.
3554!
3555# ifdef SOLVE3D
3556 logical :: ldiffer, lsame
3557# endif
3558# ifdef ADJUST_BOUNDARY
3559 logical :: lconvolve(4)
3560# endif
3561!
3562 integer :: i, ifile, is, iter, j, rec
3563# ifdef SOLVE3D
3564 integer :: ubt, itrc, k
3565# endif
3566# ifdef ADJUST_BOUNDARY
3567 integer :: ijlen, ijklen, ib, ibry, ic, ifield
3568# endif
3569 integer :: start(4), total(4)
3570!
3571 real(dp) :: my_time
3572 real(r8) :: aavg, amax, amin, asqr, facavg, facsqr
3573 real(r8) :: cff, val
3574
3575# ifdef ADJUST_BOUNDARY
3576 real(r8) :: bavg, bmin, bmax, bsqr
3577
3578 real(r8), parameter :: aspv = 0.0_r8
3579# endif
3580!
3581 real(r8), dimension(LBi:UBi,LBj:UBj) :: a2d
3582 real(r8), dimension(LBi:UBi,LBj:UBj) :: a2davg
3583 real(r8), dimension(LBi:UBi,LBj:UBj) :: a2dsqr
3584 real(r8), dimension(LBi:UBi,LBj:UBj) :: hscale
3585# ifdef ADJUST_BOUNDARY
3586 real(r8), dimension(LBij:UBij) :: b2d
3587 real(r8), dimension(LBij:UBij) :: b2davg
3588 real(r8), dimension(LBij:UBij) :: b2dsqr
3589 real(r8), dimension(LBij:UBij) :: hscaleb
3590# endif
3591# ifdef SOLVE3D
3592 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: a3d
3593 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: a3davg
3594 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: a3dsqr
3595 real(r8), dimension(LBi:UBi,LBj:UBj,1:N(ng)) :: vscale
3596# ifdef ADJUST_BOUNDARY
3597 real(r8), dimension(LBij:UBij,1:N(ng)) :: b3d
3598 real(r8), dimension(LBij:UBij,1:N(ng)) :: b3davg
3599 real(r8), dimension(LBij:UBij,1:N(ng)) :: b3dsqr
3600 real(r8), dimension(LBij:UBij,1:N(ng)) :: vscaleb
3601# ifdef DISTRIBUTE
3602 real(r8), dimension((UBij-LBij+1)*N(ng)) :: bwrk
3603# endif
3604# endif
3605# endif
3606!
3607 character (len=40 ) :: text
3608 character (len=256) :: ncname
3609
3610 character (len=*), parameter :: myfile = &
3611 & __FILE__//", randomization_tile"
3612
3613# if defined PIO_LIB && defined DISTRIBUTE
3614!
3615 TYPE (io_desc_t), pointer :: iodesc
3616# endif
3617
3618# include "set_bounds.h"
3619!
3620 sourcefile=myfile
3621
3622 my_time=tdays(ng)*day2sec
3623
3624# ifdef SOLVE3D
3625!
3626!-----------------------------------------------------------------------
3627! Compute time invariant depths (use zero free-surface).
3628!-----------------------------------------------------------------------
3629!
3630 DO i=lbi,ubi
3631 DO j=lbj,ubj
3632 a2d(i,j)=0.0_r8
3633 END DO
3634 END DO
3635
3636 CALL set_depth_tile (ng, tile, inlm, &
3637 & lbi, ubi, lbj, ubj, &
3638 & imins, imaxs, jmins, jmaxs, &
3639 & nstp, nnew, &
3640 & h, &
3641# ifdef ICESHELF
3642 & zice, &
3643# endif
3644# if defined SEDIMENT && defined SED_MORPH
3645 & bed_thick, &
3646# endif
3647 & a2d, &
3648 & hz, z_r, z_w)
3649# endif
3650!
3651!-----------------------------------------------------------------------
3652! Compute initial conditions and model erro covariance, B,
3653! normalization factors using the randomization approach of Fisher
3654! and Courtier (1995). These factors ensure that the diagonal
3655! elements of B are equal to unity. Notice that in applications
3656! with land/sea masking, the boundary conditions will produce
3657! large changes in the covariance structures near the boundary.
3658!
3659! Initialize factors with randon numbers ("white-noise") having an
3660! uniform distribution (zero mean and unity variance). Then, scale
3661! by the inverse squared root area (2D) or volume (3D) and "color"
3662! with the diffusion operator. Iterate this step over a specified
3663! number of ensamble members, Nrandom.
3664!-----------------------------------------------------------------------
3665!
3666 IF (master) WRITE (stdout,10)
3667
3668 file_loop : DO ifile=1,nsa
3669
3670 IF (lwrtnrm(ifile,ng)) THEN
3671 IF (ifile.eq.1) THEN
3672 text='initial conditions'
3673 ELSE IF (ifile.eq.2) THEN
3674 text='model'
3675 END IF
3676!
3677! Set randomization summation factors.
3678!
3679 facavg=1.0_r8/real(nrandom,r8)
3680 facsqr=sqrt(real(nrandom,r8))
3681!
3682! Set time record index to write in normalization NetCDF file.
3683!
3684 ncname=nrm(ifile,ng)%name
3685 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
3686 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
3687!
3688! Write out model time (s).
3689!
3690 SELECT CASE (nrm(ifile,ng)%IOtype)
3691 CASE (io_nf90)
3692 CALL netcdf_put_fvar (ng, itlm, ncname, &
3693 & vname(1,idtime), my_time, &
3694 & start = (/nrm(ifile,ng)%Rindex/), &
3695 & total = (/1/), &
3696 & ncid = nrm(ifile,ng)%ncid, &
3697 & varid = nrm(ifile,ng)%Vid(idtime))
3698# if defined PIO_LIB && defined DISTRIBUTE
3699 CASE (io_pio)
3700 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
3701 & vname(1,idtime), my_time, &
3702 & start = (/nrm(ifile,ng)%Rindex/), &
3703 & total = (/1/), &
3704 & piofile = nrm(ifile,ng)%pioFile, &
3705 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
3706# endif
3707 END SELECT
3708 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3709!
3710! 2D norm at RHO-points.
3711!
3712 IF (cnorm(ifile,isfsur)) THEN
3713 IF (master) THEN
3714 WRITE (stdout,20) trim(text), &
3715 & '2D normalization factors at RHO-points'
3716 FLUSH (stdout)
3717 END IF
3718 DO j=jstrt,jendt
3719 DO i=istrt,iendt
3720 a2davg(i,j)=0.0_r8
3721 a2dsqr(i,j)=0.0_r8
3722 hscale(i,j)=1.0_r8/sqrt(om_r(i,j)*on_r(i,j))
3723 END DO
3724 END DO
3725 DO iter=1,nrandom
3726 CALL white_noise2d (ng, itlm, r2dvar, rscheme(ng), &
3727 & istrr, iendr, jstrr, jendr, &
3728 & lbi, ubi, lbj, ubj, &
3729 & amin, amax, a2d)
3730 DO j=jstrt,jendt
3731 DO i=istrt,iendt
3732 a2d(i,j)=a2d(i,j)*hscale(i,j)
3733 END DO
3734 END DO
3735 CALL tl_conv_r2d_tile (ng, tile, itlm, &
3736 & lbi, ubi, lbj, ubj, &
3737 & imins, imaxs, jmins, jmaxs, &
3738 & nghostpoints, &
3739 & nhsteps(ifile,isfsur)/ifac, &
3740 & dtsizeh(ifile,isfsur), &
3741 & kh, &
3742 & pm, pn, pmon_u, pnom_v, &
3743# ifdef MASKING
3744 & rmask, umask, vmask, &
3745# endif
3746 & a2d)
3747 DO j=jstr,jend
3748 DO i=istr,iend
3749 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
3750 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
3751 END DO
3752 END DO
3753 END DO
3754 DO j=jstr,jend
3755 DO i=istr,iend
3756 aavg=facavg*a2davg(i,j)
3757 asqr=facavg*a2dsqr(i,j)
3758# ifdef MASKING
3759 IF (rmask(i,j).gt.0.0_r8) THEN
3760 hnormr(i,j,ifile)=1.0_r8/sqrt(asqr)
3761 ELSE
3762 hnormr(i,j,ifile)=0.0_r8
3763 END IF
3764# else
3765 hnormr(i,j,ifile)=1.0_r8/sqrt(asqr)
3766# endif
3767 END DO
3768 END DO
3769 CALL dabc_r2d_tile (ng, tile, &
3770 & lbi, ubi, lbj, ubj, &
3771 & hnormr(:,:,ifile))
3772# ifdef DISTRIBUTE
3773 CALL mp_exchange2d (ng, tile, itlm, 1, &
3774 & lbi, ubi, lbj, ubj, &
3775 & nghostpoints, &
3776 & ewperiodic(ng), nsperiodic(ng), &
3777 & hnormr(:,:,ifile))
3778# endif
3779!
3780 SELECT CASE (nrm(ifile,ng)%IOtype)
3781 CASE (io_nf90)
3782 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3783 & lbi, ubi, lbj, ubj, idfsur, &
3784 & nrm(ifile,ng)%ncid, &
3785 & nrm(ifile,ng)%Vid(idfsur), &
3786 & nrm(ifile,ng)%Rindex, &
3787# ifdef MASKING
3788 & rmask, &
3789# endif
3790 & hnormr(:,:,ifile))
3791
3792# if defined PIO_LIB && defined DISTRIBUTE
3793 CASE (io_pio)
3794 IF (nrm(ifile,ng)%pioVar(idfsur)%dkind.eq. &
3795 & pio_double) THEN
3796 iodesc => iodesc_dp_r2dvar(ng)
3797 ELSE
3798 iodesc => iodesc_sp_r2dvar(ng)
3799 END IF
3800 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
3801 & lbi, ubi, lbj, ubj, idfsur, &
3802 & nrm(ifile,ng)%pioFile, &
3803 & nrm(ifile,ng)%pioVar(idfsur), &
3804 & nrm(ifile,ng)%Rindex, &
3805 & iodesc, &
3806# ifdef MASKING
3807 & rmask, &
3808# endif
3809 & hnormr(:,:,ifile))
3810# endif
3811 END SELECT
3812 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3813 END IF
3814!
3815! 2D norm at U-points.
3816!
3817 IF (cnorm(ifile,isubar)) THEN
3818 IF (master) THEN
3819 WRITE (stdout,20) trim(text), &
3820 & '2D normalization factors at U-points'
3821 FLUSH (stdout)
3822 END IF
3823 DO j=jstrt,jendt
3824 DO i=istrp,iendt
3825 a2davg(i,j)=0.0_r8
3826 a2dsqr(i,j)=0.0_r8
3827 hscale(i,j)=1.0_r8/sqrt(om_u(i,j)*on_u(i,j))
3828 END DO
3829 END DO
3830 DO iter=1,nrandom
3831 CALL white_noise2d (ng, itlm, u2dvar, rscheme(ng), &
3832 & istr, iendr, jstrr, jendr, &
3833 & lbi, ubi, lbj, ubj, &
3834 & amin, amax, a2d)
3835 DO j=jstrt,jendt
3836 DO i=istrp,iendt
3837 a2d(i,j)=a2d(i,j)*hscale(i,j)
3838 END DO
3839 END DO
3840 CALL tl_conv_u2d_tile (ng, tile, itlm, &
3841 & lbi, ubi, lbj, ubj, &
3842 & imins, imaxs, jmins, jmaxs, &
3843 & nghostpoints, &
3844 & nhsteps(ifile,isubar)/ifac, &
3845 & dtsizeh(ifile,isubar), &
3846 & kh, &
3847 & pm, pn, pmon_r, pnom_p, &
3848# ifdef MASKING
3849 & umask, pmask, &
3850# endif
3851 & a2d)
3852 DO j=jstr,jend
3853 DO i=istru,iend
3854 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
3855 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
3856 END DO
3857 END DO
3858 END DO
3859 DO j=jstr,jend
3860 DO i=istru,iend
3861 aavg=facavg*a2davg(i,j)
3862 asqr=facavg*a2dsqr(i,j)
3863# ifdef MASKING
3864 IF (umask(i,j).gt.0.0_r8) THEN
3865 hnormu(i,j,ifile)=1.0_r8/sqrt(asqr)
3866 ELSE
3867 hnormu(i,j,ifile)=0.0_r8
3868 END IF
3869# else
3870 hnormu(i,j,ifile)=1.0_r8/sqrt(asqr)
3871# endif
3872 END DO
3873 END DO
3874 CALL dabc_u2d_tile (ng, tile, &
3875 & lbi, ubi, lbj, ubj, &
3876 & hnormu(:,:,ifile))
3877# ifdef DISTRIBUTE
3878 CALL mp_exchange2d (ng, tile, itlm, 1, &
3879 & lbi, ubi, lbj, ubj, &
3880 & nghostpoints, &
3881 & ewperiodic(ng), nsperiodic(ng), &
3882 & hnormu(:,:,ifile))
3883# endif
3884!
3885 SELECT CASE (nrm(ifile,ng)%IOtype)
3886 CASE (io_nf90)
3887 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3888 & lbi, ubi, lbj, ubj, idubar, &
3889 & nrm(ifile,ng)%ncid, &
3890 & nrm(ifile,ng)%Vid(idubar), &
3891 & nrm(ifile,ng)%Rindex, &
3892# ifdef MASKING
3893 & umask, &
3894# endif
3895 & hnormu(:,:,ifile))
3896
3897# if defined PIO_LIB && defined DISTRIBUTE
3898 CASE (io_pio)
3899 IF (nrm(ifile,ng)%pioVar(idubar)%dkind.eq. &
3900 & pio_double) THEN
3901 iodesc => iodesc_dp_u2dvar(ng)
3902 ELSE
3903 iodesc => iodesc_sp_u2dvar(ng)
3904 END IF
3905 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
3906 & lbi, ubi, lbj, ubj, idubar, &
3907 & nrm(ifile,ng)%pioFile, &
3908 & nrm(ifile,ng)%pioVar(idubar), &
3909 & nrm(ifile,ng)%Rindex, &
3910 & iodesc, &
3911# ifdef MASKING
3912 & umask, &
3913# endif
3914 & hnormu(:,:,ifile))
3915# endif
3916 END SELECT
3917 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
3918 END IF
3919!
3920! 2D norm at V-points.
3921!
3922 IF (cnorm(ifile,isvbar)) THEN
3923 IF (master) THEN
3924 WRITE (stdout,20) trim(text), &
3925 & '2D normalization factors at V-points'
3926 FLUSH (stdout)
3927 END IF
3928 DO j=jstrp,jendt
3929 DO i=istrt,iendt
3930 a2davg(i,j)=0.0_r8
3931 a2dsqr(i,j)=0.0_r8
3932 hscale(i,j)=1.0_r8/sqrt(om_v(i,j)*on_v(i,j))
3933 END DO
3934 END DO
3935 DO iter=1,nrandom
3936 CALL white_noise2d (ng, itlm, v2dvar, rscheme(ng), &
3937 & istrr, iendr, jstr, jendr, &
3938 & lbi, ubi, lbj, ubj, &
3939 & amin, amax, a2d)
3940 DO j=jstrp,jendt
3941 DO i=istrt,iendt
3942 a2d(i,j)=a2d(i,j)*hscale(i,j)
3943 END DO
3944 END DO
3945 CALL tl_conv_v2d_tile (ng, tile, itlm, &
3946 & lbi, ubi, lbj, ubj, &
3947 & imins, imaxs, jmins, jmaxs, &
3948 & nghostpoints, &
3949 & nhsteps(ifile,isvbar)/ifac, &
3950 & dtsizeh(ifile,isvbar), &
3951 & kh, &
3952 & pm, pn, pmon_p, pnom_r, &
3953# ifdef MASKING
3954 & vmask, pmask, &
3955# endif
3956 & a2d)
3957 DO j=jstrv,jend
3958 DO i=istr,iend
3959 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
3960 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
3961 END DO
3962 END DO
3963 END DO
3964 DO j=jstrv,jend
3965 DO i=istr,iend
3966 aavg=facavg*a2davg(i,j)
3967 asqr=facavg*a2dsqr(i,j)
3968# ifdef MASKING
3969 IF (vmask(i,j).gt.0.0_r8) THEN
3970 hnormv(i,j,ifile)=1.0_r8/sqrt(asqr)
3971 ELSE
3972 hnormv(i,j,ifile)=0.0_r8
3973 END IF
3974# else
3975 hnormv(i,j,ifile)=1.0_r8/sqrt(asqr)
3976# endif
3977 END DO
3978 END DO
3979 CALL dabc_v2d_tile (ng, tile, &
3980 & lbi, ubi, lbj, ubj, &
3981 & hnormv(:,:,ifile))
3982# ifdef DISTRIBUTE
3983 CALL mp_exchange2d (ng, tile, itlm, 1, &
3984 & lbi, ubi, lbj, ubj, &
3985 & nghostpoints, &
3986 & ewperiodic(ng), nsperiodic(ng), &
3987 & hnormv(:,:,ifile))
3988# endif
3989!
3990 SELECT CASE (nrm(ifile,ng)%IOtype)
3991 CASE (io_nf90)
3992 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
3993 & lbi, ubi, lbj, ubj, idvbar, &
3994 & nrm(ifile,ng)%ncid, &
3995 & nrm(ifile,ng)%Vid(idvbar), &
3996 & nrm(ifile,ng)%Rindex, &
3997# ifdef MASKING
3998 & vmask, &
3999# endif
4000 & hnormv(:,:,ifile))
4001
4002# if defined PIO_LIB && defined DISTRIBUTE
4003 CASE (io_pio)
4004 IF (nrm(ifile,ng)%pioVar(idvbar)%dkind.eq. &
4005 & pio_double) THEN
4006 iodesc => iodesc_dp_v2dvar(ng)
4007 ELSE
4008 iodesc => iodesc_sp_v2dvar(ng)
4009 END IF
4010 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
4011 & lbi, ubi, lbj, ubj, idvbar, &
4012 & nrm(ifile,ng)%pioFile, &
4013 & nrm(ifile,ng)%pioVar(idvbar), &
4014 & nrm(ifile,ng)%Rindex, &
4015 & iodesc, &
4016# ifdef MASKING
4017 & vmask, &
4018# endif
4019 & hnormv(:,:,ifile))
4020# endif
4021 END SELECT
4022 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4023 END IF
4024
4025# ifdef SOLVE3D
4026!
4027! 3D norm U-points.
4028!
4029 IF (cnorm(ifile,isuvel)) THEN
4030 IF (master) THEN
4031 WRITE (stdout,20) trim(text), &
4032 & '3D normalization factors at U-points'
4033 FLUSH (stdout)
4034 END IF
4035 DO j=jstrt,jendt
4036 DO i=istrp,iendt
4037 val=om_u(i,j)*on_u(i,j)*0.5_r8
4038 DO k=1,n(ng)
4039 a3davg(i,j,k)=0.0_r8
4040 a3dsqr(i,j,k)=0.0_r8
4041 vscale(i,j,k)=1.0_r8/sqrt(val*(hz(i-1,j,k)+hz(i,j,k)))
4042 END DO
4043 END DO
4044 END DO
4045 DO iter=1,nrandom
4046 CALL white_noise3d (ng, itlm, u3dvar, rscheme(ng), &
4047 & istr, iendr, jstrr, jendr, &
4048 & lbi, ubi, lbj, ubj, 1, n(ng), &
4049 & amin, amax, a3d)
4050 DO k=1,n(ng)
4051 DO j=jstrt,jendt
4052 DO i=istrp,iendt
4053 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
4054 END DO
4055 END DO
4056 END DO
4057 CALL tl_conv_u3d_tile (ng, tile, itlm, &
4058 & lbi, ubi, lbj, ubj, 1, n(ng), &
4059 & imins, imaxs, jmins, jmaxs, &
4060 & nghostpoints, &
4061 & nhsteps(ifile,isuvel)/ifac, &
4062 & nvsteps(ifile,isuvel)/ifac, &
4063 & dtsizeh(ifile,isuvel), &
4064 & dtsizev(ifile,isuvel), &
4065 & kh, kv, &
4066 & pm, pn, &
4067# ifdef GEOPOTENTIAL_HCONV
4068 & on_r, om_p, &
4069# else
4070 & pmon_r, pnom_p, &
4071# endif
4072# ifdef MASKING
4073# ifdef GEOPOTENTIAL_HCONV
4074 & pmask, rmask, umask, vmask, &
4075# else
4076 & umask, pmask, &
4077# endif
4078# endif
4079 & hz, z_r, &
4080 & a3d)
4081 DO k=1,n(ng)
4082 DO j=jstr,jend
4083 DO i=istru,iend
4084 a3davg(i,j,k)=a3davg(i,j,k)+a3d(i,j,k)
4085 a3dsqr(i,j,k)=a3dsqr(i,j,k)+a3d(i,j,k)*a3d(i,j,k)
4086 END DO
4087 END DO
4088 END DO
4089 END DO
4090 DO k=1,n(ng)
4091 DO j=jstr,jend
4092 DO i=istru,iend
4093 aavg=facavg*a3davg(i,j,k)
4094 asqr=facavg*a3dsqr(i,j,k)
4095# ifdef MASKING
4096 IF (umask(i,j).gt.0.0_r8) THEN
4097 vnormu(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4098 ELSE
4099 vnormu(i,j,k,ifile)=0.0_r8
4100 END IF
4101# else
4102 vnormu(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4103# endif
4104 END DO
4105 END DO
4106 END DO
4107 CALL dabc_u3d_tile (ng, tile, &
4108 & lbi, ubi, lbj, ubj, 1, n(ng), &
4109 & vnormu(:,:,:,ifile))
4110# ifdef DISTRIBUTE
4111 CALL mp_exchange3d (ng, tile, itlm, 1, &
4112 & lbi, ubi, lbj, ubj, 1, n(ng), &
4113 & nghostpoints, &
4114 & ewperiodic(ng), nsperiodic(ng), &
4115 & vnormu(:,:,:,ifile))
4116# endif
4117!
4118 SELECT CASE (nrm(ifile,ng)%IOtype)
4119 CASE (io_nf90)
4120 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
4121 & lbi, ubi, lbj, ubj, 1, n(ng), &
4122 & iduvel, nrm(ifile,ng)%ncid, &
4123 & nrm(ifile,ng)%Vid(iduvel), &
4124 & nrm(ifile,ng)%Rindex, &
4125# ifdef MASKING
4126 & umask, &
4127# endif
4128 & vnormu(:,:,:,ifile))
4129
4130# if defined PIO_LIB && defined DISTRIBUTE
4131 CASE (io_pio)
4132 IF (nrm(ifile,ng)%pioVar(iduvel)%dkind.eq. &
4133 & pio_double) THEN
4134 iodesc => iodesc_dp_u3dvar(ng)
4135 ELSE
4136 iodesc => iodesc_sp_u3dvar(ng)
4137 END IF
4138 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
4139 & lbi, ubi, lbj, ubj, 1, n(ng), &
4140 & iduvel, nrm(ifile,ng)%pioFile, &
4141 & nrm(ifile,ng)%pioVar(iduvel), &
4142 & nrm(ifile,ng)%Rindex, &
4143 & iodesc, &
4144# ifdef MASKING
4145 & umask, &
4146# endif
4147 & vnormu(:,:,:,ifile))
4148# endif
4149 END SELECT
4150 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4151 END IF
4152!
4153! 3D norm at V-points.
4154!
4155 IF (cnorm(ifile,isvvel)) THEN
4156 IF (master) THEN
4157 WRITE (stdout,20) trim(text), &
4158 & '3D normalization factors at V-points'
4159 FLUSH (stdout)
4160 END IF
4161 DO j=jstrp,jendt
4162 DO i=istrt,iendt
4163 val=om_v(i,j)*on_v(i,j)*0.5_r8
4164 DO k=1,n(ng)
4165 a3davg(i,j,k)=0.0_r8
4166 a3dsqr(i,j,k)=0.0_r8
4167 vscale(i,j,k)=1.0_r8/sqrt(val*(hz(i,j-1,k)+hz(i,j,k)))
4168 END DO
4169 END DO
4170 END DO
4171 DO iter=1,nrandom
4172 CALL white_noise3d (ng, itlm, v3dvar, rscheme(ng), &
4173 & istrr, iendr, jstr, jendr, &
4174 & lbi, ubi, lbj, ubj, 1, n(ng), &
4175 & amin, amax, a3d)
4176 DO k=1,n(ng)
4177 DO j=jstrp,jendt
4178 DO i=istrt,iendt
4179 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
4180 END DO
4181 END DO
4182 END DO
4183 CALL tl_conv_v3d_tile (ng, tile, itlm, &
4184 & lbi, ubi, lbj, ubj, 1, n(ng), &
4185 & imins, imaxs, jmins, jmaxs, &
4186 & nghostpoints, &
4187 & nhsteps(ifile,isvvel)/ifac, &
4188 & nvsteps(ifile,isvvel)/ifac, &
4189 & dtsizeh(ifile,isvvel), &
4190 & dtsizev(ifile,isvvel), &
4191 & kh, kv, &
4192 & pm, pn, &
4193# ifdef GEOPOTENTIAL_HCONV
4194 & on_p, om_r, &
4195# else
4196 & pmon_p, pnom_r, &
4197# endif
4198# ifdef MASKING
4199# ifdef GEOPOTENTIAL_HCONV
4200 & pmask, rmask, umask, vmask, &
4201# else
4202 & vmask, pmask, &
4203# endif
4204# endif
4205 & hz, z_r, &
4206 & a3d)
4207 DO k=1,n(ng)
4208 DO j=jstrv,jend
4209 DO i=istr,iend
4210 a3davg(i,j,k)=a3davg(i,j,k)+a3d(i,j,k)
4211 a3dsqr(i,j,k)=a3dsqr(i,j,k)+a3d(i,j,k)*a3d(i,j,k)
4212 END DO
4213 END DO
4214 END DO
4215 END DO
4216 DO k=1,n(ng)
4217 DO j=jstrv,jend
4218 DO i=istr,iend
4219 aavg=facavg*a3davg(i,j,k)
4220 asqr=facavg*a3dsqr(i,j,k)
4221# ifdef MASKING
4222 IF (vmask(i,j).gt.0.0_r8) THEN
4223 vnormv(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4224 ELSE
4225 vnormv(i,j,k,ifile)=0.0_r8
4226 END IF
4227# else
4228 vnormv(i,j,k,ifile)=1.0_r8/sqrt(asqr)
4229# endif
4230 END DO
4231 END DO
4232 END DO
4233 CALL dabc_v3d_tile (ng, tile, &
4234 & lbi, ubi, lbj, ubj, 1, n(ng), &
4235 & vnormv(:,:,:,ifile))
4236# ifdef DISTRIBUTE
4237 CALL mp_exchange3d (ng, tile, itlm, 1, &
4238 & lbi, ubi, lbj, ubj, 1, n(ng), &
4239 & nghostpoints, &
4240 & ewperiodic(ng), nsperiodic(ng), &
4241 & vnormv(:,:,:,ifile))
4242# endif
4243!
4244 SELECT CASE (nrm(ifile,ng)%IOtype)
4245 CASE (io_nf90)
4246 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
4247 & lbi, ubi, lbj, ubj, 1, n(ng), &
4248 & idvvel, nrm(ifile,ng)%ncid, &
4249 & nrm(ifile,ng)%Vid(idvvel), &
4250 & nrm(ifile,ng)%Rindex, &
4251# ifdef MASKING
4252 & vmask, &
4253# endif
4254 & vnormv(:,:,:,ifile))
4255
4256# if defined PIO_LIB && defined DISTRIBUTE
4257 CASE (io_pio)
4258 IF (nrm(ifile,ng)%pioVar(idvvel)%dkind.eq. &
4259 & pio_double) THEN
4260 iodesc => iodesc_dp_v3dvar(ng)
4261 ELSE
4262 iodesc => iodesc_sp_v3dvar(ng)
4263 END IF
4264 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
4265 & lbi, ubi, lbj, ubj, 1, n(ng), &
4266 & idvvel, nrm(ifile,ng)%pioFile, &
4267 & nrm(ifile,ng)%pioVar(idvvel), &
4268 & nrm(ifile,ng)%Rindex, &
4269 & iodesc, &
4270# ifdef MASKING
4271 & vmask, &
4272# endif
4273 & vnormv(:,:,:,ifile))
4274# endif
4275 END SELECT
4276 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4277 END IF
4278!
4279! 3D norm at RHO-points.
4280!
4281 IF (master) THEN
4282 lsame=.false.
4283 DO itrc=1,nt(ng)
4284 is=istvar(itrc)
4285 IF (cnorm(ifile,is)) lsame=.true.
4286 END DO
4287 IF (lsame) THEN
4288 WRITE (stdout,20) trim(text), &
4289 & '3D normalization factors at RHO-points'
4290 FLUSH (stdout)
4291 END IF
4292 END IF
4293!
4294! Check if the decorrelation scales for all the tracers are different.
4295! If not, just compute the normalization factors for the first tracer
4296! and assign the same value to the rest. Recall that this computation
4297! is very expensive.
4298!
4299 ldiffer=.false.
4300 DO itrc=2,nt(ng)
4301 IF ((hdecay(ifile,istvar(itrc ),ng).ne. &
4302 & hdecay(ifile,istvar(itrc-1),ng)).or. &
4303 & (vdecay(ifile,istvar(itrc ),ng).ne. &
4304 & vdecay(ifile,istvar(itrc-1),ng))) THEN
4305 ldiffer=.true.
4306 END IF
4307 END DO
4308 IF (.not.ldiffer) THEN
4309 lsame=.true.
4310 ubt=1
4311 ELSE
4312 lsame=.false.
4313 ubt=nt(ng)
4314 END IF
4315!
4316 DO j=jstrt,jendt
4317 DO i=istrt,iendt
4318 val=om_r(i,j)*on_r(i,j)
4319 DO k=1,n(ng)
4320 vscale(i,j,k)=1.0_r8/sqrt(val*hz(i,j,k))
4321 END DO
4322 END DO
4323 END DO
4324 DO itrc=1,ubt
4325 is=istvar(itrc)
4326 IF (cnorm(ifile,is)) THEN
4327 DO k=1,n(ng)
4328 DO j=jstrt,jendt
4329 DO i=istrt,iendt
4330 a3davg(i,j,k)=0.0_r8
4331 a3dsqr(i,j,k)=0.0_r8
4332 END DO
4333 END DO
4334 END DO
4335 DO iter=1,nrandom
4336 CALL white_noise3d (ng, itlm, r3dvar, rscheme(ng), &
4337 & istrr, iendr, jstrr, jendr, &
4338 & lbi, ubi, lbj, ubj, 1, n(ng), &
4339 & amin, amax, a3d)
4340 DO k=1,n(ng)
4341 DO j=jstrt,jendt
4342 DO i=istrt,iendt
4343 a3d(i,j,k)=a3d(i,j,k)*vscale(i,j,k)
4344 END DO
4345 END DO
4346 END DO
4347 CALL tl_conv_r3d_tile (ng, tile, itlm, &
4348 & lbi, ubi, lbj, ubj, 1, n(ng), &
4349 & imins, imaxs, jmins, jmaxs, &
4350 & nghostpoints, &
4351 & nhsteps(ifile,is)/ifac, &
4352 & nvsteps(ifile,is)/ifac, &
4353 & dtsizeh(ifile,is), &
4354 & dtsizev(ifile,is), &
4355 & kh, kv, &
4356 & pm, pn, &
4357# ifdef GEOPOTENTIAL_HCONV
4358 & on_u, om_v, &
4359# else
4360 & pmon_u, pnom_v, &
4361# endif
4362# ifdef MASKING
4363 & rmask, umask, vmask, &
4364# endif
4365 & hz, z_r, &
4366 & a3d)
4367 DO k=1,n(ng)
4368 DO j=jstr,jend
4369 DO i=istr,iend
4370 a3davg(i,j,k)=a3davg(i,j,k)+a3d(i,j,k)
4371 a3dsqr(i,j,k)=a3dsqr(i,j,k)+a3d(i,j,k)*a3d(i,j,k)
4372 END DO
4373 END DO
4374 END DO
4375 END DO
4376 DO k=1,n(ng)
4377 DO j=jstr,jend
4378 DO i=istr,iend
4379 aavg=facavg*a3davg(i,j,k)
4380 asqr=facavg*a3dsqr(i,j,k)
4381# ifdef MASKING
4382 IF (rmask(i,j).gt.0.0_r8) THEN
4383 vnormr(i,j,k,ifile,itrc)=1.0_r8/sqrt(asqr)
4384 ELSE
4385 vnormr(i,j,k,ifile,itrc)=0.0_r8
4386 END IF
4387# else
4388 vnormr(i,j,k,ifile,itrc)=1.0_r8/sqrt(asqr)
4389# endif
4390 END DO
4391 END DO
4392 END DO
4393 END IF
4394 END DO
4395 IF (lsame) THEN
4396 DO itrc=2,nt(ng)
4397 DO k=1,n(ng)
4398 DO j=jstr,jend
4399 DO i=istr,iend
4400 vnormr(i,j,k,ifile,itrc)=vnormr(i,j,k,ifile,1)
4401 END DO
4402 END DO
4403 END DO
4404 END DO
4405 END IF
4406 DO itrc=1,nt(ng)
4407 is=istvar(itrc)
4408 IF (cnorm(ifile,is)) THEN
4409 CALL dabc_r3d_tile (ng, tile, &
4410 & lbi, ubi, lbj, ubj, 1, n(ng), &
4411 & vnormr(:,:,:,ifile,itrc))
4412# ifdef DISTRIBUTE
4413 CALL mp_exchange3d (ng, tile, itlm, 1, &
4414 & lbi, ubi, lbj, ubj, 1, n(ng), &
4415 & nghostpoints, &
4416 & ewperiodic(ng), nsperiodic(ng), &
4417 & vnormr(:,:,:,ifile,itrc))
4418# endif
4419!
4420 SELECT CASE (nrm(ifile,ng)%IOtype)
4421 CASE (io_nf90)
4422 CALL wrt_norm3d_nf90 (ng, tile, itlm, ncname, &
4423 & lbi, ubi, lbj, ubj, 1, n(ng), &
4424 & idtvar(itrc), &
4425 & nrm(ifile,ng)%ncid, &
4426 & nrm(ifile,ng)%Vid(idtvar(itrc)), &
4427 & nrm(ifile,ng)%Rindex, &
4428# ifdef MASKING
4429 & rmask, &
4430# endif
4431 & vnormr(:,:,:,ifile,itrc))
4432
4433# if defined PIO_LIB && defined DISTRIBUTE
4434 CASE (io_pio)
4435 IF (nrm(ifile,ng)%pioTrc(itrc)%dkind.eq. &
4436 & pio_double) THEN
4437 iodesc => iodesc_dp_r3dvar(ng)
4438 ELSE
4439 iodesc => iodesc_sp_r3dvar(ng)
4440 END IF
4441 CALL wrt_norm3d_pio (ng, tile, itlm, ncname, &
4442 & lbi, ubi, lbj, ubj, 1, n(ng), &
4443 & idtvar(itrc), &
4444 & nrm(ifile,ng)%pioFile, &
4445 & nrm(ifile,ng)%pioTrc(itrc), &
4446 & nrm(ifile,ng)%Rindex, &
4447 & iodesc, &
4448# ifdef MASKING
4449 & rmask, &
4450# endif
4451 & vnormr(:,:,:,ifile,itrc))
4452# endif
4453 END SELECT
4454 IF (founderror(exit_flag, noerror, &
4455 & __line__, myfile)) RETURN
4456 END IF
4457 END DO
4458# endif
4459 END IF
4460 END DO file_loop
4461
4462# ifdef ADJUST_BOUNDARY
4463!
4464!-----------------------------------------------------------------------
4465! Compute open boundaries error covariance, B, normalization factors
4466! using the randomization approach of Fisher and Courtier (1995).
4467!-----------------------------------------------------------------------
4468!
4469 ifile=3
4470 IF (lwrtnrm(ifile,ng)) THEN
4471 text='boundary conditions'
4472 ijlen=ubij-lbij+1
4473# ifdef SOLVE3D
4474 ijklen=ijlen*n(ng)
4475# endif
4476 lconvolve(iwest )=domain(ng)%Western_Edge (tile)
4477 lconvolve(ieast )=domain(ng)%Eastern_Edge (tile)
4478 lconvolve(isouth)=domain(ng)%Southern_Edge(tile)
4479 lconvolve(inorth)=domain(ng)%Northern_Edge(tile)
4480!
4481! Set randomization summation factors.
4482!
4483 facavg=1.0_r8/real(nrandom,r8)
4484 facsqr=sqrt(real(nrandom,r8))
4485!
4486! Set time record index to write in normalization NetCDF file.
4487!
4488 ncname=nrm(ifile,ng)%name
4489 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
4490 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
4491!
4492! Write out model time (s).
4493!
4494 SELECT CASE (nrm(ifile,ng)%IOtype)
4495 CASE (io_nf90)
4496 CALL netcdf_put_fvar (ng, itlm, ncname, &
4497 & vname(1,idtime), my_time, &
4498 & start = (/nrm(ifile,ng)%Rindex/), &
4499 & total = (/1/), &
4500 & ncid = nrm(ifile,ng)%ncid, &
4501 & varid = nrm(ifile,ng)%Vid(idtime))
4502
4503# if defined PIO_LIB && defined DISTRIBUTE
4504 CASE (io_pio)
4505 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4506 & vname(1,idtime), my_time, &
4507 & start = (/nrm(ifile,ng)%Rindex/), &
4508 & total = (/1/), &
4509 & piofile = nrm(ifile,ng)%pioFile, &
4510 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
4511# endif
4512 END SELECT
4513 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4514!
4515! 2D boundary norm at RHO-points.
4516!
4517 hnormrobc=aspv
4518
4519 IF (master.and.any(cnormb(isfsur,:))) THEN
4520 WRITE (stdout,20) trim(text), &
4521 & '2D normalization factors at RHO-points'
4522 FLUSH (stdout)
4523 END IF
4524
4525 DO ibry=1,4
4526 IF (cnormb(isfsur,ibry)) THEN
4527 hscaleb=0.0_r8
4528 b2davg=0.0_r8
4529 b2dsqr=0.0_r8
4530 b2d=0.0_r8
4531 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4532 i=bounds(ng)%edge(ibry,r2dvar)
4533 IF (lconvolve(ibry)) THEN
4534 DO j=jstrt,jendt
4535 hscaleb(j)=1.0_r8/sqrt(on_r(i,j))
4536 END DO
4537 END IF
4538 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4539 j=bounds(ng)%edge(ibry,r2dvar)
4540 IF (lconvolve(ibry)) THEN
4541 DO i=istrt,iendt
4542 hscaleb(i)=1.0_r8/sqrt(om_r(i,j))
4543 END DO
4544 END IF
4545 END IF
4546 DO iter=1,nrandom
4547 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4548 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4549 & rscheme(ng), &
4550 & jstrr, jendr, &
4551 & lbij, ubij, &
4552 & bmin, bmax, b2d)
4553 DO j=jstrt,jendt
4554 b2d(j)=b2d(j)*hscaleb(j)
4555 END DO
4556 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4557 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4558 & rscheme(ng), &
4559 & istrr, iendr, &
4560 & lbij, ubij, &
4561 & bmin, bmax, b2d)
4562 DO i=istrt,iendt
4563 b2d(i)=b2d(i)*hscaleb(i)
4564 END DO
4565 END IF
4566 CALL tl_conv_r2d_bry_tile (ng, tile, itlm, ibry, &
4567 & bounds(ng)%edge(:,r2dvar), &
4568 & lbij, ubij, &
4569 & lbi, ubi, lbj, ubj, &
4570 & imins, imaxs, jmins, jmaxs, &
4571 & nghostpoints, &
4572 & nhstepsb(ibry,isfsur)/ifac, &
4573 & dtsizehb(ibry,isfsur), &
4574 & kh, &
4575 & pm, pn, pmon_u, pnom_v, &
4576# ifdef MASKING
4577 & rmask, umask, vmask, &
4578# endif
4579 & b2d)
4580 IF (lconvolve(ibry)) THEN
4581 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4582 DO j=jstr,jend
4583 b2davg(j)=b2davg(j)+b2d(j)
4584 b2dsqr(j)=b2dsqr(j)+b2d(j)*b2d(j)
4585 END DO
4586 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4587 DO i=istr,iend
4588 b2davg(i)=b2davg(i)+b2d(i)
4589 b2dsqr(i)=b2dsqr(i)+b2d(i)*b2d(i)
4590 END DO
4591 END IF
4592 END IF
4593 END DO
4594 IF (lconvolve(ibry)) THEN
4595 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4596 DO j=jstr,jend
4597 bavg=facavg*b2davg(j)
4598 bsqr=facavg*b2dsqr(j)
4599# ifdef MASKING
4600 IF (rmask(i,j).gt.0.0_r8) THEN
4601 hnormrobc(j,ibry)=1.0_r8/sqrt(bsqr)
4602 ELSE
4603 hnormrobc(j,ibry)=0.0_r8
4604 END IF
4605# else
4606 hnormrobc(j,ibry)=1.0_r8/sqrt(bsqr)
4607# endif
4608 END DO
4609 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4610 DO i=istr,iend
4611 bavg=facavg*b2davg(i)
4612 bsqr=facavg*b2dsqr(i)
4613# ifdef MASKING
4614 IF (rmask(i,j).gt.0.0_r8) THEN
4615 hnormrobc(i,ibry)=1.0_r8/sqrt(bsqr)
4616 ELSE
4617 hnormrobc(i,ibry)=0.0_r8
4618 END IF
4619# else
4620 hnormrobc(i,ibry)=1.0_r8/sqrt(bsqr)
4621# endif
4622 END DO
4623 END IF
4624 END IF
4625 CALL bc_r2d_bry_tile (ng, tile, ibry, &
4626 & lbij, ubij, &
4627 & hnormrobc(:,ibry))
4628# ifdef DISTRIBUTE
4629 CALL mp_collect (ng, itlm, ijlen, aspv, &
4630 & hnormrobc(lbij:,ibry))
4631# endif
4632 END IF
4633 END DO
4634 IF (any(cnormb(isfsur,:))) THEN
4635 ifield=idsbry(isfsur)
4636
4637 SELECT CASE (nrm(ifile,ng)%IOtype)
4638 CASE (io_nf90)
4639 CALL netcdf_put_fvar (ng, itlm, ncname, &
4640 & vname(1,ifield), &
4641 & hnormrobc(lbij:,:), &
4642 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4643 & total = (/ijlen,4,1/), &
4644 & ncid = nrm(ifile,ng)%ncid, &
4645 & varid = nrm(ifile,ng)%Vid(ifield))
4646
4647# if defined PIO_LIB && defined DISTRIBUTE
4648 CASE (io_pio)
4649 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4650 & vname(1,ifield), &
4651 & hnormrobc(lbij:,:), &
4652 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4653 & total = (/ijlen,4,1/), &
4654 & piofile = nrm(ifile,ng)%pioFile, &
4655 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
4656
4657# endif
4658 END SELECT
4659 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4660 END IF
4661!
4662! 2D boundary norm at U-points.
4663!
4664 hnormuobc=aspv
4665
4666 IF (master.and.any(cnormb(isubar,:))) THEN
4667 WRITE (stdout,20) trim(text), &
4668 & '2D normalization factors at U-points'
4669 FLUSH (stdout)
4670 END IF
4671
4672 DO ibry=1,4
4673 IF (cnormb(isubar,ibry)) THEN
4674 hscaleb=0.0_r8
4675 b2davg=0.0_r8
4676 b2dsqr=0.0_r8
4677 b2d=0.0_r8
4678 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4679 i=bounds(ng)%edge(ibry,u2dvar)
4680 IF (lconvolve(ibry)) THEN
4681 DO j=jstrt,jendt
4682 hscaleb(j)=1.0_r8/sqrt(on_u(i,j))
4683 END DO
4684 END IF
4685 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4686 j=bounds(ng)%edge(ibry,u2dvar)
4687 IF (lconvolve(ibry)) THEN
4688 DO i=istrp,iendt
4689 hscaleb(i)=1.0_r8/sqrt(om_u(i,j))
4690 END DO
4691 END IF
4692 END IF
4693 DO iter=1,nrandom
4694 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4695 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4696 & rscheme(ng), &
4697 & jstrr, jendr, &
4698 & lbij, ubij, &
4699 & bmin, bmax, b2d)
4700 DO j=jstrt,jendt
4701 b2d(j)=b2d(j)*hscaleb(j)
4702 END DO
4703 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4704 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4705 & rscheme(ng), &
4706 & istr, iendr, &
4707 & lbij, ubij, &
4708 & bmin, bmax, b2d)
4709 DO i=istrp,iendt
4710 b2d(i)=b2d(i)*hscaleb(i)
4711 END DO
4712 END IF
4713 CALL tl_conv_u2d_bry_tile (ng, tile, itlm, ibry, &
4714 & bounds(ng)%edge(:,u2dvar), &
4715 & lbij, ubij, &
4716 & lbi, ubi, lbj, ubj, &
4717 & imins, imaxs, jmins, jmaxs, &
4718 & nghostpoints, &
4719 & nhstepsb(ibry,isubar)/ifac, &
4720 & dtsizehb(ibry,isubar), &
4721 & kh, &
4722 & pm, pn, pmon_r, pnom_p, &
4723# ifdef MASKING
4724 & umask, pmask, &
4725# endif
4726 & b2d)
4727 IF (lconvolve(ibry)) THEN
4728 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4729 DO j=jstr,jend
4730 b2davg(j)=b2davg(j)+b2d(j)
4731 b2dsqr(j)=b2dsqr(j)+b2d(j)*b2d(j)
4732 END DO
4733 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4734 DO i=istru,iend
4735 b2davg(i)=b2davg(i)+b2d(i)
4736 b2dsqr(i)=b2dsqr(i)+b2d(i)*b2d(i)
4737 END DO
4738 END IF
4739 END IF
4740 END DO
4741 IF (lconvolve(ibry)) THEN
4742 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4743 DO j=jstr,jend
4744 bavg=facavg*b2davg(j)
4745 bsqr=facavg*b2dsqr(j)
4746# ifdef MASKING
4747 IF (umask(i,j).gt.0.0_r8) THEN
4748 hnormuobc(j,ibry)=1.0_r8/sqrt(bsqr)
4749 ELSE
4750 hnormuobc(j,ibry)=0.0_r8
4751 END IF
4752# else
4753 hnormuobc(j,ibry)=1.0_r8/sqrt(bsqr)
4754# endif
4755 END DO
4756 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4757 DO i=istru,iend
4758 bavg=facavg*b2davg(i)
4759 bsqr=facavg*b2dsqr(i)
4760# ifdef MASKING
4761 IF (umask(i,j).gt.0.0_r8) THEN
4762 hnormuobc(i,ibry)=1.0_r8/sqrt(bsqr)
4763 ELSE
4764 hnormuobc(i,ibry)=0.0_r8
4765 END IF
4766# else
4767 hnormuobc(i,ibry)=1.0_r8/sqrt(bsqr)
4768# endif
4769 END DO
4770 END IF
4771 END IF
4772 CALL bc_u2d_bry_tile (ng, tile, ibry, &
4773 & lbij, ubij, &
4774 & hnormuobc(:,ibry))
4775# ifdef DISTRIBUTE
4776 CALL mp_collect (ng, itlm, ijlen, aspv, &
4777 & hnormuobc(lbij:,ibry))
4778# endif
4779 END IF
4780 END DO
4781 IF (any(cnormb(isubar,:))) THEN
4782 ifield=idsbry(isubar)
4783
4784 SELECT CASE (nrm(ifile,ng)%IOtype)
4785 CASE (io_nf90)
4786 CALL netcdf_put_fvar (ng, itlm, ncname, &
4787 & vname(1,ifield), &
4788 & hnormuobc(lbij:,:), &
4789 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4790 & total = (/ijlen,4,1/), &
4791 & ncid = nrm(ifile,ng)%ncid, &
4792 & varid = nrm(ifile,ng)%Vid(ifield))
4793
4794# if defined PIO_LIB && defined DISTRIBUTE
4795 CASE (io_pio)
4796 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4797 & vname(1,ifield), &
4798 & hnormuobc(lbij:,:), &
4799 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4800 & total = (/ijlen,4,1/), &
4801 & piofile = nrm(ifile,ng)%pioFile, &
4802 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
4803# endif
4804 END SELECT
4805 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4806 END IF
4807!
4808! 2D boundary norm at V-points.
4809!
4810 hnormvobc=aspv
4811
4812 IF (master.and.any(cnormb(isvbar,:))) THEN
4813 WRITE (stdout,20) trim(text), &
4814 & '2D normalization factors at V-points'
4815 FLUSH (stdout)
4816 END IF
4817
4818 DO ibry=1,4
4819 IF (cnormb(isvbar,ibry)) THEN
4820 hscaleb=0.0_r8
4821 b2davg=0.0_r8
4822 b2dsqr=0.0_r8
4823 b2d=0.0_r8
4824 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4825 i=bounds(ng)%edge(ibry,v2dvar)
4826 IF (lconvolve(ibry)) THEN
4827 DO j=jstrp,jendt
4828 hscaleb(j)=1.0_r8/sqrt(on_v(i,j))
4829 END DO
4830 END IF
4831 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4832 j=bounds(ng)%edge(ibry,v2dvar)
4833 IF (lconvolve(ibry)) THEN
4834 DO i=istrt,iendt
4835 hscaleb(i)=1.0_r8/sqrt(om_v(i,j))
4836 END DO
4837 END IF
4838 END IF
4839 DO iter=1,nrandom
4840 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4841 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4842 & rscheme(ng), &
4843 & jstr, jendr, &
4844 & lbij, ubij, &
4845 & bmin, bmax, b2d)
4846 DO j=jstrp,jendt
4847 b2d(j)=b2d(j)*hscaleb(j)
4848 END DO
4849 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4850 CALL white_noise2d_bry (ng, tile, itlm, ibry, &
4851 & rscheme(ng), &
4852 & istrr, iendr, &
4853 & lbij, ubij, &
4854 & bmin, bmax, b2d)
4855 DO i=istrt,iendt
4856 b2d(i)=b2d(i)*hscaleb(i)
4857 END DO
4858 END IF
4859 CALL tl_conv_v2d_bry_tile (ng, tile, itlm, ibry, &
4860 & bounds(ng)%edge(:,v2dvar), &
4861 & lbij, ubij, &
4862 & lbi, ubi, lbj, ubj, &
4863 & imins, imaxs, jmins, jmaxs, &
4864 & nghostpoints, &
4865 & nhstepsb(ibry,isfsur)/ifac, &
4866 & dtsizehb(ibry,isfsur), &
4867 & kh, &
4868 & pm, pn, pmon_p, pnom_r, &
4869# ifdef MASKING
4870 & vmask, pmask, &
4871# endif
4872 & b2d)
4873 IF (lconvolve(ibry)) THEN
4874 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4875 DO j=jstrv,jend
4876 b2davg(j)=b2davg(j)+b2d(j)
4877 b2dsqr(j)=b2dsqr(j)+b2d(j)*b2d(j)
4878 END DO
4879 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4880 DO i=istr,iend
4881 b2davg(i)=b2davg(i)+b2d(i)
4882 b2dsqr(i)=b2dsqr(i)+b2d(i)*b2d(i)
4883 END DO
4884 END IF
4885 END IF
4886 END DO
4887 IF (lconvolve(ibry)) THEN
4888 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4889 DO j=jstrv,jend
4890 bavg=facavg*b2davg(j)
4891 bsqr=facavg*b2dsqr(j)
4892# ifdef MASKING
4893 IF (vmask(i,j).gt.0.0_r8) THEN
4894 hnormvobc(j,ibry)=1.0_r8/sqrt(bsqr)
4895 ELSE
4896 hnormvobc(j,ibry)=0.0_r8
4897 END IF
4898# else
4899 hnormvobc(j,ibry)=1.0_r8/sqrt(bsqr)
4900# endif
4901 END DO
4902 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4903 DO i=istr,iend
4904 bavg=facavg*b2davg(i)
4905 bsqr=facavg*b2dsqr(i)
4906# ifdef MASKING
4907 IF (vmask(i,j).gt.0.0_r8) THEN
4908 hnormvobc(i,ibry)=1.0_r8/sqrt(bsqr)
4909 ELSE
4910 hnormvobc(i,ibry)=0.0_r8
4911 END IF
4912# else
4913 hnormvobc(i,ibry)=1.0_r8/sqrt(bsqr)
4914# endif
4915 END DO
4916 END IF
4917 END IF
4918 CALL bc_v2d_bry_tile (ng, tile, ibry, &
4919 & lbij, ubij, &
4920 & hnormvobc(:,ibry))
4921# ifdef DISTRIBUTE
4922 CALL mp_collect (ng, itlm, ijlen, aspv, &
4923 & hnormvobc(lbij:,ibry))
4924# endif
4925 END IF
4926 END DO
4927 IF (any(cnormb(isvbar,:))) THEN
4928 ifield=idsbry(isvbar)
4929
4930 SELECT CASE (nrm(ifile,ng)%IOtype)
4931 CASE (io_nf90)
4932 CALL netcdf_put_fvar (ng, itlm, ncname, &
4933 & vname(1,ifield), &
4934 & hnormvobc(lbij:,:), &
4935 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4936 & total = (/ijlen,4,1/), &
4937 & ncid = nrm(ifile,ng)%ncid, &
4938 & varid = nrm(ifile,ng)%Vid(ifield))
4939
4940# if defined PIO_LIB && defined DISTRIBUTE
4941 CASE (io_pio)
4942 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
4943 & vname(1,ifield), &
4944 & hnormvobc(lbij:,:), &
4945 & start = (/1,1,nrm(ifile,ng)%Rindex/), &
4946 & total = (/ijlen,4,1/), &
4947 & piofile = nrm(ifile,ng)%pioFile, &
4948 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
4949# endif
4950 END SELECT
4951 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4952 END IF
4953
4954# ifdef SOLVE3D
4955!
4956! 3D boundary norm at U-points.
4957!
4958 vnormuobc=aspv
4959
4960 IF (master.and.any(cnormb(isuvel,:))) THEN
4961 WRITE (stdout,20) trim(text), &
4962 & '3D normalization factors at U-points'
4963 FLUSH (stdout)
4964 END IF
4965
4966 DO ibry=1,4
4967 IF (cnormb(isuvel,ibry)) THEN
4968 vscaleb=0.0_r8
4969 b3davg=0.0_r8
4970 b3dsqr=0.0_r8
4971 b3d=0.0_r8
4972 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4973 i=bounds(ng)%edge(ibry,u2dvar)
4974 IF (lconvolve(ibry)) THEN
4975 DO j=jstrt,jendt
4976 val=on_u(i,j)*0.5_r8
4977 DO k=1,n(ng)
4978 vscaleb(j,k)=1.0_r8/ &
4979 & sqrt(val*(hz(i-1,j,k)+hz(i,j,k)))
4980 END DO
4981 END DO
4982 END IF
4983 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
4984 j=bounds(ng)%edge(ibry,u2dvar)
4985 IF (lconvolve(ibry)) THEN
4986 DO i=istrp,iendt
4987 val=om_u(i,j)*0.5_r8
4988 DO k=1,n(ng)
4989 vscaleb(i,k)=1.0_r8/ &
4990 & sqrt(val*(hz(i-1,j,k)+hz(i,j,k)))
4991 END DO
4992 END DO
4993 END IF
4994 END IF
4995 DO iter=1,nrandom
4996 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
4997 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
4998 & rscheme(ng), &
4999 & jstrr, jendr, &
5000 & lbij, ubij, 1, n(ng), &
5001 & bmin, bmax, b3d)
5002 DO k=1,n(ng)
5003 DO j=jstrt,jendt
5004 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
5005 END DO
5006 END DO
5007 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5008 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5009 & rscheme(ng), &
5010 & istr, iendr, &
5011 & lbij, ubij, 1, n(ng), &
5012 & bmin, bmax, b3d)
5013 DO k=1,n(ng)
5014 DO i=istrp,iendt
5015 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
5016 END DO
5017 END DO
5018 END IF
5019 CALL tl_conv_u3d_bry_tile (ng, tile, itlm, ibry, &
5020 & bounds(ng)%edge(:,u2dvar), &
5021 & lbij, ubij, &
5022 & lbi, ubi, lbj, ubj, 1, n(ng), &
5023 & imins, imaxs, jmins, jmaxs, &
5024 & nghostpoints, &
5025 & nhstepsb(ibry,isuvel)/ifac, &
5026 & nvstepsb(ibry,isuvel)/ifac, &
5027 & dtsizehb(ibry,isuvel), &
5028 & dtsizevb(ibry,isuvel), &
5029 & kh, kv, &
5030 & pm, pn, &
5031 & pmon_r, pnom_p, &
5032# ifdef MASKING
5033 & umask, pmask, &
5034# endif
5035 & hz, z_r, &
5036 & b3d)
5037 IF (lconvolve(ibry)) THEN
5038 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5039 DO k=1,n(ng)
5040 DO j=jstr,jend
5041 b3davg(j,k)=b3davg(j,k)+b3d(j,k)
5042 b3dsqr(j,k)=b3dsqr(j,k)+b3d(j,k)*b3d(j,k)
5043 END DO
5044 END DO
5045 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5046 DO k=1,n(ng)
5047 DO i=istru,iend
5048 b3davg(i,k)=b3davg(i,k)+b3d(i,k)
5049 b3dsqr(i,k)=b3dsqr(i,k)+b3d(i,k)*b3d(i,k)
5050 END DO
5051 END DO
5052 END IF
5053 END IF
5054 END DO
5055 IF (lconvolve(ibry)) THEN
5056 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5057 DO k=1,n(ng)
5058 DO j=jstr,jend
5059 bavg=facavg*b3davg(j,k)
5060 bsqr=facavg*b3dsqr(j,k)
5061# ifdef MASKING
5062 IF (umask(i,j).gt.0.0_r8) THEN
5063 vnormuobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5064 ELSE
5065 vnormuobc(j,k,ibry)=0.0_r8
5066 END IF
5067# else
5068 vnormuobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5069# endif
5070 END DO
5071 END DO
5072 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5073 DO k=1,n(ng)
5074 DO i=istru,iend
5075 bavg=facavg*b3davg(i,k)
5076 bsqr=facavg*b3dsqr(i,k)
5077# ifdef MASKING
5078 IF (umask(i,j).gt.0.0_r8) THEN
5079 vnormuobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5080 ELSE
5081 vnormuobc(i,k,ibry)=0.0_r8
5082 END IF
5083# else
5084 vnormuobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5085# endif
5086 END DO
5087 END DO
5088 END IF
5089 END IF
5090 CALL bc_u3d_bry_tile (ng, tile, ibry, &
5091 & lbij, ubij, 1, n(ng), &
5092 & vnormuobc(:,:,ibry))
5093# ifdef DISTRIBUTE
5094 bwrk=reshape(vnormuobc(:,:,ibry), (/ijklen/))
5095 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
5096 ic=0
5097 DO k=1,n(ng)
5098 DO ib=lbij,ubij
5099 ic=ic+1
5100 vnormuobc(ib,k,ibry)=bwrk(ic)
5101 END DO
5102 END DO
5103# endif
5104 END IF
5105 END DO
5106 IF (any(cnormb(isuvel,:))) THEN
5107 ifield=idsbry(isuvel)
5108
5109 SELECT CASE (nrm(ifile,ng)%IOtype)
5110 CASE (io_nf90)
5111 CALL netcdf_put_fvar (ng, itlm, ncname, &
5112 & vname(1,ifield), &
5113 & vnormuobc(lbij:,:,:), &
5114 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5115 & total = (/ijlen,n(ng),4,1/), &
5116 & ncid = nrm(ifile,ng)%ncid, &
5117 & varid = nrm(ifile,ng)%Vid(ifield))
5118
5119# if defined PIO_LIB && defined DISTRIBUTE
5120 CASE (io_pio)
5121 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5122 & vname(1,ifield), &
5123 & vnormuobc(lbij:,:,:), &
5124 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5125 & total = (/ijlen,n(ng),4,1/), &
5126 & piofile = nrm(ifile,ng)%pioFile, &
5127 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
5128# endif
5129 END SELECT
5130 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5131 END IF
5132!
5133! 3D boundary norm at V-points.
5134!
5135 vnormvobc=aspv
5136
5137 IF (master.and.any(cnormb(isvvel,:))) THEN
5138 WRITE (stdout,20) trim(text), &
5139 & '3D normalization factors at V-points'
5140 FLUSH (stdout)
5141 END IF
5142
5143 DO ibry=1,4
5144 IF (cnormb(isvvel,ibry)) THEN
5145 vscaleb=0.0_r8
5146 b3davg=0.0_r8
5147 b3dsqr=0.0_r8
5148 b3d=0.0_r8
5149 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5150 i=bounds(ng)%edge(ibry,v2dvar)
5151 IF (lconvolve(ibry)) THEN
5152 DO j=jstrp,jendt
5153 val=on_v(i,j)*0.5_r8
5154 DO k=1,n(ng)
5155 vscaleb(j,k)=1.0_r8/ &
5156 & sqrt(val*(hz(i,j-1,k)+hz(i,j,k)))
5157 END DO
5158 END DO
5159 END IF
5160 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5161 j=bounds(ng)%edge(ibry,v2dvar)
5162 IF (lconvolve(ibry)) THEN
5163 DO i=istrt,iendt
5164 val=om_v(i,j)*0.5_r8
5165 DO k=1,n(ng)
5166 vscaleb(i,k)=1.0_r8/ &
5167 & sqrt(val*(hz(i,j-1,k)+hz(i,j,k)))
5168 END DO
5169 END DO
5170 END IF
5171 END IF
5172 DO iter=1,nrandom
5173 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5174 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5175 & rscheme(ng), &
5176 & jstr, jendr, &
5177 & lbij, ubij, 1, n(ng), &
5178 & bmin, bmax, b3d)
5179 DO k=1,n(ng)
5180 DO j=jstrp,jendt
5181 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
5182 END DO
5183 END DO
5184 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5185 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5186 & rscheme(ng), &
5187 & istrr, iendr, &
5188 & lbij, ubij, 1, n(ng), &
5189 & bmin, bmax, b3d)
5190 DO k=1,n(ng)
5191 DO i=istrt,iendt
5192 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
5193 END DO
5194 END DO
5195 END IF
5196 CALL tl_conv_v3d_bry_tile (ng, tile, itlm, ibry, &
5197 & bounds(ng)%edge(:,v2dvar), &
5198 & lbij, ubij, &
5199 & lbi, ubi, lbj, ubj, 1, n(ng), &
5200 & imins, imaxs, jmins, jmaxs, &
5201 & nghostpoints, &
5202 & nhstepsb(ibry,isvvel)/ifac, &
5203 & nvstepsb(ibry,isvvel)/ifac, &
5204 & dtsizehb(ibry,isvvel), &
5205 & dtsizevb(ibry,isvvel), &
5206 & kh, kv, &
5207 & pm, pn, &
5208 & pmon_p, pnom_r, &
5209# ifdef MASKING
5210 & vmask, pmask, &
5211# endif
5212 & hz, z_r, &
5213 & b3d)
5214 IF (lconvolve(ibry)) THEN
5215 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5216 DO k=1,n(ng)
5217 DO j=jstrv,jend
5218 b3davg(j,k)=b3davg(j,k)+b3d(j,k)
5219 b3dsqr(j,k)=b3dsqr(j,k)+b3d(j,k)*b3d(j,k)
5220 END DO
5221 END DO
5222 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5223 DO k=1,n(ng)
5224 DO i=istr,iend
5225 b3davg(i,k)=b3davg(i,k)+b3d(i,k)
5226 b3dsqr(i,k)=b3dsqr(i,k)+b3d(i,k)*b3d(i,k)
5227 END DO
5228 END DO
5229 END IF
5230 END IF
5231 END DO
5232 IF (lconvolve(ibry)) THEN
5233 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5234 DO k=1,n(ng)
5235 DO j=jstrv,jend
5236 bavg=facavg*b3davg(j,k)
5237 bsqr=facavg*b3dsqr(j,k)
5238# ifdef MASKING
5239 IF (vmask(i,j).gt.0.0_r8) THEN
5240 vnormvobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5241 ELSE
5242 vnormvobc(j,k,ibry)=0.0_r8
5243 END IF
5244# else
5245 vnormvobc(j,k,ibry)=1.0_r8/sqrt(bsqr)
5246# endif
5247 END DO
5248 END DO
5249 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5250 DO k=1,n(ng)
5251 DO i=istr,iend
5252 bavg=facavg*b3davg(i,k)
5253 bsqr=facavg*b3dsqr(i,k)
5254# ifdef MASKING
5255 IF (vmask(i,j).gt.0.0_r8) THEN
5256 vnormvobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5257 ELSE
5258 vnormvobc(i,k,ibry)=0.0_r8
5259 END IF
5260# else
5261 vnormvobc(i,k,ibry)=1.0_r8/sqrt(bsqr)
5262# endif
5263 END DO
5264 END DO
5265 END IF
5266 END IF
5267 CALL bc_v3d_bry_tile (ng, tile, ibry, &
5268 & lbij, ubij, 1, n(ng), &
5269 & vnormvobc(:,:,ibry))
5270# ifdef DISTRIBUTE
5271 bwrk=reshape(vnormvobc(:,:,ibry), (/ijklen/))
5272 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
5273 ic=0
5274 DO k=1,n(ng)
5275 DO ib=lbij,ubij
5276 ic=ic+1
5277 vnormvobc(ib,k,ibry)=bwrk(ic)
5278 END DO
5279 END DO
5280# endif
5281 END IF
5282 END DO
5283 IF (any(cnormb(isvvel,:))) THEN
5284 ifield=idsbry(isvvel)
5285
5286 SELECT CASE (nrm(ifile,ng)%IOtype)
5287 CASE (io_nf90)
5288 CALL netcdf_put_fvar (ng, itlm, ncname, &
5289 & vname(1,ifield), &
5290 & vnormvobc(lbij:,:,:), &
5291 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5292 & total = (/ijlen,n(ng),4,1/), &
5293 & ncid = nrm(ifile,ng)%ncid, &
5294 & varid = nrm(ifile,ng)%Vid(ifield))
5295
5296# if defined PIO_LIB && defined DISTRIBUTE
5297 CASE (io_pio)
5298 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5299 & vname(1,ifield), &
5300 & vnormvobc(lbij:,:,:), &
5301 & start = (/1,1,1,nrm(ifile,ng)%Rindex/), &
5302 & total = (/ijlen,n(ng),4,1/), &
5303 & piofile = nrm(ifile,ng)%pioFile, &
5304 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
5305# endif
5306 END SELECT
5307 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5308 END IF
5309!
5310! 3D boundary norm at RHO-points.
5311!
5312 IF (master) THEN
5313 DO itrc=1,nt(ng)
5314 is=istvar(itrc)
5315 IF (any(cnormb(is,:))) THEN
5316 lsame=.true.
5317 EXIT
5318 END IF
5319 END DO
5320 IF (lsame) THEN
5321 WRITE (stdout,20) trim(text), &
5322 & '3D normalization factors at RHO-points'
5323 FLUSH (stdout)
5324 END IF
5325 END IF
5326
5327 DO itrc=1,nt(ng)
5328 vnormrobc=aspv
5329 is=istvar(itrc)
5330 DO ibry=1,4
5331 IF (cnormb(is,ibry)) THEN
5332 vscaleb=0.0_r8
5333 b3davg=0.0_r8
5334 b3dsqr=0.0_r8
5335 b3d=0.0_r8
5336 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5337 i=bounds(ng)%edge(ibry,r2dvar)
5338 IF (lconvolve(ibry)) THEN
5339 DO j=jstrt,jendt
5340 val=on_r(i,j)
5341 DO k=1,n(ng)
5342 vscaleb(j,k)=1.0_r8/sqrt(val*hz(i,j,k))
5343 END DO
5344 END DO
5345 END IF
5346 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5347 j=bounds(ng)%edge(ibry,r2dvar)
5348 IF (lconvolve(ibry)) THEN
5349 DO i=istrt,iendt
5350 val=om_r(i,j)
5351 DO k=1,n(ng)
5352 vscaleb(i,k)=1.0_r8/sqrt(val*hz(i,j,k))
5353 END DO
5354 END DO
5355 END IF
5356 END IF
5357 DO iter=1,nrandom
5358 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5359 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5360 & rscheme(ng), &
5361 & jstrr, jendr, &
5362 & lbij, ubij, 1, n(ng), &
5363 & bmin, bmax, b3d)
5364 DO k=1,n(ng)
5365 DO j=jstrt,jendt
5366 b3d(j,k)=b3d(j,k)*vscaleb(j,k)
5367 END DO
5368 END DO
5369 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5370 CALL white_noise3d_bry (ng, tile, itlm, ibry, &
5371 & rscheme(ng), &
5372 & istrr, iendr, &
5373 & lbij, ubij, 1, n(ng), &
5374 & bmin, bmax, b3d)
5375 DO k=1,n(ng)
5376 DO i=istrt,iendt
5377 b3d(i,k)=b3d(i,k)*vscaleb(i,k)
5378 END DO
5379 END DO
5380 END IF
5381 CALL tl_conv_r3d_bry_tile (ng, tile, itlm, ibry, &
5382 & bounds(ng)%edge(:,r2dvar), &
5383 & lbij, ubij, &
5384 & lbi, ubi, lbj, ubj, &
5385 & 1, n(ng), &
5386 & imins, imaxs, jmins, jmaxs, &
5387 & nghostpoints, &
5388 & nhstepsb(ibry,is)/ifac, &
5389 & nvstepsb(ibry,is)/ifac, &
5390 & dtsizehb(ibry,is), &
5391 & dtsizevb(ibry,is), &
5392 & kh, kv, &
5393 & pm, pn, &
5394 & pmon_u, pnom_v, &
5395# ifdef MASKING
5396 & rmask, umask, vmask, &
5397# endif
5398 & hz, z_r, &
5399 & b3d)
5400 IF (lconvolve(ibry)) THEN
5401 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5402 DO k=1,n(ng)
5403 DO j=jstr,jend
5404 b3davg(j,k)=b3davg(j,k)+b3d(j,k)
5405 b3dsqr(j,k)=b3dsqr(j,k)+b3d(j,k)*b3d(j,k)
5406 END DO
5407 END DO
5408 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5409 DO k=1,n(ng)
5410 DO i=istr,iend
5411 b3davg(i,k)=b3davg(i,k)+b3d(i,k)
5412 b3dsqr(i,k)=b3dsqr(i,k)+b3d(i,k)*b3d(i,k)
5413 END DO
5414 END DO
5415 END IF
5416 END IF
5417 END DO
5418 IF (lconvolve(ibry)) THEN
5419 IF ((ibry.eq.iwest).or.(ibry.eq.ieast)) THEN
5420 DO k=1,n(ng)
5421 DO j=jstr,jend
5422 bavg=facavg*b3davg(j,k)
5423 bsqr=facavg*b3dsqr(j,k)
5424# ifdef MASKING
5425 IF (rmask(i,j).gt.0.0_r8) THEN
5426 vnormrobc(j,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5427 ELSE
5428 vnormrobc(j,k,ibry,itrc)=0.0_r8
5429 END IF
5430# else
5431 vnormrobc(j,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5432# endif
5433 END DO
5434 END DO
5435 ELSE IF ((ibry.eq.isouth).or.(ibry.eq.inorth)) THEN
5436 DO k=1,n(ng)
5437 DO i=istr,iend
5438 bavg=facavg*b3davg(i,k)
5439 bsqr=facavg*b3dsqr(i,k)
5440# ifdef MASKING
5441 IF (rmask(i,j).gt.0.0_r8) THEN
5442 vnormrobc(i,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5443 ELSE
5444 vnormrobc(i,k,ibry,itrc)=0.0_r8
5445 END IF
5446# else
5447 vnormrobc(i,k,ibry,itrc)=1.0_r8/sqrt(bsqr)
5448# endif
5449 END DO
5450 END DO
5451 END IF
5452 END IF
5453 CALL bc_r3d_bry_tile (ng, tile, ibry, &
5454 & lbij, ubij, 1, n(ng), &
5455 & vnormrobc(:,:,ibry,itrc))
5456# ifdef DISTRIBUTE
5457 bwrk=reshape(vnormrobc(:,:,ibry,itrc), (/ijklen/))
5458 CALL mp_collect (ng, itlm, ijklen, aspv, bwrk)
5459 ic=0
5460 DO k=1,n(ng)
5461 DO ib=lbij,ubij
5462 ic=ic+1
5463 vnormrobc(ib,k,ibry,itrc)=bwrk(ic)
5464 END DO
5465 END DO
5466# endif
5467 END IF
5468 END DO
5469 IF (any(cnormb(is,:))) THEN
5470 ifield=idsbry(istvar(itrc))
5471
5472 SELECT CASE (nrm(ifile,ng)%IOtype)
5473 CASE (io_nf90)
5474 CALL netcdf_put_fvar (ng, itlm, ncname, &
5475 & vname(1,ifield), &
5476 & vnormrobc(lbij:,:,:,itrc), &
5477 & start =(/1,1,1,nrm(ifile,ng)%Rindex/), &
5478 & total = (/ijlen,n(ng),4,1/), &
5479 & ncid = nrm(ifile,ng)%ncid, &
5480 & varid = nrm(ifile,ng)%Vid(ifield))
5481
5482# if defined PIO_LIB && defined DISTRIBUTE
5483 CASE (io_pio)
5484 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5485 & vname(1,ifield), &
5486 & vnormrobc(lbij:,:,:,itrc), &
5487 & start =(/1,1,1,nrm(ifile,ng)%Rindex/), &
5488 & total = (/ijlen,n(ng),4,1/), &
5489 & piofile = nrm(ifile,ng)%pioFile, &
5490 & piovar = nrm(ifile,ng)%pioVar(ifield)%vd)
5491# endif
5492 END SELECT
5493 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5494 END IF
5495 END DO
5496# endif
5497!
5498! Synchronize open boundaries normalization NetCDF file to disk to
5499! allow other processes to access data immediately after it is
5500! written.
5501!
5502 SELECT CASE (nrm(ifile,ng)%IOtype)
5503 CASE (io_nf90)
5504 CALL netcdf_sync (ng, itlm, ncname, &
5505 & nrm(ifile,ng)%ncid)
5506# if defined PIO_LIB && defined DISTRIBUTE
5507 CASE (io_pio)
5508 CALL pio_netcdf_sync (ng, itlm, ncname, &
5509 & nrm(ifile,ng)%pioFile)
5510# endif
5511 END SELECT
5512 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5513 END IF
5514# endif
5515
5516# if defined ADJUST_WSTRESS || defined ADJUST_STFLUX
5517!
5518!-----------------------------------------------------------------------
5519! Compute surface forcing error covariance, B, normalization factors
5520! using the randomization approach of Fisher and Courtier (1995).
5521!-----------------------------------------------------------------------
5522!
5523 ifile=4
5524 IF (lwrtnrm(ifile,ng)) THEN
5525 rec=1
5526 text='surface forcing'
5527!
5528! Set randomization summation factors.
5529!
5530 facavg=1.0_r8/real(nrandom,r8)
5531 facsqr=sqrt(real(nrandom,r8))
5532!
5533! Set time record index to write in normalization NetCDF file.
5534!
5535 ncname=nrm(ifile,ng)%name
5536 nrm(ifile,ng)%Rindex=nrm(ifile,ng)%Rindex+1
5537 nrm(ifile,ng)%Nrec=nrm(ifile,ng)%Nrec+1
5538!
5539! Write out model time (s).
5540!
5541 SELECT CASE (nrm(ifile,ng)%IOtype)
5542 CASE (io_nf90)
5543 CALL netcdf_put_fvar (ng, itlm, ncname, &
5544 & vname(1,idtime), my_time, &
5545 & start = (/nrm(ifile,ng)%Rindex/), &
5546 & total = (/1/), &
5547 & ncid = nrm(ifile,ng)%ncid, &
5548 & varid = nrm(ifile,ng)%Vid(idtime))
5549
5550# if defined PIO_LIB && defined DISTRIBUTE
5551 CASE (io_pio)
5552 CALL pio_netcdf_put_fvar (ng, itlm, ncname, &
5553 & vname(1,idtime), my_time, &
5554 & start = (/nrm(ifile,ng)%Rindex/), &
5555 & total = (/1/), &
5556 & piofile = nrm(ifile,ng)%pioFile, &
5557 & piovar = nrm(ifile,ng)%pioVar(idtime)%vd)
5558# endif
5559 END SELECT
5560 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5561
5562# ifdef ADJUST_WSTRESS
5563!
5564! 2D norm at U-stress points.
5565!
5566 IF (cnorm(rec,isustr)) THEN
5567 IF (master) THEN
5568 WRITE (stdout,20) trim(text), &
5569 & '2D normalization factors at U-points'
5570 FLUSH (stdout)
5571 END IF
5572 DO j=jstrt,jendt
5573 DO i=istrp,iendt
5574 a2davg(i,j)=0.0_r8
5575 a2dsqr(i,j)=0.0_r8
5576 hscale(i,j)=1.0_r8/sqrt(om_u(i,j)*on_u(i,j))
5577 END DO
5578 END DO
5579 DO iter=1,nrandom
5580 CALL white_noise2d (ng, itlm, u2dvar, rscheme(ng), &
5581 & istr, iendr, jstrr, jendr, &
5582 & lbi, ubi, lbj, ubj, &
5583 & amin, amax, a2d)
5584 DO j=jstrt,jendt
5585 DO i=istrp,iendt
5586 a2d(i,j)=a2d(i,j)*hscale(i,j)
5587 END DO
5588 END DO
5589 CALL tl_conv_u2d_tile (ng, tile, itlm, &
5590 & lbi, ubi, lbj, ubj, &
5591 & imins, imaxs, jmins, jmaxs, &
5592 & nghostpoints, &
5593 & nhsteps(rec,isustr)/ifac, &
5594 & dtsizeh(rec,isustr), &
5595 & kh, &
5596 & pm, pn, pmon_r, pnom_p, &
5597# ifdef MASKING
5598 & umask, pmask, &
5599# endif
5600 & a2d)
5601 DO j=jstr,jend
5602 DO i=istru,iend
5603 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
5604 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
5605 END DO
5606 END DO
5607 END DO
5608 DO j=jstr,jend
5609 DO i=istru,iend
5610 aavg=facavg*a2davg(i,j)
5611 asqr=facavg*a2dsqr(i,j)
5612# ifdef MASKING
5613 IF (umask(i,j).gt.0.0_r8) THEN
5614 hnormsus(i,j)=1.0_r8/sqrt(asqr)
5615 ELSE
5616 hnormsus(i,j)=0.0_r8
5617 END IF
5618# else
5619 hnormsus(i,j)=1.0_r8/sqrt(asqr)
5620# endif
5621 END DO
5622 END DO
5623 CALL dabc_u2d_tile (ng, tile, &
5624 & lbi, ubi, lbj, ubj, &
5625 & hnormsus)
5626# ifdef DISTRIBUTE
5627 CALL mp_exchange2d (ng, tile, itlm, 1, &
5628 & lbi, ubi, lbj, ubj, &
5629 & nghostpoints, &
5630 & ewperiodic(ng), nsperiodic(ng), &
5631 & hnormsus)
5632# endif
5633!
5634 SELECT CASE (nrm(ifile,ng)%IOtype)
5635 CASE (io_nf90)
5636 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
5637 & lbi, ubi, lbj, ubj, idusms, &
5638 & nrm(ifile,ng)%ncid, &
5639 & nrm(ifile,ng)%Vid(idusms), &
5640 & nrm(ifile,ng)%Rindex, &
5641# ifdef MASKING
5642 & umask, &
5643# endif
5644 & hnormsus)
5645
5646# if defined PIO_LIB && defined DISTRIBUTE
5647 CASE (io_pio)
5648 IF (nrm(ifile,ng)%pioVar(idusms)%dkind.eq. &
5649 & pio_double) THEN
5650 iodesc => iodesc_dp_u2dvar(ng)
5651 ELSE
5652 iodesc => iodesc_sp_u2dvar(ng)
5653 END IF
5654 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
5655 & lbi, ubi, lbj, ubj, idusms, &
5656 & nrm(ifile,ng)%pioFile, &
5657 & nrm(ifile,ng)%pioVar(idusms), &
5658 & nrm(ifile,ng)%Rindex, &
5659 & iodesc, &
5660# ifdef MASKING
5661 & umask, &
5662# endif
5663 & hnormsus)
5664# endif
5665 END SELECT
5666 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5667 END IF
5668!
5669! 2D norm at V-stress points.
5670!
5671 IF (cnorm(rec,isvstr)) THEN
5672 IF (master) THEN
5673 WRITE (stdout,20) trim(text), &
5674 & '2D normalization factors at V-points'
5675 FLUSH (stdout)
5676 END IF
5677 DO j=jstrp,jendt
5678 DO i=istrt,iendt
5679 a2davg(i,j)=0.0_r8
5680 a2dsqr(i,j)=0.0_r8
5681 hscale(i,j)=1.0_r8/sqrt(om_v(i,j)*on_v(i,j))
5682 END DO
5683 END DO
5684 DO iter=1,nrandom
5685 CALL white_noise2d (ng, itlm, v2dvar, rscheme(ng), &
5686 & istrr, iendr, jstr, jendr, &
5687 & lbi, ubi, lbj, ubj, &
5688 & amin, amax, a2d)
5689 DO j=jstrp,jendt
5690 DO i=istrt,iendt
5691 a2d(i,j)=a2d(i,j)*hscale(i,j)
5692 END DO
5693 END DO
5694 CALL tl_conv_v2d_tile (ng, tile, itlm, &
5695 & lbi, ubi, lbj, ubj, &
5696 & imins, imaxs, jmins, jmaxs, &
5697 & nghostpoints, &
5698 & nhsteps(rec,isvstr)/ifac, &
5699 & dtsizeh(rec,isvstr), &
5700 & kh, &
5701 & pm, pn, pmon_p, pnom_r, &
5702# ifdef MASKING
5703 & vmask, pmask, &
5704# endif
5705 & a2d)
5706 DO j=jstrv,jend
5707 DO i=istr,iend
5708 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
5709 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
5710 END DO
5711 END DO
5712 END DO
5713 DO j=jstrv,jend
5714 DO i=istr,iend
5715 aavg=facavg*a2davg(i,j)
5716 asqr=facavg*a2dsqr(i,j)
5717# ifdef MASKING
5718 IF (vmask(i,j).gt.0.0_r8) THEN
5719 hnormsvs(i,j)=1.0_r8/sqrt(asqr)
5720 ELSE
5721 hnormsvs(i,j)=0.0_r8
5722 END IF
5723# else
5724 hnormsvs(i,j)=1.0_r8/sqrt(asqr)
5725# endif
5726 END DO
5727 END DO
5728 CALL dabc_v2d_tile (ng, tile, &
5729 & lbi, ubi, lbj, ubj, &
5730 & hnormsvs)
5731# ifdef DISTRIBUTE
5732 CALL mp_exchange2d (ng, tile, itlm, 1, &
5733 & lbi, ubi, lbj, ubj, &
5734 & nghostpoints, &
5735 & ewperiodic(ng), nsperiodic(ng), &
5736 & hnormsvs)
5737# endif
5738!
5739 SELECT CASE (nrm(ifile,ng)%IOtype)
5740 CASE (io_nf90)
5741 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
5742 & lbi, ubi, lbj, ubj, idvsms, &
5743 & nrm(ifile,ng)%ncid, &
5744 & nrm(ifile,ng)%Vid(idvsms), &
5745 & nrm(ifile,ng)%Rindex, &
5746# ifdef MASKING
5747 & vmask, &
5748# endif
5749 & hnormsvs)
5750
5751# if defined PIO_LIB && defined DISTRIBUTE
5752 CASE (io_pio)
5753 IF (nrm(ifile,ng)%pioVar(idvsms)%dkind.eq. &
5754 & pio_double) THEN
5755 iodesc => iodesc_dp_v2dvar(ng)
5756 ELSE
5757 iodesc => iodesc_sp_v2dvar(ng)
5758 END IF
5759 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
5760 & lbi, ubi, lbj, ubj, idvsms, &
5761 & nrm(ifile,ng)%pioFile, &
5762 & nrm(ifile,ng)%pioVar(idvsms), &
5763 & nrm(ifile,ng)%Rindex, &
5764 & iodesc, &
5765# ifdef MASKING
5766 & vmask, &
5767# endif
5768 & hnormsvs)
5769# endif
5770 END SELECT
5771 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
5772 END IF
5773# endif
5774# if defined ADJUST_STFLUX && defined SOLVE3D
5775!
5776! 2D norm at surface treace flux points.
5777!
5778 IF (master) THEN
5779 lsame=.false.
5780 DO itrc=1,nt(ng)
5781 IF (lstflux(itrc,ng)) THEN
5782 is=istsur(itrc)
5783 IF (cnorm(rec,is)) lsame=.true.
5784 END IF
5785 END DO
5786 IF (lsame) THEN
5787 WRITE (stdout,20) trim(text), &
5788 & '2D normalization factors at RHO-points'
5789 FLUSH (stdout)
5790 END IF
5791 END IF
5792!
5793! Check if the decorrelation scales for all the surface tracer fluxes
5794! are different. If not, just compute the normalization factors for the
5795! first tracer and assign the same value to the rest. Recall that this
5796! computation is very expensive.
5797!
5798 ldiffer=.false.
5799 DO itrc=2,nt(ng)
5800 IF (hdecay(rec,istvar(itrc ),ng).ne. &
5801 & hdecay(rec,istvar(itrc-1),ng)) THEN
5802 ldiffer=.true.
5803 END IF
5804 END DO
5805 IF (.not.ldiffer) THEN
5806 lsame=.true.
5807 ubt=1
5808 ELSE
5809 lsame=.false.
5810 ubt=nt(ng)
5811 END IF
5812!
5813 DO j=jstrt,jendt
5814 DO i=istrt,iendt
5815 hscale(i,j)=1.0_r8/sqrt(om_r(i,j)*on_r(i,j))
5816 END DO
5817 END DO
5818 DO itrc=1,ubt
5819 IF (lstflux(itrc,ng)) THEN
5820 is=istsur(itrc)
5821 IF (cnorm(rec,is)) THEN
5822 DO j=jstrt,jendt
5823 DO i=istrt,iendt
5824 a2davg(i,j)=0.0_r8
5825 a2dsqr(i,j)=0.0_r8
5826 END DO
5827 END DO
5828 DO iter=1,nrandom
5829 CALL white_noise2d (ng, itlm, r2dvar, rscheme(ng), &
5830 & istrr, iendr, jstrr, jendr, &
5831 & lbi, ubi, lbj, ubj, &
5832 & amin, amax, a2d)
5833 DO j=jstrt,jendt
5834 DO i=istrt,iendt
5835 a2d(i,j)=a2d(i,j)*hscale(i,j)
5836 END DO
5837 END DO
5838 CALL tl_conv_r2d_tile (ng, tile, itlm, &
5839 & lbi, ubi, lbj, ubj, &
5840 & imins, imaxs, jmins, jmaxs, &
5841 & nghostpoints, &
5842 & nhsteps(rec,is)/ifac, &
5843 & dtsizeh(rec,is), &
5844 & kh, &
5845 & pm, pn, pmon_u, pnom_v, &
5846# ifdef MASKING
5847 & rmask, umask, vmask, &
5848# endif
5849 & a2d)
5850 DO j=jstr,jend
5851 DO i=istr,iend
5852 a2davg(i,j)=a2davg(i,j)+a2d(i,j)
5853 a2dsqr(i,j)=a2dsqr(i,j)+a2d(i,j)*a2d(i,j)
5854 END DO
5855 END DO
5856 END DO
5857 DO j=jstr,jend
5858 DO i=istr,iend
5859 aavg=facavg*a2davg(i,j)
5860 asqr=facavg*a2dsqr(i,j)
5861# ifdef MASKING
5862 IF (rmask(i,j).gt.0.0_r8) THEN
5863 hnormstf(i,j,itrc)=1.0_r8/sqrt(asqr)
5864 ELSE
5865 hnormstf(i,j,itrc)=0.0_r8
5866 END IF
5867# else
5868 hnormstf(i,j,itrc)=1.0_r8/sqrt(asqr)
5869# endif
5870 END DO
5871 END DO
5872 END IF
5873 END IF
5874 END DO
5875 IF (lsame) THEN
5876 DO itrc=2,nt(ng)
5877 IF (lstflux(itrc,ng)) THEN
5878 DO j=jstr,jend
5879 DO i=istr,iend
5880 hnormstf(i,j,itrc)=hnormstf(i,j,1)
5881 END DO
5882 END DO
5883 END IF
5884 END DO
5885 END IF
5886 DO itrc=1,nt(ng)
5887 IF (lstflux(itrc,ng)) THEN
5888 is=istsur(itrc)
5889 IF (cnorm(rec,is)) THEN
5890 CALL dabc_r2d_tile (ng, tile, &
5891 & lbi, ubi, lbj, ubj, &
5892 & hnormstf(:,:,itrc))
5893# ifdef DISTRIBUTE
5894 CALL mp_exchange2d (ng, tile, itlm, 1, &
5895 & lbi, ubi, lbj, ubj, &
5896 & nghostpoints, &
5897 & ewperiodic(ng), nsperiodic(ng), &
5898 & hnormstf(:,:,itrc))
5899# endif
5900!
5901 SELECT CASE (nrm(ifile,ng)%IOtype)
5902 CASE (io_nf90)
5903 CALL wrt_norm2d_nf90 (ng, tile, itlm, ncname, &
5904 & lbi, ubi, lbj, ubj, &
5905 & idtsur(itrc), &
5906 & nrm(ifile,ng)%ncid, &
5907 & nrm(ifile,ng)%Vid(idtsur(itrc)), &
5908 & nrm(ifile,ng)%Rindex, &
5909# ifdef MASKING
5910 & rmask, &
5911# endif
5912 & hnormstf(:,:,itrc))
5913
5914# if defined PIO_LIB && defined DISTRIBUTE
5915 CASE (io_pio)
5916 IF (nrm(ifile,ng)%pioVar(idtsur(itrc))%dkind.eq. &
5917 & pio_double) THEN
5918 iodesc => iodesc_dp_r2dvar(ng)
5919 ELSE
5920 iodesc => iodesc_sp_r2dvar(ng)
5921 END IF
5922 CALL wrt_norm2d_pio (ng, tile, itlm, ncname, &
5923 & lbi, ubi, lbj, ubj, &
5924 & idtsur(itrc), &
5925 & nrm(ifile,ng)%pioFile, &
5926 & nrm(ifile,ng)%pioVar(idtsur(itrc)), &
5927 & nrm(ifile,ng)%Rindex, &
5928 & iodesc, &
5929# ifdef MASKING
5930 & rmask, &
5931# endif
5932 & hnormstf(:,:,itrc))
5933# endif
5934 END SELECT
5935 IF (founderror(exit_flag, noerror, &
5936 & __line__, myfile)) RETURN
5937 END IF
5938 END IF
5939 END DO
5940# endif
5941 END IF
5942# endif
5943!
5944 IF (master) THEN
5945 WRITE (stdout,30)
5946 END IF
5947
5948 10 FORMAT (/,' Error Covariance Factors: Randomization Method',/)
5949 20 FORMAT (4x,'Computing',1x,a,1x,a)
5950 30 FORMAT (/)
5951!
5952 RETURN
5953 END SUBROUTINE randomization_tile
5954
5955!
5956!***********************************************************************
5957 SUBROUTINE wrt_norm2d_nf90 (ng, tile, model, ncname, &
5958 & LBi, UBi, LBj, UBj, &
5959 & ifield, ncid, ncvarid, tindex, &
5960# ifdef MASKING
5961 & Amask, &
5962# endif
5963 & A)
5964!***********************************************************************
5965!
5966! Imported variable declarations.
5967!
5968 integer, intent(in) :: ng, tile, model
5969 integer, intent(in) :: lbi, ubi, lbj, ubj
5970 integer, intent(in) :: ifield, ncid, ncvarid, tindex
5971
5972 character (len=*), intent(in) :: ncname
5973!
5974# ifdef ASSUMED_SHAPE
5975# ifdef MASKING
5976 real(r8), intent(in) :: amask(lbi:,lbj:)
5977# endif
5978 real(r8), intent(in) :: a(lbi:,lbj:)
5979# else
5980# ifdef MASKING
5981 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
5982# endif
5983 real(r8), intent(in) :: a(lbi:ubi,lbj:ubj)
5984# endif
5985!
5986! Local variable declarations.
5987!
5988 integer :: gfactor, gtype, status
5989!
5990 real(dp) :: scale
5991!
5992 character (len=*), parameter :: myfile = &
5993 & __FILE__//", wrt_norm2d_nf90"
5994
5995# include "set_bounds.h"
5996!
5997!-----------------------------------------------------------------------
5998! Write out requested 2D field into normalization NetCDF file. Since
5999! the computation of normalization coefficients is a very expensive
6000! computation, synchronize file to disk.
6001!-----------------------------------------------------------------------
6002!
6003 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6004!
6005! Set grid type factor to write full (gfactor=1) fields or water
6006! points (gfactor=-1) fields only.
6007!
6008# if defined WRITE_WATER && defined MASKING
6009 gfactor=-1
6010# else
6011 gfactor=1
6012# endif
6013!
6014! Write out 2D normalization field.
6015!
6016 gtype=gfactor*iinfo(1,ifield,ng)
6017 scale=1.0_dp
6018 status=nf_fwrite2d(ng, model, ncid, ifield, &
6019 & ncvarid, tindex, gtype, &
6020 & lbi, ubi, lbj, ubj, scale, &
6021# ifdef MASKING
6022 & amask, &
6023# endif
6024 & a)
6025 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
6026 IF (master) THEN
6027 WRITE (stdout,10) trim(vname(1,ifield)), tindex
6028 END IF
6029 exit_flag=3
6030 ioerror=status
6031 RETURN
6032 END IF
6033!
6034! Synchronize normalization NetCDF file to disk to allow other
6035! processes to access data immediately after it is written.
6036!
6037 CALL netcdf_sync (ng, model, ncname, ncid)
6038 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6039
6040 IF (master) WRITE (stdout,20) trim(vname(1,ifield)), tindex
6041 FLUSH (stdout)
6042!
6043 10 FORMAT (/,' WRT_NORM2D_NF90 - error while writing variable: ',a, &
6044 & /,19x 'into normalization NetCDF file for time record: ', &
6045 & i0)
6046 20 FORMAT (7x,'wrote ',a, t21,'normalization factors into record ', &
6047 & i0)
6048!
6049 RETURN
6050 END SUBROUTINE wrt_norm2d_nf90
6051
6052# if defined PIO_LIB && defined DISTRIBUTE
6053!
6054!***********************************************************************
6055 SUBROUTINE wrt_norm2d_pio (ng, tile, model, ncname, &
6056 & LBi, UBi, LBj, UBj, &
6057 & ifield, pioFile, pioVar, tindex, &
6058 & pioDesc, &
6059# ifdef MASKING
6060 & Amask, &
6061# endif
6062 & A)
6063!***********************************************************************
6064!
6065! Imported variable declarations.
6066!
6067 integer, intent(in) :: ng, tile, model
6068 integer, intent(in) :: lbi, ubi, lbj, ubj
6069 integer, intent(in) :: ifield, tindex
6070
6071 character (len=*), intent(in) :: ncname
6072!
6073# ifdef ASSUMED_SHAPE
6074# ifdef MASKING
6075 real(r8), intent(in) :: amask(lbi:,lbj:)
6076# endif
6077 real(r8), intent(in) :: a(lbi:,lbj:)
6078# else
6079# ifdef MASKING
6080 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
6081# endif
6082 real(r8), intent(in) :: a(lbi:ubi,lbj:ubj)
6083# endif
6084!
6085 TYPE (file_desc_t), intent(inout) :: piofile
6086 TYPE (io_desc_t), intent(inout) :: piodesc
6087 TYPE (my_vardesc), intent(inout) :: piovar
6088!
6089! Local variable declarations.
6090!
6091 integer :: status
6092!
6093 real(dp) :: scale
6094!
6095 character (len=*), parameter :: myfile = &
6096 & __FILE__//", wrt_norm2d_pio"
6097
6098# include "set_bounds.h"
6099!
6100!-----------------------------------------------------------------------
6101! Write out requested 2D field into normalization NetCDF file. Since
6102! the computation of normalization coefficients is a very expensive
6103! computation, synchronize file to disk.
6104!-----------------------------------------------------------------------
6105!
6106 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6107!
6108! Write out 2D normalization field.
6109!
6110 scale=1.0_dp
6111 status=nf_fwrite2d(ng, model, piofile, ifield, &
6112 & piovar, tindex, piodesc, &
6113 & lbi, ubi, lbj, ubj, scale, &
6114# ifdef MASKING
6115 & amask, &
6116# endif
6117 & a)
6118 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
6119 IF (master) THEN
6120 WRITE (stdout,10) trim(vname(1,ifield)), tindex
6121 END IF
6122 exit_flag=3
6123 ioerror=status
6124 RETURN
6125 END IF
6126!
6127! Synchronize normalization NetCDF file to disk to allow other
6128! processes to access data immediately after it is written.
6129!
6130 CALL pio_netcdf_sync (ng, model, ncname, piofile)
6131 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6132
6133 IF (master) WRITE (stdout,20) trim(vname(1,ifield)), tindex
6134 FLUSH (stdout)
6135!
6136 10 FORMAT (/,' WRT_NORM2D_PIO - error while writing variable: ',a, &
6137 & /,18x 'into normalization NetCDF file for time record: ', &
6138 & i0)
6139 20 FORMAT (7x,'wrote ',a, t21,'normalization factors into record ', &
6140 & i0)
6141!
6142 RETURN
6143 END SUBROUTINE wrt_norm2d_pio
6144# endif
6145
6146!
6147!***********************************************************************
6148 SUBROUTINE wrt_norm3d_nf90 (ng, tile, model, ncname, &
6149 & LBi, UBi, LBj, UBj, LBk, UBk, &
6150 & ifield, ncid, ncvarid, tindex, &
6151# ifdef MASKING
6152 & Amask, &
6153# endif
6154 & A)
6155!***********************************************************************
6156!
6157! Imported variable declarations.
6158!
6159 integer, intent(in) :: ng, tile, model
6160 integer, intent(in) :: lbi, ubi, lbj, ubj, lbk, ubk
6161 integer, intent(in) :: ifield, ncid, ncvarid, tindex
6162
6163 character (len=*), intent(in) :: ncname
6164!
6165# ifdef ASSUMED_SHAPE
6166# ifdef MASKING
6167 real(r8), intent(in) :: amask(lbi:,lbj:)
6168# endif
6169 real(r8), intent(in) :: a(lbi:,lbj:,lbk:)
6170# else
6171# ifdef MASKING
6172 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
6173# endif
6174 real(r8), intent(in) :: a(lbi:ubi,lbj:ubj,lbk:ubk)
6175# endif
6176!
6177! Local variable declarations.
6178!
6179 integer :: gfactor, gtype, status
6180!
6181 real(dp) :: scale
6182!
6183 character (len=*), parameter :: myfile = &
6184 & __FILE__//", wrt_norm3d_nf90"
6185
6186# include "set_bounds.h"
6187!
6188!-----------------------------------------------------------------------
6189! Write out requested 3D field into normalization NetCDF file. Since
6190! the computation of normalization coefficients is a very expensive
6191! computation, synchronize file to disk.
6192!-----------------------------------------------------------------------
6193!
6194 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6195!
6196! Set grid type factor to write full (gfactor=1) fields or water
6197! points (gfactor=-1) fields only.
6198!
6199# if defined WRITE_WATER && defined MASKING
6200 gfactor=-1
6201# else
6202 gfactor=1
6203# endif
6204!
6205! Write out 3D normalization field.
6206!
6207 gtype=gfactor*iinfo(1,ifield,ng)
6208 scale=1.0_dp
6209 status=nf_fwrite3d(ng, model, ncid, ifield, &
6210 & ncvarid, tindex, gtype, &
6211 & lbi, ubi, lbj, ubj, lbk, ubk, scale, &
6212# ifdef MASKING
6213 & amask, &
6214# endif
6215 & a)
6216 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
6217 IF (master) THEN
6218 WRITE (stdout,10) trim(vname(1,ifield)), tindex
6219 END IF
6220 exit_flag=3
6221 ioerror=status
6222 RETURN
6223 END IF
6224!
6225! Synchronize normalization NetCDF file to disk to allow other
6226! processes to access data immediately after it is written.
6227!
6228 CALL netcdf_sync (ng, model, ncname, ncid)
6229 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6230
6231 IF (master) WRITE (stdout,20) trim(vname(1,ifield)), tindex
6232 FLUSH (stdout)
6233!
6234 10 FORMAT (/,' WRT_NORM3D_NF90 - error while writing variable: ',a, &
6235 & /,19x,'into normalization NetCDF file for time record: ', &
6236 & i0)
6237 20 FORMAT (7x,'wrote ',a, t21,'normalization factors into record ', &
6238 & i0)
6239!
6240 RETURN
6241 END SUBROUTINE wrt_norm3d_nf90
6242
6243# if defined PIO_LIB && defined DISTRIBUTE
6244!
6245!***********************************************************************
6246 SUBROUTINE wrt_norm3d_pio (ng, tile, model, ncname, &
6247 & LBi, UBi, LBj, UBj, LBk, UBk, &
6248 & ifield, pioFile, pioVar, tindex, &
6249 & pioDesc, &
6250# ifdef MASKING
6251 & Amask, &
6252# endif
6253 & A)
6254!***********************************************************************
6255!
6256! Imported variable declarations.
6257!
6258 integer, intent(in) :: ng, tile, model
6259 integer, intent(in) :: lbi, ubi, lbj, ubj, lbk, ubk
6260 integer, intent(in) :: ifield, tindex
6261
6262 character (len=*), intent(in) :: ncname
6263!
6264# ifdef ASSUMED_SHAPE
6265# ifdef MASKING
6266 real(r8), intent(in) :: amask(lbi:,lbj:)
6267# endif
6268 real(r8), intent(in) :: a(lbi:,lbj:,lbk:)
6269# else
6270# ifdef MASKING
6271 real(r8), intent(in) :: amask(lbi:ubi,lbj:ubj)
6272# endif
6273 real(r8), intent(in) :: a(lbi:ubi,lbj:ubj,lbk:ubk)
6274# endif
6275!
6276 TYPE (file_desc_t), intent(inout) :: piofile
6277 TYPE (io_desc_t), intent(inout) :: piodesc
6278 TYPE (my_vardesc), intent(inout) :: piovar
6279!
6280! Local variable declarations.
6281!
6282 integer :: status
6283!
6284 real(dp) :: scale
6285!
6286 character (len=*), parameter :: myfile = &
6287 & __FILE__//", wrt_norm3d_pio"
6288
6289# include "set_bounds.h"
6290!
6291!-----------------------------------------------------------------------
6292! Write out requested 3D field into normalization NetCDF file. Since
6293! the computation of normalization coefficients is a very expensive
6294! computation, synchronize file to disk.
6295!-----------------------------------------------------------------------
6296!
6297 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6298!
6299! Write out 3D normalization field.
6300!
6301 scale=1.0_dp
6302 status=nf_fwrite3d(ng, model, piofile, ifield, &
6303 & piovar, tindex, piodesc, &
6304 & lbi, ubi, lbj, ubj, lbk, ubk, scale, &
6305# ifdef MASKING
6306 & amask, &
6307# endif
6308 & a)
6309 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
6310 IF (master) THEN
6311 WRITE (stdout,10) trim(vname(1,ifield)), tindex
6312 END IF
6313 exit_flag=3
6314 ioerror=status
6315 RETURN
6316 END IF
6317!
6318! Synchronize normalization NetCDF file to disk to allow other
6319! processes to access data immediately after it is written.
6320!
6321 CALL pio_netcdf_sync (ng, model, ncname, piofile)
6322 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
6323
6324 IF (master) WRITE (stdout,20) trim(vname(1,ifield)), tindex
6325 FLUSH (stdout)
6326!
6327 10 FORMAT (/,' WRT_NORM3D_PIO - error while writing variable: ',a, &
6328 & /,18x,'into normalization NetCDF file for time record: ', &
6329 & i0)
6330 20 FORMAT (7x,'wrote ',a, t21,'normalization factors into record ', &
6331 & i0)
6332!
6333 RETURN
6334 END SUBROUTINE wrt_norm3d_pio
6335# endif
6336#endif
6337 END MODULE normalization_mod
distribute_mod::mp_collect
Definition distribute.F:108
distribute_mod::mp_reduce
Definition distribute.F:113
mod_netcdf::netcdf_put_fvar
Definition mod_netcdf.F:82
mod_pio_netcdf::pio_netcdf_put_fvar
Definition mod_pio_netcdf.F:94
nf_fwrite2d_mod::nf_fwrite2d
Definition nf_fwrite2d.F:77
nf_fwrite3d_mod::nf_fwrite3d
Definition nf_fwrite3d.F:78
ad_conv_2d_mod
Definition ad_conv_2d.F:3
ad_conv_2d_mod::ad_conv_u2d_tile
subroutine ad_conv_u2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_r, pnom_p, umask, pmask, ad_a)
Definition ad_conv_2d.F:323
ad_conv_2d_mod::ad_conv_r2d_tile
subroutine ad_conv_r2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_u, pnom_v, rmask, umask, vmask, ad_a)
Definition ad_conv_2d.F:70
ad_conv_2d_mod::ad_conv_v2d_tile
subroutine ad_conv_v2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_p, pnom_r, vmask, pmask, ad_a)
Definition ad_conv_2d.F:573
ad_conv_3d_mod
Definition ad_conv_3d.F:3
ad_conv_3d_mod::ad_conv_v3d_tile
subroutine ad_conv_v3d_tile(ng, tile, model, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, on_p, om_r, pmask, rmask, umask, vmask, hz, z_r, ad_a)
Definition ad_conv_3d.F:2014
ad_conv_3d_mod::ad_conv_u3d_tile
subroutine ad_conv_u3d_tile(ng, tile, model, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, on_r, om_p, pmask, rmask, umask, vmask, hz, z_r, ad_a)
Definition ad_conv_3d.F:1027
ad_conv_3d_mod::ad_conv_r3d_tile
subroutine ad_conv_r3d_tile(ng, tile, model, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, on_u, om_v, rmask, umask, vmask, hz, z_r, ad_a)
Definition ad_conv_3d.F:85
ad_conv_bry2d_mod
Definition ad_conv_bry2d.F:2
ad_conv_bry2d_mod::ad_conv_v2d_bry_tile
subroutine ad_conv_v2d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_p, pnom_r, vmask, pmask, ad_a)
Definition ad_conv_bry2d.F:691
ad_conv_bry2d_mod::ad_conv_u2d_bry_tile
subroutine ad_conv_u2d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_r, pnom_p, umask, pmask, ad_a)
Definition ad_conv_bry2d.F:384
ad_conv_bry2d_mod::ad_conv_r2d_bry_tile
subroutine ad_conv_r2d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_u, pnom_v, rmask, umask, vmask, ad_a)
Definition ad_conv_bry2d.F:74
ad_conv_bry3d_mod
Definition ad_conv_bry3d.F:2
ad_conv_bry3d_mod::ad_conv_r3d_bry_tile
subroutine ad_conv_r3d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, pmon_u, pnom_v, rmask, umask, vmask, hz, z_r, ad_a)
Definition ad_conv_bry3d.F:82
ad_conv_bry3d_mod::ad_conv_u3d_bry_tile
subroutine ad_conv_u3d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, pmon_r, pnom_p, umask, pmask, hz, z_r, ad_a)
Definition ad_conv_bry3d.F:1001
ad_conv_bry3d_mod::ad_conv_v3d_bry_tile
subroutine ad_conv_v3d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, pmon_p, pnom_r, vmask, pmask, hz, z_r, ad_a)
Definition ad_conv_bry3d.F:1928
bc_2d_mod
Definition bc_2d.F:2
bc_2d_mod::dabc_v2d_tile
subroutine dabc_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition bc_2d.F:771
bc_2d_mod::dabc_u2d_tile
subroutine dabc_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition bc_2d.F:646
bc_2d_mod::dabc_r2d_tile
subroutine dabc_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition bc_2d.F:523
bc_3d_mod
Definition bc_3d.F:2
bc_3d_mod::dabc_u3d_tile
subroutine dabc_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition bc_3d.F:869
bc_3d_mod::dabc_r3d_tile
subroutine dabc_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition bc_3d.F:730
bc_3d_mod::dabc_v3d_tile
subroutine dabc_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition bc_3d.F:1010
bc_bry2d_mod
Definition bc_bry2d.F:2
bc_bry2d_mod::bc_r2d_bry_tile
subroutine bc_r2d_bry_tile(ng, tile, boundary, lbij, ubij, a)
Definition bc_bry2d.F:30
bc_bry2d_mod::bc_u2d_bry_tile
subroutine bc_u2d_bry_tile(ng, tile, boundary, lbij, ubij, a)
Definition bc_bry2d.F:100
bc_bry2d_mod::bc_v2d_bry_tile
subroutine bc_v2d_bry_tile(ng, tile, boundary, lbij, ubij, a)
Definition bc_bry2d.F:170
bc_bry3d_mod
Definition bc_bry3d.F:2
bc_bry3d_mod::bc_u3d_bry_tile
subroutine bc_u3d_bry_tile(ng, tile, boundary, lbij, ubij, lbk, ubk, a)
Definition bc_bry3d.F:120
bc_bry3d_mod::bc_r3d_bry_tile
subroutine bc_r3d_bry_tile(ng, tile, boundary, lbij, ubij, lbk, ubk, a)
Definition bc_bry3d.F:30
bc_bry3d_mod::bc_v3d_bry_tile
subroutine bc_v3d_bry_tile(ng, tile, boundary, lbij, ubij, lbk, ubk, a)
Definition bc_bry3d.F:210
distribute_mod
Definition distribute.F:3
mod_boundary
Definition mod_boundary.F:2
mod_boundary::boundary
type(t_boundary), dimension(:), allocatable boundary
Definition mod_boundary.F:746
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_fourdvar
Definition mod_fourdvar.F:2
mod_fourdvar::nhsteps
integer, dimension(:,:), allocatable nhsteps
Definition mod_fourdvar.F:609
mod_fourdvar::nmethod
integer, dimension(:), allocatable nmethod
Definition mod_fourdvar.F:433
mod_fourdvar::nvsteps
integer, dimension(:,:), allocatable nvsteps
Definition mod_fourdvar.F:610
mod_fourdvar::dtsizehb
real(r8), dimension(:,:), allocatable dtsizehb
Definition mod_fourdvar.F:628
mod_fourdvar::nrandom
integer nrandom
Definition mod_fourdvar.F:447
mod_fourdvar::dtsizeh
real(r8), dimension(:,:), allocatable dtsizeh
Definition mod_fourdvar.F:622
mod_fourdvar::nvstepsb
integer, dimension(:,:), allocatable nvstepsb
Definition mod_fourdvar.F:616
mod_fourdvar::dtsizevb
real(r8), dimension(:,:), allocatable dtsizevb
Definition mod_fourdvar.F:629
mod_fourdvar::dtsizev
real(r8), dimension(:,:), allocatable dtsizev
Definition mod_fourdvar.F:623
mod_fourdvar::rscheme
integer, dimension(:), allocatable rscheme
Definition mod_fourdvar.F:440
mod_fourdvar::nhstepsb
integer, dimension(:,:), allocatable nhstepsb
Definition mod_fourdvar.F:615
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_iounits
Definition mod_iounits.F:2
mod_iounits::ioerror
integer ioerror
Definition mod_iounits.F:313
mod_iounits::nrm
type(t_io), dimension(:,:), allocatable nrm
Definition mod_iounits.F:230
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_iounits::sourcefile
character(len=256) sourcefile
Definition mod_iounits.F:317
mod_kinds
Definition mod_kinds.F:2
mod_kinds::r8
integer, parameter r8
Definition mod_kinds.F:28
mod_kinds::dp
integer, parameter dp
Definition mod_kinds.F:25
mod_mixing
Definition mod_mixing.F:2
mod_mixing::mixing
type(t_mixing), dimension(:), allocatable mixing
Definition mod_mixing.F:399
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::io_nf90
integer, parameter io_nf90
Definition mod_ncparam.F:95
mod_ncparam::idubar
integer idubar
Definition mod_ncparam.F:325
mod_ncparam::idvvel
integer idvvel
Definition mod_ncparam.F:381
mod_ncparam::idvsms
integer idvsms
Definition mod_ncparam.F:377
mod_ncparam::isvvel
integer isvvel
Definition mod_ncparam.F:507
mod_ncparam::idsbry
integer, dimension(:), allocatable idsbry
Definition mod_ncparam.F:523
mod_ncparam::io_pio
integer, parameter io_pio
Definition mod_ncparam.F:96
mod_ncparam::isvbar
integer isvbar
Definition mod_ncparam.F:505
mod_ncparam::isvstr
integer isvstr
Definition mod_ncparam.F:511
mod_ncparam::idtsur
integer, dimension(:), allocatable idtsur
Definition mod_ncparam.F:453
mod_ncparam::idfsur
integer idfsur
Definition mod_ncparam.F:206
mod_ncparam::idtvar
integer, dimension(:), allocatable idtvar
Definition mod_ncparam.F:568
mod_ncparam::istvar
integer, dimension(:), allocatable istvar
Definition mod_ncparam.F:520
mod_ncparam::isuvel
integer isuvel
Definition mod_ncparam.F:506
mod_ncparam::isfsur
integer isfsur
Definition mod_ncparam.F:503
mod_ncparam::iduvel
integer iduvel
Definition mod_ncparam.F:343
mod_ncparam::isustr
integer isustr
Definition mod_ncparam.F:510
mod_ncparam::vname
character(len=maxlen), dimension(6, 0:nv) vname
Definition mod_ncparam.F:591
mod_ncparam::idtime
integer idtime
Definition mod_ncparam.F:307
mod_ncparam::isubar
integer isubar
Definition mod_ncparam.F:504
mod_ncparam::iinfo
integer, dimension(:,:,:), allocatable iinfo
Definition mod_ncparam.F:578
mod_ncparam::idusms
integer idusms
Definition mod_ncparam.F:339
mod_ncparam::istsur
integer, dimension(:), allocatable istsur
Definition mod_ncparam.F:519
mod_ncparam::idvbar
integer idvbar
Definition mod_ncparam.F:360
mod_netcdf
Definition mod_netcdf.F:2
mod_netcdf::netcdf_sync
subroutine, public netcdf_sync(ng, model, ncname, ncid)
Definition mod_netcdf.F:9505
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_parallel
Definition mod_parallel.F:2
mod_parallel::master
logical master
Definition mod_parallel.F:40
mod_parallel::tile_count
integer tile_count
Definition mod_parallel.F:89
mod_param
Definition mod_param.F:2
mod_param::inlm
integer, parameter inlm
Definition mod_param.F:662
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::bounds
type(t_bounds), dimension(:), allocatable bounds
Definition mod_param.F:232
mod_param::ntilex
integer, dimension(:), allocatable ntilex
Definition mod_param.F:685
mod_param::r3dvar
integer, parameter r3dvar
Definition mod_param.F:721
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::iadm
integer, parameter iadm
Definition mod_param.F:665
mod_param::u3dvar
integer, parameter u3dvar
Definition mod_param.F:722
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_param::lm
integer, dimension(:), allocatable lm
Definition mod_param.F:455
mod_param::u2dvar
integer, parameter u2dvar
Definition mod_param.F:718
mod_param::ntilee
integer, dimension(:), allocatable ntilee
Definition mod_param.F:686
mod_param::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_param::mm
integer, dimension(:), allocatable mm
Definition mod_param.F:456
mod_param::nsa
integer nsa
Definition mod_param.F:612
mod_param::r2dvar
integer, parameter r2dvar
Definition mod_param.F:717
mod_param::v2dvar
integer, parameter v2dvar
Definition mod_param.F:719
mod_param::v3dvar
integer, parameter v3dvar
Definition mod_param.F:723
mod_pio_netcdf
Definition mod_pio_netcdf.F:2
mod_pio_netcdf::iodesc_dp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r3dvar
Definition mod_pio_netcdf.F:248
mod_pio_netcdf::iodesc_sp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u3dvar
Definition mod_pio_netcdf.F:210
mod_pio_netcdf::pio_netcdf_sync
subroutine, public pio_netcdf_sync(ng, model, ncname, piofile)
Definition mod_pio_netcdf.F:9275
mod_pio_netcdf::iodesc_sp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dvar
Definition mod_pio_netcdf.F:195
mod_pio_netcdf::iodesc_dp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u3dvar
Definition mod_pio_netcdf.F:249
mod_pio_netcdf::iodesc_sp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dvar
Definition mod_pio_netcdf.F:194
mod_pio_netcdf::iodesc_dp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dvar
Definition mod_pio_netcdf.F:234
mod_pio_netcdf::iodesc_dp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v3dvar
Definition mod_pio_netcdf.F:250
mod_pio_netcdf::iodesc_dp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dvar
Definition mod_pio_netcdf.F:235
mod_pio_netcdf::iodesc_sp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v3dvar
Definition mod_pio_netcdf.F:211
mod_pio_netcdf::iodesc_sp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r3dvar
Definition mod_pio_netcdf.F:209
mod_pio_netcdf::iodesc_dp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dvar
Definition mod_pio_netcdf.F:233
mod_pio_netcdf::iodesc_sp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dvar
Definition mod_pio_netcdf.F:196
mod_scalars
Definition mod_scalars.F:2
mod_scalars::lwrtnrm
logical, dimension(:,:), allocatable lwrtnrm
Definition mod_scalars.F:1008
mod_scalars::day2sec
real(dp), parameter day2sec
Definition mod_scalars.F:816
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::lstflux
logical, dimension(:,:), allocatable lstflux
Definition mod_scalars.F:1156
mod_scalars::tdays
real(dp), dimension(:), allocatable tdays
Definition mod_scalars.F:261
mod_scalars::vdecay
real(r8), dimension(:,:,:), allocatable vdecay
Definition mod_scalars.F:1329
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::cnorm
logical, dimension(:,:), allocatable cnorm
Definition mod_scalars.F:1260
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::cnormb
logical, dimension(:,:), allocatable cnormb
Definition mod_scalars.F:1265
mod_scalars::noerror
integer noerror
Definition mod_scalars.F:561
mod_scalars::hdecay
real(r8), dimension(:,:,:), allocatable hdecay
Definition mod_scalars.F:1319
mod_sedbed
Definition sedbed_mod.h:1
mod_sedbed::sedbed
type(t_sedbed), dimension(:), allocatable sedbed
Definition sedbed_mod.h:157
mod_stepping
Definition mod_stepping.F:2
mod_stepping::nnew
integer, dimension(:), allocatable nnew
Definition mod_stepping.F:69
mod_stepping::nstp
integer, dimension(:), allocatable nstp
Definition mod_stepping.F:71
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::mp_exchange2d
subroutine mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:294
mp_exchange_mod::mp_exchange3d
subroutine mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:2037
nf_fwrite2d_mod
Definition nf_fwrite2d.F:2
nf_fwrite3d_mod
Definition nf_fwrite3d.F:2
normalization_mod
Definition normalization.F:2
normalization_mod::wrt_norm3d_pio
subroutine, private wrt_norm3d_pio(ng, tile, model, ncname, lbi, ubi, lbj, ubj, lbk, ubk, ifield, piofile, piovar, tindex, piodesc, amask, a)
Definition normalization.F:6254
normalization_mod::normalization
subroutine, public normalization(ng, tile, ifac)
Definition normalization.F:139
normalization_mod::normalization_tile
subroutine, private normalization_tile(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, nstp, nnew, ifac, pm, om_p, om_r, om_u, om_v, pn, on_p, on_r, on_u, on_v, pmon_p, pmon_r, pmon_u, pnom_p, pnom_r, pnom_v, pmask, rmask, umask, vmask, h, zice, bed_thick, hz, z_r, z_w, kh, kv, vnormrobc, vnormuobc, vnormvobc, hnormrobc, hnormuobc, hnormvobc, hnormsus, hnormsvs, hnormstf, vnormr, vnormu, vnormv, hnormr, hnormu, hnormv)
Definition normalization.F:340
normalization_mod::wrt_norm2d_pio
subroutine, private wrt_norm2d_pio(ng, tile, model, ncname, lbi, ubi, lbj, ubj, ifield, piofile, piovar, tindex, piodesc, amask, a)
Definition normalization.F:6063
normalization_mod::wrt_norm3d_nf90
subroutine, private wrt_norm3d_nf90(ng, tile, model, ncname, lbi, ubi, lbj, ubj, lbk, ubk, ifield, ncid, ncvarid, tindex, amask, a)
Definition normalization.F:6155
normalization_mod::wrt_norm2d_nf90
subroutine, private wrt_norm2d_nf90(ng, tile, model, ncname, lbi, ubi, lbj, ubj, ifield, ncid, ncvarid, tindex, amask, a)
Definition normalization.F:5964
normalization_mod::randomization_tile
subroutine, private randomization_tile(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, nstp, nnew, ifac, pm, om_p, om_r, om_u, om_v, pn, on_p, on_r, on_u, on_v, pmon_p, pmon_r, pmon_u, pnom_p, pnom_r, pnom_v, pmask, rmask, umask, vmask, h, zice, bed_thick, hz, z_r, z_w, kh, kv, vnormrobc, vnormuobc, vnormvobc, hnormrobc, hnormuobc, hnormvobc, hnormsus, hnormsvs, hnormstf, vnormr, vnormu, vnormv, hnormr, hnormu, hnormv)
Definition normalization.F:3414
set_depth_mod
Definition set_depth.F:2
set_depth_mod::set_depth_tile
subroutine, public set_depth_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nstp, nnew, h, zice, zt_avg1, hz, z_r, z_w)
Definition set_depth.F:86
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
tl_conv_2d_mod
Definition tl_conv_2d.F:3
tl_conv_2d_mod::tl_conv_u2d_tile
subroutine tl_conv_u2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_r, pnom_p, umask, pmask, tl_a)
Definition tl_conv_2d.F:301
tl_conv_2d_mod::tl_conv_r2d_tile
subroutine tl_conv_r2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_u, pnom_v, rmask, umask, vmask, tl_a)
Definition tl_conv_2d.F:70
tl_conv_2d_mod::tl_conv_v2d_tile
subroutine tl_conv_v2d_tile(ng, tile, model, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_p, pnom_r, vmask, pmask, tl_a)
Definition tl_conv_2d.F:530
tl_conv_3d_mod
Definition tl_conv_3d.F:3
tl_conv_3d_mod::tl_conv_u3d_tile
subroutine tl_conv_u3d_tile(ng, tile, model, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, on_r, om_p, pmask, rmask, umask, vmask, hz, z_r, tl_a)
Definition tl_conv_3d.F:847
tl_conv_3d_mod::tl_conv_v3d_tile
subroutine tl_conv_v3d_tile(ng, tile, model, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, on_p, om_r, pmask, rmask, umask, vmask, hz, z_r, tl_a)
Definition tl_conv_3d.F:1662
tl_conv_3d_mod::tl_conv_r3d_tile
subroutine tl_conv_r3d_tile(ng, tile, model, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, on_u, om_v, rmask, umask, vmask, hz, z_r, tl_a)
Definition tl_conv_3d.F:85
tl_conv_bry2d_mod
Definition tl_conv_bry2d.F:2
tl_conv_bry2d_mod::tl_conv_v2d_bry_tile
subroutine tl_conv_v2d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_p, pnom_r, vmask, pmask, tl_a)
Definition tl_conv_bry2d.F:639
tl_conv_bry2d_mod::tl_conv_u2d_bry_tile
subroutine tl_conv_u2d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_r, pnom_p, umask, pmask, tl_a)
Definition tl_conv_bry2d.F:358
tl_conv_bry2d_mod::tl_conv_r2d_bry_tile
subroutine tl_conv_r2d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, nghost, nhsteps, dtsizeh, kh, pm, pn, pmon_u, pnom_v, rmask, umask, vmask, tl_a)
Definition tl_conv_bry2d.F:74
tl_conv_bry3d_mod
Definition tl_conv_bry3d.F:2
tl_conv_bry3d_mod::tl_conv_v3d_bry_tile
subroutine tl_conv_v3d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, pmon_p, pnom_r, vmask, pmask, hz, z_r, tl_a)
Definition tl_conv_bry3d.F:1654
tl_conv_bry3d_mod::tl_conv_u3d_bry_tile
subroutine tl_conv_u3d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, pmon_r, pnom_p, umask, pmask, hz, z_r, tl_a)
Definition tl_conv_bry3d.F:866
tl_conv_bry3d_mod::tl_conv_r3d_bry_tile
subroutine tl_conv_r3d_bry_tile(ng, tile, model, boundary, edge, lbij, ubij, lbi, ubi, lbj, ubj, lbk, ubk, imins, imaxs, jmins, jmaxs, nghost, nhsteps, nvsteps, dtsizeh, dtsizev, kh, kv, pm, pn, pmon_u, pnom_v, rmask, umask, vmask, hz, z_r, tl_a)
Definition tl_conv_bry3d.F:82
white_noise_mod
Definition white_noise.F:2
white_noise_mod::white_noise3d
subroutine, public white_noise3d(ng, model, gtype, rscheme, imin, imax, jmin, jmax, lbi, ubi, lbj, ubj, lbk, ubk, rmin, rmax, r)
Definition white_noise.F:356
white_noise_mod::white_noise3d_bry
subroutine, public white_noise3d_bry(ng, tile, model, boundary, rscheme, imin, imax, lbij, ubij, lbk, ubk, rmin, rmax, r)
Definition white_noise.F:480
white_noise_mod::white_noise2d_bry
subroutine, public white_noise2d_bry(ng, tile, model, boundary, rscheme, imin, imax, lbij, ubij, rmin, rmax, r)
Definition white_noise.F:252
white_noise_mod::white_noise2d
subroutine, public white_noise2d(ng, model, gtype, rscheme, imin, imax, jmin, jmax, lbi, ubi, lbj, ubj, rmin, rmax, r)
Definition white_noise.F:138
mod_iounits::my_vardesc
Definition mod_iounits.F:151