ROMS
Loading...
Searching...
No Matches
wrt_extract.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE wrt_extract_mod
3
4#ifdef GRID_EXTRACT
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 module writes requested model fields into the EXTRACT output !
14! file using either the standard NetCDF library or the Parallel-IO !
15! (PIO) library. !
16! !
17! If ExtractFlag > 1: Decimation !
18! !
19! It decimates the field solution at the prescribed integer factor, !
20! ExtractFlag . For example, if ExtractFlag=2 (recommended), the !
21! output fieldsare written at every other point, resulting in coarser !
22! data resolution. This strategy is advantageous in mixed resolution, !
23! split 4D-Var applications where the outer loop background (prior) !
24! trajectory may be computed at a higher resolution than in the inner !
25! loop minimization to accelerate the calculations. For decimation to !
26! work, the number of parent grid RHO-points (0: Lm+1, 0:Mm+1) must !
27! be multiples of dec_fator. That is, !
28! !
29! MOD(Lm+1, ExtractFlag) = 0 !
30! MOD(Mm+1, ExtractFlag) = 0 !
31! !
32! If ExtractFlag = 1: Interpolation !
33! !
34!=======================================================================
35!
36 USE mod_param
37 USE mod_parallel
38# ifdef BBL_MODEL
39 USE mod_bbl
40# endif
41# ifdef ADJUST_BOUNDARY
42 USE mod_boundary
43# endif
44# ifdef SOLVE3D
45 USE mod_coupling
46# endif
47 USE mod_forces
48 USE mod_grid
49 USE mod_extract
50 USE mod_iounits
51 USE mod_mixing
52 USE mod_ncparam
53 USE mod_ocean
54 USE mod_scalars
55# if defined SEDIMENT || defined BBL_MODEL
56 USE mod_sedbed
57 USE mod_sediment
58# endif
59 USE mod_stepping
60!
61# if (defined BBL_MODEL || defined WAVES_OUTPUT) && defined SOLVE3D
62 USE bbl_output_mod, ONLY : bbl_wrt_nf90
63# if defined PIO_LIB && defined DISTRIBUTE
64 USE bbl_output_mod, ONLY : bbl_wrt_pio
65# endif
66# endif
67 USE extract_field_mod, ONLY : extract_field
68# if defined ICE_MODEL && defined SOLVE3D
69 USE ice_output_mod, ONLY : ice_wrt_nf90
70# if defined PIO_LIB && defined DISTRIBUTE
71 USE ice_output_mod, ONLY : ice_wrt_pio
72# endif
73# endif
74 USE nf_fwrite2d_mod, ONLY : nf_fwrite2d
75# ifdef ADJUST_BOUNDARY
76 USE nf_fwrite2d_bry_mod, ONLY : nf_fwrite2d_bry
77# endif
78# ifdef SOLVE3D
79 USE nf_fwrite3d_mod, ONLY : nf_fwrite3d
80# ifdef ADJUST_BOUNDARY
81 USE nf_fwrite3d_bry_mod, ONLY : nf_fwrite3d_bry
82# endif
83 USE omega_mod, ONLY : scale_omega
84# endif
85# if defined SEDIMENT && defined SOLVE3D
86 USE sediment_output_mod, ONLY : sediment_wrt_nf90
87# if defined PIO_LIB && defined DISTRIBUTE
88 USE sediment_output_mod, ONLY : sediment_wrt_pio
89# endif
90# endif
91 USE strings_mod, ONLY : founderror
92 USE uv_rotate_mod, ONLY : uv_rotate2d
93# ifdef SOLVE3D
94 USE uv_rotate_mod, ONLY : uv_rotate3d
95# endif
96# if defined WEC_VF && defined SOLVE3D
97 USE wec_output_mod, ONLY : wec_wrt_nf90
98# if defined PIO_LIB && defined DISTRIBUTE
99 USE wec_output_mod, ONLY : wec_wrt_pio
100# endif
101# endif
102!
103 implicit none
104!
105 PUBLIC :: wrt_extract
106 PRIVATE :: wrt_extract_nf90
107# if defined PIO_LIB && defined DISTRIBUTE
108 PRIVATE :: wrt_extract_pio
109# endif
110!
111 CONTAINS
112!
113!***********************************************************************
114 SUBROUTINE wrt_extract (ng, tile)
115!***********************************************************************
116!
117! Imported variable declarations.
118!
119 integer, intent(in) :: ng, tile
120!
121! Local variable declarations.
122!
123# ifdef ADJUST_BOUNDARY
124 integer :: LBij, UBij
125# endif
126 integer :: LBi, UBi, LBj, UBj
127 integer :: iLB, iUB, jLB, jUB
128!
129 character (len=*), parameter :: MyFile = &
130 & __FILE__
131!
132!-----------------------------------------------------------------------
133! Write out decimate fields according to IO type.
134!-----------------------------------------------------------------------
135!
136# ifdef ADJUST_BOUNDARY
137 lbij=bounds(ng)%LBij ! parent boundary bounds
138 ubij=bounds(ng)%UBij
139# endif
140 lbi=bounds(ng)%LBi(tile) ! parent array bounds
141 ubi=bounds(ng)%UBi(tile)
142 lbj=bounds(ng)%LBj(tile)
143 ubj=bounds(ng)%UBj(tile)
144!
145 ilb=xtr_bounds(ng)%LBi(tile) ! extract array bounds
146 iub=xtr_bounds(ng)%UBi(tile)
147 jlb=xtr_bounds(ng)%LBj(tile)
148 jub=xtr_bounds(ng)%UBj(tile)
149!
150 SELECT CASE (xtr(ng)%IOtype)
151 CASE (io_nf90)
152 CALL wrt_extract_nf90 (ng, inlm, tile, &
153# ifdef ADJUST_BOUNDARY
154 & lbij, ubij, &
155# endif
156 & lbi, ubi, lbj, ubj, &
157 & ilb, iub, jlb, jub)
158
159# if defined PIO_LIB && defined DISTRIBUTE
160 CASE (io_pio)
161 CALL wrt_extract_pio (ng, inlm, tile, &
162# ifdef ADJUST_BOUNDARY
163 & lbij, ubij, &
164# endif
165 & lbi, ubi, lbj, ubj, &
166 & ilb, iub, jlb, jub)
167# endif
168 CASE DEFAULT
169 IF (master) WRITE (stdout,10) xtr(ng)%IOtype
170 exit_flag=3
171 END SELECT
172 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
173!
174 10 FORMAT (' WRT_EXTRACT - Illegal output file type, io_type = ',i0, &
175 & /,15x,'Check KeyWord ''OUT_LIB'' in ''roms.in''.')
176!
177 RETURN
178 END SUBROUTINE wrt_extract
179!
180!***********************************************************************
181 SUBROUTINE wrt_extract_nf90 (ng, model, tile, &
182# ifdef ADJUST_BOUNDARY
183 & LBij, UBij, &
184# endif
185 & LBi, UBi, LBj, UBj, &
186 & iLB, iUB, jLB, jUB)
187!***********************************************************************
188!
189 USE mod_netcdf
190!
191! Imported variable declarations.
192!
193 integer, intent(in) :: ng, model, tile
194# ifdef ADJUST_BOUNDARY
195 integer, intent(in) :: LBij, UBij
196# endif
197 integer, intent(in) :: LBi, UBi, LBj, UBj
198 integer, intent(in) :: iLB, iUB, jLB, jUB
199!
200! Local variable declarations.
201!
202 integer :: Fcount, gfactor, gtype, ifield, status
203# ifdef SOLVE3D
204 integer :: i, itrc, j, k
205# endif
206!
207 real(dp) :: scale
208!
209 real(r8), allocatable :: Ur2d(:,:)
210 real(r8), allocatable :: Vr2d(:,:)
211# ifdef SOLVE3D
212 real(r8), allocatable :: Ur3d(:,:,:)
213 real(r8), allocatable :: Vr3d(:,:,:)
214 real(r8), allocatable :: Wr3d(:,:,:)
215# endif
216!
217 character (len=*), parameter :: MyFile = &
218 & __FILE__//", wrt_extract_nf90"
219
220# include "set_bounds.h"
221!
222 sourcefile=myfile
223!
224!-----------------------------------------------------------------------
225! Write out decimate fields.
226!-----------------------------------------------------------------------
227!
228 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
229!
230! Set grid type factor to write full (gfactor=1) fields or water
231! points (gfactor=-1) fields only.
232!
233# if defined WRITE_WATER && defined MASKING
234 gfactor=-1
235# else
236 gfactor=1
237# endif
238!
239! Set time record index.
240!
241 xtr(ng)%Rindex=xtr(ng)%Rindex+1
242 fcount=xtr(ng)%load
243 xtr(ng)%Nrec(fcount)=xtr(ng)%Nrec(fcount)+1
244!
245! Report.
246!
247# ifdef SOLVE3D
248# ifdef NESTING
249 IF (master) WRITE (stdout,10) kout, nout, xtr(ng)%Rindex, ng
250# else
251 IF (master) WRITE (stdout,10) kout, nout, xtr(ng)%Rindex
252# endif
253# else
254# ifdef NESTING
255 IF (master) WRITE (stdout,10) kout, xtr(ng)%Rindex, ng
256# else
257 IF (master) WRITE (stdout,10) kout, xtr(ng)%Rindex
258# endif
259# endif
260!
261! Write out model time (s).
262!
263 CALL netcdf_put_fvar (ng, model, xtr(ng)%name, &
264 & trim(vname(1,idtime)), time(ng:), &
265 & (/xtr(ng)%Rindex/), (/1/), &
266 & ncid = xtr(ng)%ncid, &
267 & varid = xtr(ng)%Vid(idtime))
268 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
269
270# ifdef WET_DRY
271!
272! Write out wet/dry mask at PSI-points.
273!
274 scale=1.0_dp
275 gtype=gfactor*p2dvar
276 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idpwet, &
277 & xtr(ng)%Vid(idpwet), &
278 & xtr(ng)%Rindex, gtype, &
279 & lbi, ubi, lbj, ubj, scale, &
280# ifdef MASKING
281 & extract(ng) % pmask, &
282# endif
283 & extract(ng) % pmask_wet, &
284 & setfillval = .false.)
285 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
286 IF (master) THEN
287 WRITE (stdout,20) trim(vname(1,idpwet)), xtr(ng)%Rindex
288 END IF
289 exit_flag=3
290 ioerror=status
291 RETURN
292 END IF
293!
294! Write out wet/dry mask at RHO-points.
295!
296 scale=1.0_dp
297 gtype=gfactor*r2dvar
298 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idrwet, &
299 & xtr(ng)%Vid(idrwet), &
300 & xtr(ng)%Rindex, gtype, &
301 & lbi, ubi, lbj, ubj, scale, &
302# ifdef MASKING
303 & extract(ng) % rmask, &
304# endif
305 & extract(ng) % rmask_wet, &
306 & setfillval = .false.)
307 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
308 IF (master) THEN
309 WRITE (stdout,20) trim(vname(1,idrwet)), xtr(ng)%Rindex
310 END IF
311 exit_flag=3
312 ioerror=status
313 RETURN
314 END IF
315!
316! Write out wet/dry mask at U-points.
317!
318 scale=1.0_dp
319 gtype=gfactor*u2dvar
320 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, iduwet, &
321 & xtr(ng)%Vid(iduwet), &
322 & xtr(ng)%Rindex, gtype, &
323 & lbi, ubi, lbj, ubj, scale, &
324# ifdef MASKING
325 & extract(ng) % umask, &
326# endif
327 & extract(ng) % umask_wet, &
328 & setfillval = .false.)
329 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
330 IF (master) THEN
331 WRITE (stdout,20) trim(vname(1,iduwet)), xtr(ng)%Rindex
332 END IF
333 exit_flag=3
334 ioerror=status
335 RETURN
336 END IF
337!
338! Write out wet/dry mask at V-points.
339!
340 scale=1.0_dp
341 gtype=gfactor*v2dvar
342 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvwet, &
343 & xtr(ng)%Vid(idvwet), &
344 & xtr(ng)%Rindex, gtype, &
345 & lbi, ubi, lbj, ubj, scale, &
346# ifdef MASKING
347 & extract(ng) % vmask, &
348# endif
349 & extract(ng) % vmask_wet, &
350 & setfillval = .false.)
351 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
352 IF (master) THEN
353 WRITE (stdout,20) trim(vname(1,idvwet)), xtr(ng)%Rindex
354 END IF
355 exit_flag=3
356 ioerror=status
357 RETURN
358 END IF
359# endif
360# ifdef SOLVE3D
361!
362! Write time-varying depths of RHO-points.
363!
364 IF (hout(idpthr,ng)) THEN
365 scale=1.0_dp
366 gtype=gfactor*r3dvar
367 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idpthr, &
368 & xtr(ng)%Vid(idpthr), &
369 & xtr(ng)%Rindex, gtype, &
370 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
371# ifdef MASKING
372 & extract(ng) % rmask, &
373# endif
374 & extract(ng) % z_r, &
375 & setfillval = .false.)
376 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
377 IF (master) THEN
378 WRITE (stdout,20) trim(vname(1,idpthr)), xtr(ng)%Rindex
379 END IF
380 exit_flag=3
381 ioerror=status
382 RETURN
383 END IF
384 END IF
385!
386! Write time-varying depths of U-points.
387!
388 IF (hout(idpthu,ng)) THEN
389 scale=1.0_dp
390 gtype=gfactor*u3dvar
391 DO k=1,n(ng)
392 DO j=jstr-1,jend+1
393 DO i=istru-1,iend+1
394 extract(ng)%z_v(i,j,k)=0.5_r8* &
395 & (extract(ng)%z_r(i-1,j,k)+ &
396 & extract(ng)%z_r(i ,j,k))
397 END DO
398 END DO
399 END DO
400 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idpthu, &
401 & xtr(ng)%Vid(idpthu), &
402 & xtr(ng)%Rindex, gtype, &
403 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
404# ifdef MASKING
405 & extract(ng) % umask, &
406# endif
407 & extract(ng) % z_v, &
408 & setfillval = .false.)
409 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
410 IF (master) THEN
411 WRITE (stdout,20) trim(vname(1,idpthu)), xtr(ng)%Rindex
412 END IF
413 exit_flag=3
414 ioerror=status
415 RETURN
416 END IF
417 END IF
418!
419! Write time-varying depths of V-points.
420!
421 IF (hout(idpthv,ng)) THEN
422 scale=1.0_dp
423 gtype=gfactor*v3dvar
424 DO k=1,n(ng)
425 DO j=jstrv-1,jend+1
426 DO i=istr-1,iend+1
427 extract(ng)%z_v(i,j,k)=0.5_r8*(extract(ng)%z_r(i,j-1,k)+ &
428 & extract(ng)%z_r(i,j ,k))
429 END DO
430 END DO
431 END DO
432 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idpthv, &
433 & xtr(ng)%Vid(idpthv), &
434 & xtr(ng)%Rindex, gtype, &
435 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
436# ifdef MASKING
437 & extract(ng) % vmask, &
438# endif
439 & extract(ng) % z_v, &
440 & setfillval = .false.)
441 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
442 IF (master) THEN
443 WRITE (stdout,20) trim(vname(1,idpthv)), xtr(ng)%Rindex
444 END IF
445 exit_flag=3
446 ioerror=status
447 RETURN
448 END IF
449 END IF
450!
451! Write time-varying depths of W-points.
452!
453 IF (hout(idpthw,ng)) THEN
454 scale=1.0_dp
455 gtype=gfactor*w3dvar
456 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idpthw, &
457 & xtr(ng)%Vid(idpthw), &
458 & xtr(ng)%Rindex, gtype, &
459 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
460# ifdef MASKING
461 & extract(ng) % rmask, &
462# endif
463 & extract(ng) % z_w, &
464 & setfillval = .false.)
465 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
466 IF (master) THEN
467 WRITE (stdout,20) trim(vname(1,idpthw)), xtr(ng)%Rindex
468 END IF
469 exit_flag=3
470 ioerror=status
471 RETURN
472 END IF
473 END IF
474# endif
475!
476! Write out free-surface (m)
477!
478 IF (hout(idfsur,ng)) THEN
479 scale=1.0_dp
480 gtype=gfactor*r2dvar
481 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idfsur, &
482 & xtr(ng)%Vid(idfsur), &
483 & xtr(ng)%Rindex, gtype, &
484 & lbi, ubi, lbj, ubj, scale, &
485# ifdef MASKING
486 & grid(ng) % rmask, &
487# endif
488 & ocean(ng) % zeta(:,:,kout), &
489 & setfillval = .false., &
490 & extractfield = extractflag(ng))
491 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
492 IF (master) THEN
493 WRITE (stdout,20) trim(vname(1,idfsur)), xtr(ng)%Rindex
494 END IF
495 exit_flag=3
496 ioerror=status
497 RETURN
498 END IF
499
500# if defined FORWARD_WRITE && defined FORWARD_RHS
501!
502 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idrzet, &
503 & xtr(ng)%Vid(idrzet), &
504 & xtr(ng)%Rindex, gtype, &
505 & lbi, ubi, lbj, ubj, scale, &
506# ifdef MASKING
507 & grid(ng) % rmask, &
508# endif
509 & ocean(ng) % rzeta(:,:,kout), &
510 & setfillval = .false., &
511 & extractfield = extractflag(ng))
512 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
513 IF (master) THEN
514 WRITE (stdout,20) trim(vname(1,idrzet)), xtr(ng)%Rindex
515 END IF
516 exit_flag=3
517 ioerror=status
518 RETURN
519 END IF
520# endif
521 END IF
522
523# ifdef ADJUST_BOUNDARY
524!
525! Write out free-surface open boundaries.
526!
527 IF (any(lobc(:,isfsur,ng))) THEN
528 scale=1.0_dp
529 status=nf_fwrite2d_bry(ng, model, xtr(ng)%name, xtr(ng)%ncid, &
530 & vname(1,idsbry(isfsur)), &
531 & xtr(ng)%Vid(idsbry(isfsur)), &
532 & xtr(ng)%Rindex, r2dvar, &
533 & lbij, ubij, nbrec(ng), scale, &
534 & boundary(ng) % zeta_obc(lbij:,:,:, &
535 & lbout(ng)), &
536 & extractfield = extractflag(ng))
537 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
538 IF (master) THEN
539 WRITE (stdout,20) trim(vname(1,idsbry(isfsur))), &
540 & xtr(ng)%Rindex
541 END IF
542 exit_flag=3
543 ioerror=status
544 RETURN
545 END IF
546 END IF
547# endif
548!
549! Write out 2D U-momentum component (m/s).
550!
551 IF (hout(idubar,ng)) THEN
552 scale=1.0_dp
553 gtype=gfactor*u2dvar
554 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idubar, &
555 & xtr(ng)%Vid(idubar), &
556 & xtr(ng)%Rindex, gtype, &
557 & lbi, ubi, lbj, ubj, scale, &
558# ifdef MASKING
559 & grid(ng) % umask_full, &
560# endif
561 & ocean(ng) % ubar(:,:,kout), &
562 & setfillval = .false., &
563 & extractfield = extractflag(ng))
564 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
565 IF (master) THEN
566 WRITE (stdout,20) trim(vname(1,idubar)), xtr(ng)%Rindex
567 END IF
568 exit_flag=3
569 ioerror=status
570 RETURN
571 END IF
572
573# ifdef FORWARD_WRITE
574# ifdef FORWARD_RHS
575!
576 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idru2d, &
577 & xtr(ng)%Vid(idru2d), &
578 & xtr(ng)%Rindex, gtype, &
579 & lbi, ubi, lbj, ubj, scale, &
580# ifdef MASKING
581 & grid(ng) % umask_full, &
582# endif
583 & ocean(ng) % rubar(:,:,kout), &
584 & setfillval = .false., &
585 & extractfield = extractflag(ng))
586 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
587 IF (master) THEN
588 WRITE (stdout,20) trim(vname(1,idru2d)), xtr(ng)%Rindex
589 END IF
590 exit_flag=3
591 ioerror=status
592 RETURN
593 END IF
594# endif
595# ifdef SOLVE3D
596# ifdef FORWARD_RHS
597!
598 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idruct, &
599 & xtr(ng)%Vid(idruct), &
600 & xtr(ng)%Rindex, gtype, &
601 & lbi, ubi, lbj, ubj, scale, &
602# ifdef MASKING
603 & grid(ng) % umask_full, &
604# endif
605 & coupling(ng) % rufrc, &
606 & setfillval = .false., &
607 & extractfield = extractflag(ng))
608 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
609 IF (master) THEN
610 WRITE (stdout,20) trim(vname(1,idruct)), xtr(ng)%Rindex
611 END IF
612 exit_flag=3
613 ioerror=status
614 RETURN
615 END IF
616# endif
617!
618 IF (.not.allocated(ur2d)) THEN
619 allocate (ur2d(lbi:ubi,lbj:ubj))
620 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
621 END IF
622 ur2d=extractflag(ng)*coupling(ng)%DU_avg1
623 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idufx1, &
624 & xtr(ng)%Vid(idufx1), &
625 & xtr(ng)%Rindex, gtype, &
626 & lbi, ubi, lbj, ubj, scale, &
627# ifdef MASKING
628 & grid(ng) % umask_full, &
629# endif
630 & ur2d, &
631 & setfillval = .false., &
632 & extractfield = extractflag(ng))
633 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
634 IF (master) THEN
635 WRITE (stdout,20) trim(vname(1,idufx1)), xtr(ng)%Rindex
636 END IF
637 exit_flag=3
638 ioerror=status
639 RETURN
640 END IF
641!
642 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
643 ur2d=extractflag(ng)*coupling(ng)%DU_avg2
644 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idufx2, &
645 & xtr(ng)%Vid(idufx2), &
646 & xtr(ng)%Rindex, gtype, &
647 & lbi, ubi, lbj, ubj, scale, &
648# ifdef MASKING
649 & grid(ng) % umask_full, &
650# endif
651 & ur2d, &
652 & setfillval = .false., &
653 & extractfield = extractflag(ng))
654 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
655 IF (master) THEN
656 WRITE (stdout,20) trim(vname(1,idufx2)), xtr(ng)%Rindex
657 END IF
658 exit_flag=3
659 ioerror=status
660 RETURN
661 END IF
662 deallocate (ur2d)
663# endif
664# endif
665 END IF
666
667# ifdef ADJUST_BOUNDARY
668!
669! Write out 2D U-momentum component open boundaries.
670!
671 IF (any(lobc(:,isubar,ng))) THEN
672 scale=1.0_dp
673 status=nf_fwrite2d_bry(ng, model, xtr(ng)%name, xtr(ng)%ncid, &
674 & vname(1,idsbry(isubar)), &
675 & xtr(ng)%Vid(idsbry(isubar)), &
676 & xtr(ng)%Rindex, u2dvar, &
677 & lbij, ubij, nbrec(ng), scale, &
678 & boundary(ng) % ubar_obc(lbij:,:,:, &
679 & lbout(ng)), &
680 & extractfield = extractflag(ng))
681 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
682 IF (master) THEN
683 WRITE (stdout,20) trim(vname(1,idsbry(isubar))), &
684 & xtr(ng)%Rindex
685 END IF
686 exit_flag=3
687 ioerror=status
688 RETURN
689 END IF
690 END IF
691# endif
692!
693! Write out 2D V-momentum component (m/s).
694!
695 IF (hout(idvbar,ng)) THEN
696 scale=1.0_dp
697 gtype=gfactor*v2dvar
698 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvbar, &
699 & xtr(ng)%Vid(idvbar), &
700 & xtr(ng)%Rindex, gtype, &
701 & lbi, ubi, lbj, ubj, scale, &
702# ifdef MASKING
703 & grid(ng) % vmask_full, &
704# endif
705 & ocean(ng) % vbar(:,:,kout), &
706 & setfillval = .false., &
707 & extractfield = extractflag(ng))
708 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
709 IF (master) THEN
710 WRITE (stdout,20) trim(vname(1,idvbar)), xtr(ng)%Rindex
711 END IF
712 exit_flag=3
713 ioerror=status
714 RETURN
715 END IF
716
717# ifdef FORWARD_WRITE
718# ifdef FORWARD_RHS
719!
720 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idrv2d, &
721 & xtr(ng)%Vid(idrv2d), &
722 & xtr(ng)%Rindex, gtype, &
723 & lbi, ubi, lbj, ubj, scale, &
724# ifdef MASKING
725 & grid(ng) % vmask_full, &
726# endif
727 & ocean(ng) % rvbar(:,:,kout), &
728 & setfillval = .false., &
729 & extractfield = extractflag(ng))
730 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
731 IF (master) THEN
732 WRITE (stdout,20) trim(vname(1,idrv2d)), xtr(ng)%Rindex
733 END IF
734 exit_flag=3
735 ioerror=status
736 RETURN
737 END IF
738# endif
739# ifdef SOLVE3D
740# ifdef FORWARD_RHS
741!
742 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idrvct, &
743 & xtr(ng)%Vid(idrvct), &
744 & xtr(ng)%Rindex, gtype, &
745 & lbi, ubi, lbj, ubj, scale, &
746# ifdef MASKING
747 & grid(ng) % vmask_full, &
748# endif
749 & coupling(ng) % rvfrc, &
750 & setfillval = .false., &
751 & extractfield = extractflag(ng))
752 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
753 IF (master) THEN
754 WRITE (stdout,20) trim(vname(1,idrvct)), xtr(ng)%Rindex
755 END IF
756 exit_flag=3
757 ioerror=status
758 RETURN
759 END IF
760# endif
761!
762 IF (.not.allocated(vr2d)) THEN
763 allocate (vr2d(lbi:ubi,lbj:ubj))
764 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
765 END IF
766 vr2d=extractflag(ng)*coupling(ng)%DV_avg1
767 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvfx1, &
768 & xtr(ng)%Vid(idvfx1), &
769 & xtr(ng)%Rindex, gtype, &
770 & lbi, ubi, lbj, ubj, scale, &
771# ifdef MASKING
772 & grid(ng) % vmask_full, &
773# endif
774 & vr2d, &
775 & setfillval = .false., &
776 & extractfield = extractflag(ng))
777 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
778 IF (master) THEN
779 WRITE (stdout,20) trim(vname(1,idvfx1)), xtr(ng)%Rindex
780 END IF
781 exit_flag=3
782 ioerror=status
783 RETURN
784 END IF
785!
786 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
787 vr2d=extractflag(ng)*coupling(ng)%DV_avg2
788 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvfx2, &
789 & xtr(ng)%Vid(idvfx2), &
790 & xtr(ng)%Rindex, gtype, &
791 & lbi, ubi, lbj, ubj, scale, &
792# ifdef MASKING
793 & grid(ng) % vmask_full, &
794# endif
795 & vr2d, &
796 & setfillval = .false., &
797 & extractfield = extractflag(ng))
798 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
799 IF (master) THEN
800 WRITE (stdout,20) trim(vname(1,idvfx2)), xtr(ng)%Rindex
801 END IF
802 exit_flag=3
803 ioerror=status
804 RETURN
805 END IF
806 deallocate (vr2d)
807# endif
808# endif
809 END IF
810
811# ifdef ADJUST_BOUNDARY
812!
813! Write out 2D V-momentum component open boundaries.
814!
815 IF (any(lobc(:,isvbar,ng))) THEN
816 scale=1.0_dp
817 status=nf_fwrite2d_bry(ng, model, xtr(ng)%name, xtr(ng)%ncid, &
818 & vname(1,idsbry(isvbar)), &
819 & xtr(ng)%Vid(idsbry(isvbar)), &
820 & xtr(ng)%Rindex, v2dvar, &
821 & lbij, ubij, nbrec(ng), scale, &
822 & boundary(ng) % vbar_obc(lbij:,:,:, &
823 & lbout(ng)), &
824 & extractfield = extractflag(ng))
825 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
826 IF (master) THEN
827 WRITE (stdout,20) trim(vname(1,idsbry(isvbar))), &
828 & xtr(ng)%Rindex
829 END IF
830 exit_flag=3
831 ioerror=status
832 RETURN
833 END IF
834 END IF
835# endif
836!
837! Write out 2D Eastward and Northward momentum components (m/s) at
838! RHO-points.
839!
840 IF (hout(idu2de,ng).and.hout(idv2dn,ng)) THEN
841 IF (.not.allocated(ur2d)) THEN
842 allocate (ur2d(lbi:ubi,lbj:ubj))
843 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
844 END IF
845 IF (.not.allocated(vr2d)) THEN
846 allocate (vr2d(lbi:ubi,lbj:ubj))
847 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
848 END IF
849 CALL uv_rotate2d (ng, tile, .false., .true., &
850 & lbi, ubi, lbj, ubj, &
851 & grid(ng) % CosAngler, &
852 & grid(ng) % SinAngler, &
853# ifdef MASKING
854 & grid(ng) % rmask_full, &
855# endif
856 & ocean(ng) % ubar(:,:,kout), &
857 & ocean(ng) % vbar(:,:,kout), &
858 & ur2d, vr2d)
859!
860 scale=1.0_dp
861 gtype=gfactor*r2dvar
862 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idu2de, &
863 & xtr(ng)%Vid(idu2de), &
864 & xtr(ng)%Rindex, gtype, &
865 & lbi, ubi, lbj, ubj, scale, &
866# ifdef MASKING
867 & grid(ng) % rmask_full, &
868# endif
869 & ur2d, &
870 & setfillval = .false., &
871 & extractfield = extractflag(ng))
872 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
873 IF (master) THEN
874 WRITE (stdout,20) trim(vname(1,idu2de)), xtr(ng)%Rindex
875 END IF
876 exit_flag=3
877 ioerror=status
878 RETURN
879 END IF
880!
881 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idv2dn, &
882 & xtr(ng)%Vid(idv2dn), &
883 & xtr(ng)%Rindex, gtype, &
884 & lbi, ubi, lbj, ubj, scale, &
885# ifdef MASKING
886 & grid(ng) % rmask_full, &
887# endif
888 & vr2d, &
889 & setfillval = .false., &
890 & extractfield = extractflag(ng))
891 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
892 IF (master) THEN
893 WRITE (stdout,20) trim(vname(1,idv2dn)), xtr(ng)%Rindex
894 END IF
895 exit_flag=3
896 ioerror=status
897 RETURN
898 END IF
899 deallocate (ur2d)
900 deallocate (vr2d)
901 END IF
902
903# ifdef SOLVE3D
904!
905! Write out 3D U-momentum component (m/s).
906!
907 IF (hout(iduvel,ng)) THEN
908 scale=1.0_dp
909 gtype=gfactor*u3dvar
910 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, iduvel, &
911 & xtr(ng)%Vid(iduvel), &
912 & xtr(ng)%Rindex, gtype, &
913 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
914# ifdef MASKING
915 & grid(ng) % umask_full, &
916# endif
917 & ocean(ng) % u(:,:,:,nout), &
918 & setfillval = .false., &
919 & extractfield = extractflag(ng))
920 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
921 IF (master) THEN
922 WRITE (stdout,20) trim(vname(1,iduvel)), xtr(ng)%Rindex
923 END IF
924 exit_flag=3
925 ioerror=status
926 RETURN
927 END IF
928
929# if defined FORWARD_WRITE && defined FORWARD_RHS
930!
931 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idru3d, &
932 & xtr(ng)%Vid(idru3d), &
933 & xtr(ng)%Rindex, gtype, &
934 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
935# ifdef MASKING
936 & grid(ng) % umask_full, &
937# endif
938 & ocean(ng) % ru(:,:,:,nout), &
939 & setfillval = .false., &
940 & extractfield = extractflag(ng))
941 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
942 IF (master) THEN
943 WRITE (stdout,20) trim(vname(1,idru3d)), xtr(ng)%Rindex
944 END IF
945 exit_flag=3
946 ioerror=status
947 RETURN
948 END IF
949# endif
950 END IF
951
952# ifdef ADJUST_BOUNDARY
953!
954! Write out 3D U-momentum component open boundaries.
955!
956 IF (any(lobc(:,isuvel,ng))) THEN
957 scale=1.0_dp
958 status=nf_fwrite3d_bry(ng, model, xtr(ng)%name, xtr(ng)%ncid, &
959 & vname(1,idsbry(isuvel)), &
960 & xtr(ng)%Vid(idsbry(isuvel)), &
961 & xtr(ng)%Rindex, u3dvar, &
962 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
963 & boundary(ng) % u_obc(lbij:,:,:,:, &
964 & lbout(ng)), &
965 & extractfield = extractflag(ng))
966 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
967 IF (master) THEN
968 WRITE (stdout,20) trim(vname(1,idsbry(isuvel))), &
969 & xtr(ng)%Rindex
970 END IF
971 exit_flag=3
972 ioerror=status
973 RETURN
974 END IF
975 END IF
976# endif
977!
978! Write out 3D V-momentum component (m/s).
979!
980 IF (hout(idvvel,ng)) THEN
981 scale=1.0_dp
982 gtype=gfactor*v3dvar
983 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idvvel, &
984 & xtr(ng)%Vid(idvvel), &
985 & xtr(ng)%Rindex, gtype, &
986 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
987# ifdef MASKING
988 & grid(ng) % vmask_full, &
989# endif
990 & ocean(ng) % v(:,:,:,nout), &
991 & setfillval = .false., &
992 & extractfield = extractflag(ng))
993 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
994 IF (master) THEN
995 WRITE (stdout,20) trim(vname(1,idvvel)), xtr(ng)%Rindex
996 END IF
997 exit_flag=3
998 ioerror=status
999 RETURN
1000 END IF
1001
1002# if defined FORWARD_WRITE && defined FORWARD_RHS
1003!
1004 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idrv3d, &
1005 & xtr(ng)%Vid(idrv3d), &
1006 & xtr(ng)%Rindex, gtype, &
1007 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1008# ifdef MASKING
1009 & grid(ng) % vmask_full, &
1010# endif
1011 & ocean(ng) % rv(:,:,:,nout), &
1012 & setfillval = .false., &
1013 & extractfield = extractflag(ng))
1014 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1015 IF (master) THEN
1016 WRITE (stdout,20) trim(vname(1,idrv3d)), xtr(ng)%Rindex
1017 END IF
1018 exit_flag=3
1019 ioerror=status
1020 RETURN
1021 END IF
1022# endif
1023 END IF
1024
1025# ifdef ADJUST_BOUNDARY
1026!
1027! Write out 3D V-momentum component open boundaries.
1028!
1029 IF (any(lobc(:,isvvel,ng))) THEN
1030 scale=1.0_dp
1031 status=nf_fwrite3d_bry(ng, model, xtr(ng)%name, xtr(ng)%ncid, &
1032 & vname(1,idsbry(isvvel)), &
1033 & xtr(ng)%Vid(idsbry(isvvel)), &
1034 & xtr(ng)%Rindex, v3dvar, &
1035 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
1036 & boundary(ng) % v_obc(lbij:,:,:,:, &
1037 & lbout(ng)), &
1038 & extractfield = extractflag(ng))
1039 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1040 IF (master) THEN
1041 WRITE (stdout,20) trim(vname(1,idsbry(isvvel))), &
1042 & xtr(ng)%Rindex
1043 END IF
1044 exit_flag=3
1045 ioerror=status
1046 RETURN
1047 END IF
1048 END IF
1049# endif
1050!
1051! Write out 3D Eastward and Northward momentum components (m/s) at
1052! RHO-points.
1053!
1054 IF (hout(idu3de,ng).and.hout(idv3dn,ng)) THEN
1055 IF (.not.allocated(ur3d)) THEN
1056 allocate (ur3d(lbi:ubi,lbj:ubj,n(ng)))
1057 ur3d(lbi:ubi,lbj:ubj,1:n(ng))=0.0_r8
1058 END IF
1059 IF (.not.allocated(vr3d)) THEN
1060 allocate (vr3d(lbi:ubi,lbj:ubj,n(ng)))
1061 vr3d(lbi:ubi,lbj:ubj,1:n(ng))=0.0_r8
1062 END IF
1063 CALL uv_rotate3d (ng, tile, .false., .true., &
1064 & lbi, ubi, lbj, ubj, 1, n(ng), &
1065 & grid(ng) % CosAngler, &
1066 & grid(ng) % SinAngler, &
1067# ifdef MASKING
1068 & grid(ng) % rmask_full, &
1069# endif
1070 & ocean(ng) % u(:,:,:,nout), &
1071 & ocean(ng) % v(:,:,:,nout), &
1072 & ur3d, vr3d)
1073!
1074 scale=1.0_dp
1075 gtype=gfactor*r3dvar
1076 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idu3de, &
1077 & xtr(ng)%Vid(idu3de), &
1078 & xtr(ng)%Rindex, gtype, &
1079 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1080# ifdef MASKING
1081 & grid(ng) % rmask_full, &
1082# endif
1083 & ur3d, &
1084 & setfillval = .false., &
1085 & extractfield = extractflag(ng))
1086 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1087 IF (master) THEN
1088 WRITE (stdout,20) trim(vname(1,idu3de)), xtr(ng)%Rindex
1089 END IF
1090 exit_flag=3
1091 ioerror=status
1092 RETURN
1093 END IF
1094!
1095 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idv3dn, &
1096 & xtr(ng)%Vid(idv3dn), &
1097 & xtr(ng)%Rindex, gtype, &
1098 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1099# ifdef MASKING
1100 & grid(ng) % rmask_full, &
1101# endif
1102 & vr3d, &
1103 & setfillval = .false., &
1104 & extractfield = extractflag(ng))
1105 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1106 IF (master) THEN
1107 WRITE (stdout,20) trim(vname(1,idv3dn)), xtr(ng)%Rindex
1108 END IF
1109 exit_flag=3
1110 ioerror=status
1111 RETURN
1112 END IF
1113 deallocate (ur3d)
1114 deallocate (vr3d)
1115 END IF
1116!
1117! Write out S-coordinate omega vertical velocity (m/s).
1118!
1119 IF (hout(idovel,ng)) THEN
1120 IF (.not.allocated(wr3d)) THEN
1121 allocate (wr3d(lbi:ubi,lbj:ubj,0:n(ng)))
1122 wr3d(lbi:ubi,lbj:ubj,0:n(ng))=0.0_r8
1123 END IF
1124 scale=1.0_dp
1125 gtype=gfactor*w3dvar
1126 CALL scale_omega (ng, tile, lbi, ubi, lbj, ubj, 0, n(ng), &
1127 & grid(ng) % pm, &
1128 & grid(ng) % pn, &
1129 & ocean(ng) % W, &
1130 & wr3d)
1131 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idovel, &
1132 & xtr(ng)%Vid(idovel), &
1133 & xtr(ng)%Rindex, gtype, &
1134 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1135# ifdef MASKING
1136 & grid(ng) % rmask, &
1137# endif
1138 & wr3d, &
1139 & setfillval = .false., &
1140 & extractfield = extractflag(ng))
1141 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1142 IF (master) THEN
1143 WRITE (stdout,20) trim(vname(1,idovel)), xtr(ng)%Rindex
1144 END IF
1145 exit_flag=3
1146 ioerror=status
1147 RETURN
1148 END IF
1149 deallocate (wr3d)
1150 END IF
1151
1152# ifdef OMEGA_IMPLICIT
1153!
1154! Write out S-coordinate implicit vertical "omega" momentum component.
1155!
1156 IF (hout(idovil,ng)) THEN
1157 IF (.not.allocated(wr3d)) THEN
1158 allocate (wr3d(lbi:ubi,lbj:ubj,0:n(ng)))
1159 wr3d(lbi:ubi,lbj:ubj,0:n(ng))=0.0_r8
1160 END IF
1161 scale=1.0_dp
1162 gtype=gfactor*w3dvar
1163 CALL scale_omega (ng, tile, lbi, ubi, lbj, ubj, 0, n(ng), &
1164 & grid(ng) % pm, &
1165 & grid(ng) % pn, &
1166 & ocean(ng) % Wi, &
1167 & wr3d)
1168 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idovil, &
1169 & xtr(ng)%Vid(idovil), &
1170 & xtr(ng)%Rindex, gtype, &
1171 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1172# ifdef MASKING
1173 & grid(ng) % rmask, &
1174# endif
1175 & wr3d, &
1176 & setfillval = .false., &
1177 & extractfield = extractflag(ng))
1178 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1179 IF (master) THEN
1180 WRITE (stdout,20) trim(vname(1,idovil)), xtr(ng)%Rindex
1181 END IF
1182 exit_flag=3
1183 ioerror=status
1184 RETURN
1185 END IF
1186 deallocate (wr3d)
1187 END IF
1188# endif
1189!
1190! Write out vertical velocity (m/s).
1191!
1192 IF (hout(idwvel,ng)) THEN
1193 scale=1.0_dp
1194 gtype=gfactor*w3dvar
1195 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idwvel, &
1196 & xtr(ng)%Vid(idwvel), &
1197 & xtr(ng)%Rindex, gtype, &
1198 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1199# ifdef MASKING
1200 & grid(ng) % rmask, &
1201# endif
1202 & ocean(ng) % wvel, &
1203 & setfillval = .false., &
1204 & extractfield = extractflag(ng))
1205 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1206 IF (master) THEN
1207 WRITE (stdout,20) trim(vname(1,idwvel)), xtr(ng)%Rindex
1208 END IF
1209 exit_flag=3
1210 ioerror=status
1211 RETURN
1212 END IF
1213 END IF
1214!
1215! Write out tracer type variables.
1216!
1217 DO itrc=1,nt(ng)
1218 IF (hout(idtvar(itrc),ng)) THEN
1219 scale=1.0_dp
1220 gtype=gfactor*r3dvar
1221 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idtvar(itrc), &
1222 & xtr(ng)%Tid(itrc), &
1223 & xtr(ng)%Rindex, gtype, &
1224 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1225# ifdef MASKING
1226 & grid(ng) % rmask, &
1227# endif
1228 & ocean(ng) % t(:,:,:,nout,itrc), &
1229 & setfillval = .false., &
1230 & extractfield = extractflag(ng))
1231 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1232 IF (master) THEN
1233 WRITE (stdout,20) trim(vname(1,idtvar(itrc))), &
1234 & xtr(ng)%Rindex
1235 END IF
1236 exit_flag=3
1237 ioerror=status
1238 RETURN
1239 END IF
1240 END IF
1241 END DO
1242
1243# ifdef ADJUST_BOUNDARY
1244!
1245! Write out 3D tracers open boundaries.
1246!
1247 DO itrc=1,nt(ng)
1248 IF (any(lobc(:,istvar(itrc),ng))) THEN
1249 scale=1.0_dp
1250 ifield=idsbry(istvar(itrc))
1251 status=nf_fwrite3d_bry(ng, model, xtr(ng)%name, xtr(ng)%ncid,&
1252 & vname(1,ifield), &
1253 & xtr(ng)%Vid(ifield), &
1254 & xtr(ng)%Rindex, r3dvar, &
1255 & lbij, ubij, 1, n(ng), nbrec(ng), &
1256 & scale, &
1257 & boundary(ng) % t_obc(lbij:,:,:,:, &
1258 & lbout(ng),itrc), &
1259 & extractfield = extractflag(ng))
1260 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1261 IF (master) THEN
1262 WRITE (stdout,20) trim(vname(1,ifield)), xtr(ng)%Rindex
1263 END IF
1264 exit_flag=3
1265 ioerror=status
1266 RETURN
1267 END IF
1268 END IF
1269 END DO
1270# endif
1271!
1272! Write out density anomaly.
1273!
1274 IF (hout(iddano,ng)) THEN
1275 scale=1.0_dp
1276 gtype=gfactor*r3dvar
1277 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, iddano, &
1278 & xtr(ng)%Vid(iddano), &
1279 & xtr(ng)%Rindex, gtype, &
1280 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1281# ifdef MASKING
1282 & grid(ng) % rmask, &
1283# endif
1284 & ocean(ng) % rho, &
1285 & setfillval = .false., &
1286 & extractfield = extractflag(ng))
1287 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1288 IF (master) THEN
1289 WRITE (stdout,20) trim(vname(1,iddano)), xtr(ng)%Rindex
1290 END IF
1291 exit_flag=3
1292 ioerror=status
1293 RETURN
1294 END IF
1295 END IF
1296
1297# ifdef LMD_SKPP
1298!
1299! Write out depth surface boundary layer.
1300!
1301 IF (hout(idhsbl,ng)) THEN
1302 scale=1.0_dp
1303 gtype=gfactor*r2dvar
1304 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idhsbl, &
1305 & xtr(ng)%Vid(idhsbl), &
1306 & xtr(ng)%Rindex, gtype, &
1307 & lbi, ubi, lbj, ubj, scale, &
1308# ifdef MASKING
1309 & grid(ng) % rmask, &
1310# endif
1311 & mixing(ng) % hsbl, &
1312 & setfillval = .false., &
1313 & extractfield = extractflag(ng))
1314 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1315 IF (master) THEN
1316 WRITE (stdout,20) trim(vname(1,idhsbl)), xtr(ng)%Rindex
1317 END IF
1318 exit_flag=3
1319 ioerror=status
1320 RETURN
1321 END IF
1322 END IF
1323# endif
1324# ifdef LMD_BKPP
1325!
1326! Write out depth bottom boundary layer.
1327!
1328 IF (hout(idhbbl,ng)) THEN
1329 scale=1.0_dp
1330 gtype=gfactor*r2dvar
1331 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idhbbl, &
1332 & xtr(ng)%Vid(idhbbl), &
1333 & xtr(ng)%Rindex, gtype, &
1334 & lbi, ubi, lbj, ubj, scale, &
1335# ifdef MASKING
1336 & grid(ng) % rmask, &
1337# endif
1338 & mixing(ng) % hbbl, &
1339 & setfillval = .false., &
1340 & extractfield = extractflag(ng))
1341 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1342 IF (master) THEN
1343 WRITE (stdout,20) trim(vname(1,idhbbl)), xtr(ng)%Rindex
1344 END IF
1345 exit_flag=3
1346 ioerror=status
1347 RETURN
1348 END IF
1349 END IF
1350# endif
1351# if defined FORWARD_WRITE && defined LMD_NONLOCAL
1352!
1353! Write out KPP nonlocal transport.
1354!
1355 DO i=1,nat
1356 IF (hout(idghat(i),ng)) THEN
1357 scale=1.0_dp
1358 gtype=gfactor*w3dvar
1359 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idghat(i), &
1360 & xtr(ng)%Vid(idghat(i)), &
1361 & xtr(ng)%Rindex, gtype, &
1362 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1363# ifdef MASKING
1364 & grid(ng) % rmask, &
1365# endif
1366 & mixing(ng) % ghats(:,:,:,i), &
1367 & setfillval = .false., &
1368 & extractfield = extractflag(ng))
1369 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1370 IF (master) THEN
1371 WRITE (stdout,20) trim(vname(1,idghat(i))), xtr(ng)%Rindex
1372 END IF
1373 exit_flag=3
1374 ioerror=status
1375 RETURN
1376 END IF
1377 END IF
1378 END DO
1379# endif
1380!
1381! Write out vertical viscosity coefficient.
1382!
1383 IF (hout(idvvis,ng)) THEN
1384 scale=1.0_dp
1385 gtype=gfactor*w3dvar
1386 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idvvis, &
1387 & xtr(ng)%Vid(idvvis), &
1388 & xtr(ng)%Rindex, gtype, &
1389 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1390# ifdef MASKING
1391 & grid(ng) % rmask, &
1392# endif
1393 & mixing(ng) % Akv, &
1394 & setfillval = .false., &
1395 & extractfield = extractflag(ng))
1396 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1397 IF (master) THEN
1398 WRITE (stdout,20) trim(vname(1,idvvis)), xtr(ng)%Rindex
1399 END IF
1400 exit_flag=3
1401 ioerror=status
1402 RETURN
1403 END IF
1404 END IF
1405!
1406! Write out vertical diffusion coefficient for potential temperature.
1407!
1408 IF (hout(idtdif,ng)) THEN
1409 scale=1.0_dp
1410 gtype=gfactor*w3dvar
1411 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idtdif, &
1412 & xtr(ng)%Vid(idtdif), &
1413 & xtr(ng)%Rindex, gtype, &
1414 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1415# ifdef MASKING
1416 & grid(ng) % rmask, &
1417# endif
1418 & mixing(ng) % Akt(:,:,:,itemp), &
1419 & setfillval = .false., &
1420 & extractfield = extractflag(ng))
1421 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1422 IF (master) THEN
1423 WRITE (stdout,20) trim(vname(1,idtdif)), xtr(ng)%Rindex
1424 END IF
1425 exit_flag=3
1426 ioerror=status
1427 RETURN
1428 END IF
1429 END IF
1430
1431# ifdef SALINITY
1432!
1433! Write out vertical diffusion coefficient for salinity.
1434!
1435 IF (hout(idsdif,ng)) THEN
1436 scale=1.0_dp
1437 gtype=gfactor*w3dvar
1438 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idsdif, &
1439 & xtr(ng)%Vid(idsdif), &
1440 & xtr(ng)%Rindex, gtype, &
1441 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1442# ifdef MASKING
1443 & grid(ng) % rmask, &
1444# endif
1445 & mixing(ng) % Akt(:,:,:,isalt), &
1446 & setfillval = .false., &
1447 & extractfield = extractflag(ng))
1448 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1449 IF (master) THEN
1450 WRITE (stdout,20) trim(vname(1,idsdif)), xtr(ng)%Rindex
1451 END IF
1452 exit_flag=3
1453 ioerror=status
1454 RETURN
1455 END IF
1456 END IF
1457# endif
1458# if defined GLS_MIXING || defined MY25_MIXING
1459!
1460! Write out turbulent kinetic energy.
1461!
1462 IF (hout(idmtke,ng)) THEN
1463 scale=1.0_dp
1464 gtype=gfactor*w3dvar
1465 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idmtke, &
1466 & xtr(ng)%Vid(idmtke), &
1467 & xtr(ng)%Rindex, gtype, &
1468 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1469# ifdef MASKING
1470 & grid(ng) % rmask, &
1471# endif
1472 & mixing(ng) % tke(:,:,:,nout), &
1473 & setfillval = .false., &
1474 & extractfield = extractflag(ng))
1475 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1476 IF (master) THEN
1477 WRITE (stdout,20) trim(vname(1,idmtke)), xtr(ng)%Rindex
1478 END IF
1479 exit_flag=3
1480 ioerror=status
1481 RETURN
1482 END IF
1483
1484# ifdef FORWARD_WRITE
1485!
1486 scale=1.0_dp
1487 gtype=gfactor*w3dvar
1488 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idvmkk, &
1489 & xtr(ng)%Vid(idvmkk), &
1490 & xtr(ng)%Rindex, gtype, &
1491 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1492# ifdef MASKING
1493 & grid(ng) % rmask, &
1494# endif
1495 & mixing(ng) % Akk, &
1496 & setfillval = .false., &
1497 & extractfield = extractflag(ng))
1498 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1499 IF (master) THEN
1500 WRITE (stdout,20) trim(vname(1,idvmkk)), xtr(ng)%Rindex
1501 END IF
1502 exit_flag=3
1503 ioerror=status
1504 RETURN
1505 END IF
1506# endif
1507 END IF
1508!
1509! Write out turbulent length scale field.
1510!
1511 IF (hout(idmtls,ng)) THEN
1512 scale=1.0_dp
1513 gtype=gfactor*w3dvar
1514 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idmtls, &
1515 & xtr(ng)%Vid(idmtls), &
1516 & xtr(ng)%Rindex, gtype, &
1517 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1518# ifdef MASKING
1519 & grid(ng) % rmask, &
1520# endif
1521 & mixing(ng) % gls(:,:,:,nout), &
1522 & setfillval = .false., &
1523 & extractfield = extractflag(ng))
1524 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1525 IF (master) THEN
1526 WRITE (stdout,20) trim(vname(1,idmtls)), xtr(ng)%Rindex
1527 END IF
1528 exit_flag=3
1529 ioerror=status
1530 RETURN
1531 END IF
1532
1533# ifdef FORWARD_WRITE
1534!
1535 scale=1.0_dp
1536 gtype=gfactor*w3dvar
1537 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idvmls, &
1538 & xtr(ng)%Vid(idvmls), &
1539 & xtr(ng)%Rindex, gtype, &
1540 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1541# ifdef MASKING
1542 & grid(ng) % rmask, &
1543# endif
1544 & mixing(ng) % Lscale, &
1545 & setfillval = .false., &
1546 & extractfield = extractflag(ng))
1547 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1548 IF (master) THEN
1549 WRITE (stdout,20) trim(vname(1,idvmls)), xtr(ng)%Rindex
1550 END IF
1551 exit_flag=3
1552 ioerror=status
1553 RETURN
1554 END IF
1555# endif
1556# if defined FORWARD_WRITE && defined GLS_MIXING
1557!
1558 scale=1.0_dp
1559 gtype=gfactor*w3dvar
1560 status=nf_fwrite3d(ng, model, xtr(ng)%ncid, idvmkp, &
1561 & xtr(ng)%Vid(idvmkp), &
1562 & xtr(ng)%Rindex, gtype, &
1563 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1564# ifdef MASKING
1565 & grid(ng) % rmask, &
1566# endif
1567 & mixing(ng) % Akp, &
1568 & setfillval = .false., &
1569 & extractfield = extractflag(ng))
1570 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1571 IF (master) THEN
1572 WRITE (stdout,20) trim(vname(1,idvmkp)), xtr(ng)%Rindex
1573 END IF
1574 exit_flag=3
1575 ioerror=status
1576 RETURN
1577 END IF
1578# endif
1579 END IF
1580# endif
1581# if defined BULK_FLUXES || defined ECOSIM || defined ATM_PRESS
1582!
1583! Write out surface air pressure.
1584!
1585 IF (hout(idpair,ng)) THEN
1586 scale=1.0_dp
1587 gtype=gfactor*r2dvar
1588 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idpair, &
1589 & xtr(ng)%Vid(idpair), &
1590 & xtr(ng)%Rindex, gtype, &
1591 & lbi, ubi, lbj, ubj, scale, &
1592# ifdef MASKING
1593 & grid(ng) % rmask, &
1594# endif
1595 & forces(ng) % Pair, &
1596 & setfillval = .false., &
1597 & extractfield = extractflag(ng))
1598 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1599 IF (master) THEN
1600 WRITE (stdout,20) trim(vname(1,idpair)), xtr(ng)%Rindex
1601 END IF
1602 exit_flag=3
1603 ioerror=status
1604 RETURN
1605 END IF
1606 END IF
1607# endif
1608# if defined BULK_FLUXES
1609!
1610! Write out surface air temperature.
1611!
1612 IF (hout(idtair,ng)) THEN
1613 scale=1.0_dp
1614 gtype=gfactor*r2dvar
1615 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idtair, &
1616 & xtr(ng)%Vid(idtair), &
1617 & xtr(ng)%Rindex, gtype, &
1618 & lbi, ubi, lbj, ubj, scale, &
1619# ifdef MASKING
1620 & grid(ng) % rmask, &
1621# endif
1622 & forces(ng) % Tair, &
1623 & setfillval = .false., &
1624 & extractfield = extractflag(ng))
1625 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1626 IF (master) THEN
1627 WRITE (stdout,20) trim(vname(1,idtair)), xtr(ng)%Rindex
1628 END IF
1629 exit_flag=3
1630 ioerror=status
1631 RETURN
1632 END IF
1633 END IF
1634# endif
1635# if defined BULK_FLUXES || defined ECOSIM
1636!
1637! Write out surface winds.
1638!
1639 IF (hout(iduair,ng)) THEN
1640 scale=1.0_dp
1641 gtype=gfactor*r2dvar
1642 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, iduair, &
1643 & xtr(ng)%Vid(iduair), &
1644 & xtr(ng)%Rindex, gtype, &
1645 & lbi, ubi, lbj, ubj, scale, &
1646# ifdef MASKING
1647 & grid(ng) % rmask, &
1648# endif
1649 & forces(ng) % Uwind, &
1650 & setfillval = .false., &
1651 & extractfield = extractflag(ng))
1652 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1653 IF (master) THEN
1654 WRITE (stdout,20) trim(vname(1,iduair)), xtr(ng)%Rindex
1655 END IF
1656 exit_flag=3
1657 ioerror=status
1658 RETURN
1659 END IF
1660 END IF
1661!
1662 IF (hout(idvair,ng)) THEN
1663 scale=1.0_dp
1664 gtype=gfactor*r2dvar
1665 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvair, &
1666 & xtr(ng)%Vid(idvair), &
1667 & xtr(ng)%Rindex, gtype, &
1668 & lbi, ubi, lbj, ubj, scale, &
1669# ifdef MASKING
1670 & grid(ng) % rmask, &
1671# endif
1672 & forces(ng) % Vwind, &
1673 & setfillval = .false., &
1674 & extractfield = extractflag(ng))
1675 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1676 IF (master) THEN
1677 WRITE (stdout,20) trim(vname(1,idvair)), xtr(ng)%Rindex
1678 END IF
1679 exit_flag=3
1680 ioerror=status
1681 RETURN
1682 END IF
1683 END IF
1684!
1685! Write out Eastward/Northward surface wind (m/s) at RHO-points.
1686!
1687 IF (hout(iduaie,ng).and.hout(idvain,ng)) THEN
1688 IF (.not.allocated(ur2d)) THEN
1689 allocate (ur2d(lbi:ubi,lbj:ubj))
1690 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
1691 END IF
1692 IF (.not.allocated(vr2d)) THEN
1693 allocate (vr2d(lbi:ubi,lbj:ubj))
1694 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
1695 END IF
1696 CALL uv_rotate2d (ng, tile, .false., .true., &
1697 & lbi, ubi, lbj, ubj, &
1698 & grid(ng) % CosAngler, &
1699 & grid(ng) % SinAngler, &
1700# ifdef MASKING
1701 & grid(ng) % rmask_full, &
1702# endif
1703 & forces(ng) % Uwind, &
1704 & forces(ng) % Vwind, &
1705 & ur2d, vr2d)
1706!
1707 scale=1.0_dp
1708 gtype=gfactor*r2dvar
1709 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, iduaie, &
1710 & xtr(ng)%Vid(iduaie), &
1711 & xtr(ng)%Rindex, gtype, &
1712 & lbi, ubi, lbj, ubj, scale, &
1713# ifdef MASKING
1714 & grid(ng) % rmask, &
1715# endif
1716 & ur2d, &
1717 & setfillval = .false., &
1718 & extractfield = extractflag(ng))
1719 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1720 IF (master) THEN
1721 WRITE (stdout,20) trim(vname(1,iduaie)), xtr(ng)%Rindex
1722 END IF
1723 exit_flag=3
1724 ioerror=status
1725 RETURN
1726 END IF
1727!
1728 scale=1.0_dp
1729 gtype=gfactor*r2dvar
1730 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvain, &
1731 & xtr(ng)%Vid(idvain), &
1732 & xtr(ng)%Rindex, gtype, &
1733 & lbi, ubi, lbj, ubj, scale, &
1734# ifdef MASKING
1735 & grid(ng) % rmask, &
1736# endif
1737 & vr2d, &
1738 & setfillval = .false., &
1739 & extractfield = extractflag(ng))
1740 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1741 IF (master) THEN
1742 WRITE (stdout,20) trim(vname(1,idvain)), xtr(ng)%Rindex
1743 END IF
1744 exit_flag=3
1745 ioerror=status
1746 RETURN
1747 END IF
1748 deallocate (ur2d)
1749 deallocate (vr2d)
1750 END IF
1751# endif
1752!
1753! Write out surface active tracers fluxes.
1754!
1755 DO itrc=1,nat
1756 IF (hout(idtsur(itrc),ng)) THEN
1757 IF (itrc.eq.itemp) THEN
1758# ifdef SO_SEMI
1759 scale=1.0_dp
1760# else
1761 scale=rho0*cp ! Celsius m/s to W/m2
1762# endif
1763 ELSE IF (itrc.eq.isalt) THEN
1764 scale=1.0_dp
1765 END IF
1766 gtype=gfactor*r2dvar
1767 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idtsur(itrc), &
1768 & xtr(ng)%Vid(idtsur(itrc)), &
1769 & xtr(ng)%Rindex, gtype, &
1770 & lbi, ubi, lbj, ubj, scale, &
1771# ifdef MASKING
1772 & grid(ng) % rmask, &
1773# endif
1774 & forces(ng) % stflx(:,:,itrc), &
1775 & setfillval = .false., &
1776 & extractfield = extractflag(ng))
1777 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1778 IF (master) THEN
1779 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), &
1780 & xtr(ng)%Rindex
1781 END IF
1782 exit_flag=3
1783 ioerror=status
1784 RETURN
1785 END IF
1786 END IF
1787 END DO
1788
1789# if defined BULK_FLUXES || defined FRC_COUPLING
1790!
1791! Write out latent heat flux.
1792!
1793 IF (hout(idlhea,ng)) THEN
1794 scale=rho0*cp
1795 gtype=gfactor*r2dvar
1796 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idlhea, &
1797 & xtr(ng)%Vid(idlhea), &
1798 & xtr(ng)%Rindex, gtype, &
1799 & lbi, ubi, lbj, ubj, scale, &
1800# ifdef MASKING
1801 & grid(ng) % rmask, &
1802# endif
1803 & forces(ng) % lhflx, &
1804 & setfillval = .false., &
1805 & extractfield = extractflag(ng))
1806 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1807 IF (master) THEN
1808 WRITE (stdout,20) trim(vname(1,idlhea)), xtr(ng)%Rindex
1809 END IF
1810 exit_flag=3
1811 ioerror=status
1812 RETURN
1813 END IF
1814 END IF
1815!
1816! Write out sensible heat flux.
1817!
1818 IF (hout(idshea,ng)) THEN
1819 scale=rho0*cp
1820 gtype=gfactor*r2dvar
1821 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idshea, &
1822 & xtr(ng)%Vid(idshea), &
1823 & xtr(ng)%Rindex, gtype, &
1824 & lbi, ubi, lbj, ubj, scale, &
1825# ifdef MASKING
1826 & grid(ng) % rmask, &
1827# endif
1828 & forces(ng) % shflx, &
1829 & setfillval = .false., &
1830 & extractfield = extractflag(ng))
1831 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1832 IF (master) THEN
1833 WRITE (stdout,20) trim(vname(1,idshea)), xtr(ng)%Rindex
1834 END IF
1835 exit_flag=3
1836 ioerror=status
1837 RETURN
1838 END IF
1839 END IF
1840!
1841! Write out net longwave radiation flux.
1842!
1843 IF (hout(idlrad,ng)) THEN
1844 scale=rho0*cp
1845 gtype=gfactor*r2dvar
1846 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idlrad, &
1847 & xtr(ng)%Vid(idlrad), &
1848 & xtr(ng)%Rindex, gtype, &
1849 & lbi, ubi, lbj, ubj, scale, &
1850# ifdef MASKING
1851 & grid(ng) % rmask, &
1852# endif
1853 & forces(ng) % lrflx, &
1854 & setfillval = .false., &
1855 & extractfield = extractflag(ng))
1856 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1857 IF (master) THEN
1858 WRITE (stdout,20) trim(vname(1,idlrad)), xtr(ng)%Rindex
1859 END IF
1860 exit_flag=3
1861 ioerror=status
1862 RETURN
1863 END IF
1864 END IF
1865# endif
1866
1867# ifdef BULK_FLUXES
1868# ifdef EMINUSP
1869!
1870! Write out evaporation rate (kg/m2/s).
1871!
1872 IF (hout(idevap,ng)) THEN
1873 scale=1.0_dp
1874 gtype=gfactor*r2dvar
1875 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idevap, &
1876 & xtr(ng)%Vid(idevap), &
1877 & xtr(ng)%Rindex, gtype, &
1878 & lbi, ubi, lbj, ubj, scale, &
1879# ifdef MASKING
1880 & grid(ng) % rmask, &
1881# endif
1882 & forces(ng) % evap, &
1883 & setfillval = .false., &
1884 & extractfield = extractflag(ng))
1885 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1886 IF (master) THEN
1887 WRITE (stdout,20) trim(vname(1,idevap)), xtr(ng)%Rindex
1888 END IF
1889 exit_flag=3
1890 ioerror=status
1891 RETURN
1892 END IF
1893 END IF
1894!
1895! Write out precipitation rate (kg/m2/s).
1896!
1897 IF (hout(idrain,ng)) THEN
1898 scale=1.0_dp
1899 gtype=gfactor*r2dvar
1900 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idrain, &
1901 & xtr(ng)%Vid(idrain), &
1902 & xtr(ng)%Rindex, gtype, &
1903 & lbi, ubi, lbj, ubj, scale, &
1904# ifdef MASKING
1905 & grid(ng) % rmask, &
1906# endif
1907 & forces(ng) % rain, &
1908 & setfillval = .false., &
1909 & extractfield = extractflag(ng))
1910 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1911 IF (master) THEN
1912 WRITE (stdout,20) trim(vname(1,idrain)), xtr(ng)%Rindex
1913 END IF
1914 exit_flag=3
1915 ioerror=status
1916 RETURN
1917 END IF
1918 END IF
1919# endif
1920# endif
1921!
1922! Write out E-P (m/s).
1923!
1924 IF (hout(idempf,ng)) THEN
1925 scale=1.0_dp
1926 gtype=gfactor*r2dvar
1927 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idempf, &
1928 & xtr(ng)%Vid(idempf), &
1929 & xtr(ng)%Rindex, gtype, &
1930 & lbi, ubi, lbj, ubj, scale, &
1931# ifdef MASKING
1932 & grid(ng) % rmask, &
1933# endif
1934 & forces(ng) % stflux(:,:,isalt), &
1935 & setfillval = .false., &
1936 & extractfield = extractflag(ng))
1937 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1938 IF (master) THEN
1939 WRITE (stdout,20) trim(vname(1,idempf)), xtr(ng)%Rindex
1940 END IF
1941 exit_flag=3
1942 ioerror=status
1943 RETURN
1944 END IF
1945 END IF
1946
1947# ifdef SHORTWAVE
1948!
1949! Write out net shortwave radiation flux.
1950!
1951 IF (hout(idsrad,ng)) THEN
1952 scale=rho0*cp
1953 gtype=gfactor*r2dvar
1954 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idsrad, &
1955 & xtr(ng)%Vid(idsrad), &
1956 & xtr(ng)%Rindex, gtype, &
1957 & lbi, ubi, lbj, ubj, scale, &
1958# ifdef MASKING
1959 & grid(ng) % rmask, &
1960# endif
1961 & forces(ng) % srflx, &
1962 & setfillval = .false., &
1963 & extractfield = extractflag(ng))
1964 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1965 IF (master) THEN
1966 WRITE (stdout,20) trim(vname(1,idsrad)), xtr(ng)%Rindex
1967 END IF
1968 exit_flag=3
1969 ioerror=status
1970 RETURN
1971 END IF
1972 END IF
1973# endif
1974# endif
1975!
1976! Write out surface U-momentum stress.
1977!
1978 IF (hout(idusms,ng)) THEN
1979# ifdef SO_SEMI
1980 scale=1.0_dp
1981# else
1982 scale=rho0 ! m2/s2 to Pa
1983# endif
1984 gtype=gfactor*u2dvar
1985 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idusms, &
1986 & xtr(ng)%Vid(idusms), &
1987 & xtr(ng)%Rindex, gtype, &
1988 & lbi, ubi, lbj, ubj, scale, &
1989# ifdef MASKING
1990 & grid(ng) % umask, &
1991# endif
1992 & forces(ng) % sustr, &
1993 & setfillval = .false., &
1994 & extractfield = extractflag(ng))
1995 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1996 IF (master) THEN
1997 WRITE (stdout,20) trim(vname(1,idusms)), xtr(ng)%Rindex
1998 END IF
1999 exit_flag=3
2000 ioerror=status
2001 RETURN
2002 END IF
2003 END IF
2004!
2005! Write out surface V-momentum stress.
2006!
2007 IF (hout(idvsms,ng)) THEN
2008# ifdef SO_SEMI
2009 scale=1.0_dp
2010# else
2011 scale=rho0
2012# endif
2013 gtype=gfactor*v2dvar
2014 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvsms, &
2015 & xtr(ng)%Vid(idvsms), &
2016 & xtr(ng)%Rindex, gtype, &
2017 & lbi, ubi, lbj, ubj, scale, &
2018# ifdef MASKING
2019 & grid(ng) % vmask, &
2020# endif
2021 & forces(ng) % svstr, &
2022 & setfillval = .false., &
2023 & extractfield = extractflag(ng))
2024 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
2025 IF (master) THEN
2026 WRITE (stdout,20) trim(vname(1,idvsms)), xtr(ng)%Rindex
2027 END IF
2028 exit_flag=3
2029 ioerror=status
2030 RETURN
2031 END IF
2032 END IF
2033!
2034! Write out bottom U-momentum stress.
2035!
2036 IF (hout(idubms,ng)) THEN
2037 scale=-rho0
2038 gtype=gfactor*u2dvar
2039 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idubms, &
2040 & xtr(ng)%Vid(idubms), &
2041 & xtr(ng)%Rindex, gtype, &
2042 & lbi, ubi, lbj, ubj, scale, &
2043# ifdef MASKING
2044 & grid(ng) % umask, &
2045# endif
2046 & forces(ng) % bustr, &
2047 & setfillval = .false., &
2048 & extractfield = extractflag(ng))
2049 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
2050 IF (master) THEN
2051 WRITE (stdout,20) trim(vname(1,idubms)), xtr(ng)%Rindex
2052 END IF
2053 exit_flag=3
2054 ioerror=status
2055 RETURN
2056 END IF
2057 END IF
2058!
2059! Write out bottom V-momentum stress.
2060!
2061 IF (hout(idvbms,ng)) THEN
2062 scale=-rho0
2063 gtype=gfactor*v2dvar
2064 status=nf_fwrite2d(ng, model, xtr(ng)%ncid, idvbms, &
2065 & xtr(ng)%Vid(idvbms), &
2066 & xtr(ng)%Rindex, gtype, &
2067 & lbi, ubi, lbj, ubj, scale, &
2068# ifdef MASKING
2069 & grid(ng) % vmask, &
2070# endif
2071 & forces(ng) % bvstr, &
2072 & setfillval = .false., &
2073 & extractfield = extractflag(ng))
2074 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
2075 IF (master) THEN
2076 WRITE (stdout,20) trim(vname(1,idvbms)), xtr(ng)%Rindex
2077 END IF
2078 exit_flag=3
2079 ioerror=status
2080 RETURN
2081 END IF
2082 END IF
2083
2084# if (defined BBL_MODEL || defined WAVES_OUTPUT) && defined SOLVE3D
2085!
2086!-----------------------------------------------------------------------
2087! Write out the bottom boundary layer model or waves variables.
2088!-----------------------------------------------------------------------
2089!
2090 CALL bbl_wrt_nf90 (ng, model, tile, &
2091 & lbi, ubi, lbj, ubj, &
2092 & hout, xtr)
2093 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2094# endif
2095
2096# if defined ICE_MODEL && defined SOLVE3D
2097!
2098!-----------------------------------------------------------------------
2099! Write out the sea-ice model variables.
2100!-----------------------------------------------------------------------
2101!
2102 CALL ice_wrt_nf90 (ng, model, tile, &
2103 & lbi, ubi, lbj, ubj, &
2104 & hout, xtr)
2105 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2106# endif
2107
2108# if defined SEDIMENT && defined SOLVE3D
2109!
2110!-----------------------------------------------------------------------
2111! Write out the sediment model variables.
2112!-----------------------------------------------------------------------
2113!
2114 CALL sediment_wrt_nf90 (ng, model, tile, &
2115 & lbi, ubi, lbj, ubj, &
2116 & hout, xtr)
2117 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2118# endif
2119
2120# if defined WEC_VF && defined SOLVE3D
2121!
2122!-----------------------------------------------------------------------
2123! Write out the Waves Effect on Currents variables.
2124!-----------------------------------------------------------------------
2125!
2126 CALL wec_wrt_nf90 (ng, model, tile, &
2127 & lbi, ubi, lbj, ubj, &
2128 & hout, xtr)
2129 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2130# endif
2131!
2132!-----------------------------------------------------------------------
2133! Synchronize decimate NetCDF file to disk to allow other processes
2134! to access data immediately after it is written.
2135!-----------------------------------------------------------------------
2136!
2137 CALL netcdf_sync (ng, model, xtr(ng)%name, xtr(ng)%ncid)
2138 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2139!
2140 10 FORMAT (2x,'WRT_EXTRACT_NF90 - writing decimate', t42, &
2141# ifdef SOLVE3D
2142# ifdef NESTING
2143 & 'fields (Index=',i1,',',i1,') in record = ',i0,t92,i2.2)
2144# else
2145 & 'fields (Index=',i1,',',i1,') in record = ',i0)
2146# endif
2147# else
2148# ifdef NESTING
2149 & 'fields (Index=',i1,') in record = ',i0,t92,i2.2)
2150# else
2151 & 'fields (Index=',i1,') in record = ',i0)
2152# endif
2153# endif
2154 20 FORMAT (/,' WRT_EXTRACT_NF90 - error while writing variable: ',a, &
2155 & /,20x,'into decimate NetCDF file for time record: ',i0)
2156!
2157 RETURN
2158 END SUBROUTINE wrt_extract_nf90
2159
2160# if defined PIO_LIB && defined DISTRIBUTE
2161!
2162!***********************************************************************
2163 SUBROUTINE wrt_extract_pio (ng, model, tile, &
2164# ifdef ADJUST_BOUNDARY
2165 & LBij, UBij, &
2166 & ijLB, ijUB, &
2167
2168# endif
2169 & LBi, UBi, LBj, UBj, &
2170 & iLB, iUB, jLB, jUB)
2171!***********************************************************************
2172!
2173 USE mod_pio_netcdf
2174!
2175! Imported variable declarations.
2176!
2177 integer, intent(in) :: ng, model, tile
2178# ifdef ADJUST_BOUNDARY
2179 integer, intent(in) :: LBij, UBij
2180 integer, intent(in) :: ijLB, ijUB
2181# endif
2182 integer, intent(in) :: LBi, UBi, LBj, UBj
2183 integer, intent(in) :: iLB, iUB, jLB, jUB
2184!
2185! Local variable declarations.
2186!
2187 integer :: Fcount, ifield, status
2188# ifdef SOLVE3D
2189 integer :: i, itrc, j, k
2190# endif
2191!
2192 real(dp) :: scale
2193!
2194 real(r8), allocatable :: Ur2d(:,:)
2195 real(r8), allocatable :: Vr2d(:,:)
2196# ifdef SOLVE3D
2197 real(r8), allocatable :: Ur3d(:,:,:)
2198 real(r8), allocatable :: Vr3d(:,:,:)
2199 real(r8), allocatable :: Wr3d(:,:,:)
2200# endif
2201!
2202 character (len=*), parameter :: MyFile = &
2203 & __FILE__//", wrt_extract_pio"
2204!
2205 TYPE (IO_desc_t), pointer :: ioDesX
2206
2207# include "set_bounds.h"
2208!
2209 sourcefile=myfile
2210!
2211!-----------------------------------------------------------------------
2212! Write out decimate fields.
2213!-----------------------------------------------------------------------
2214!
2215 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2216!
2217! Set time record index.
2218!
2219 xtr(ng)%Rindex=xtr(ng)%Rindex+1
2220 fcount=xtr(ng)%load
2221 xtr(ng)%Nrec(fcount)=xtr(ng)%Nrec(fcount)+1
2222!
2223! Report.
2224!
2225# ifdef SOLVE3D
2226# ifdef NESTING
2227 IF (master) WRITE (stdout,10) kout, nout, xtr(ng)%Rindex, ng
2228# else
2229 IF (master) WRITE (stdout,10) kout, nout, xtr(ng)%Rindex
2230# endif
2231# else
2232# ifdef NESTING
2233 IF (master) WRITE (stdout,10) kout, xtr(ng)%Rindex, ng
2234# else
2235 IF (master) WRITE (stdout,10) kout, xtr(ng)%Rindex
2236# endif
2237# endif
2238!
2239! Write out model time (s).
2240!
2241 CALL pio_netcdf_put_fvar (ng, model, xtr(ng)%name, &
2242 & trim(vname(1,idtime)), time(ng:), &
2243 & (/xtr(ng)%Rindex/), (/1/), &
2244 & piofile = xtr(ng)%pioFile, &
2245 & piovar = xtr(ng)%pioVar(idtime)%vd)
2246 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2247
2248# ifdef WET_DRY
2249!
2250! Write out wet/dry mask at PSI-points.
2251!
2252 scale=1.0_dp
2253 IF (xtr(ng)%pioVar(idpwet)%dkind.eq.pio_double) THEN
2254 iodesx => iodesx_dp_p2dvar(ng)
2255 ELSE
2256 iodesx => iodesx_sp_p2dvar(ng)
2257 END IF
2258 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idpwet, &
2259 & xtr(ng)%pioVar(idpwet), &
2260 & xtr(ng)%Rindex, &
2261 & iodesx, &
2262 & ilb, iub, jlb, jub, scale, &
2263# ifdef MASKING
2264 & extract(ng) % pmask, &
2265# endif
2266 & extract(ng) % pmask_wet, &
2267 & setfillval = .false.)
2268 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2269 IF (master) THEN
2270 WRITE (stdout,20) trim(vname(1,idpwet)), xtr(ng)%Rindex
2271 END IF
2272 exit_flag=3
2273 ioerror=status
2274 RETURN
2275 END IF
2276!
2277! Write out wet/dry mask at RHO-points.
2278!
2279 scale=1.0_dp
2280 IF (xtr(ng)%pioVar(idrwet)%dkind.eq.pio_double) THEN
2281 iodesx => iodesx_dp_r2dvar(ng)
2282 ELSE
2283 iodesx => iodesx_sp_r2dvar(ng)
2284 END IF
2285 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idrwet, &
2286 & xtr(ng)%pioVar(idrwet), &
2287 & xtr(ng)%Rindex, &
2288 & iodesx, &
2289 & ilb, iub, jlb, jub, scale, &
2290# ifdef MASKING
2291 & extract(ng) % rmask, &
2292# endif
2293 & extract(ng) % rmask_wet, &
2294 & setfillval = .false.)
2295 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2296 IF (master) THEN
2297 WRITE (stdout,20) trim(vname(1,idrwet)), xtr(ng)%Rindex
2298 END IF
2299 exit_flag=3
2300 ioerror=status
2301 RETURN
2302 END IF
2303!
2304! Write out wet/dry mask at U-points.
2305!
2306 scale=1.0_dp
2307 IF (xtr(ng)%pioVar(iduwet)%dkind.eq.pio_double) THEN
2308 iodesx => iodesx_dp_u2dvar(ng)
2309 ELSE
2310 iodesx => iodesx_sp_u2dvar(ng)
2311 END IF
2312 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, iduwet, &
2313 & xtr(ng)%pioVar(iduwet), &
2314 & xtr(ng)%Rindex, &
2315 & iodesx, &
2316 & ilb, iub, jlb, jub, scale, &
2317# ifdef MASKING
2318 & extract(ng) % umask, &
2319# endif
2320 & extract(ng) % umask_wet, &
2321 & setfillval = .false.)
2322 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2323 IF (master) THEN
2324 WRITE (stdout,20) trim(vname(1,iduwet)), xtr(ng)%Rindex
2325 END IF
2326 exit_flag=3
2327 ioerror=status
2328 RETURN
2329 END IF
2330!
2331! Write out wet/dry mask at V-points.
2332!
2333 scale=1.0_dp
2334 IF (xtr(ng)%pioVar(idvwet)%dkind.eq.pio_double) THEN
2335 iodesx => iodesx_dp_v2dvar(ng)
2336 ELSE
2337 iodesx => iodesx_sp_v2dvar(ng)
2338 END IF
2339 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvwet, &
2340 & xtr(ng)%pioVar(idvwet), &
2341 & xtr(ng)%Rindex, &
2342 & iodesx, &
2343 & ilb, iub, jlb, jub, scale, &
2344# ifdef MASKING
2345 & extract(ng) % vmask, &
2346# endif
2347 & extract(ng) % vmask_wet, &
2348 & setfillval = .false.)
2349 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2350 IF (master) THEN
2351 WRITE (stdout,20) trim(vname(1,idvwet)), xtr(ng)%Rindex
2352 END IF
2353 exit_flag=3
2354 ioerror=status
2355 RETURN
2356 END IF
2357# endif
2358# ifdef SOLVE3D
2359!
2360! Write time-varying depths of RHO-points.
2361!
2362 IF (hout(idpthr,ng)) THEN
2363 scale=1.0_dp
2364 IF (xtr(ng)%pioVar(idpthr)%dkind.eq.pio_double) THEN
2365 iodesx => iodesx_dp_r3dvar(ng)
2366 ELSE
2367 iodesx => iodesx_sp_r3dvar(ng)
2368 END IF
2369 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idpthr, &
2370 & xtr(ng)%pioVar(idpthr), &
2371 & xtr(ng)%Rindex, &
2372 & iodesx, &
2373 & ilb, iub, jlb, jub, 1, n(ng), scale, &
2374# ifdef MASKING
2375 & extract(ng) % rmask, &
2376# endif
2377 & extract(ng) % z_r, &
2378 & setfillval = .false.)
2379 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2380 IF (master) THEN
2381 WRITE (stdout,20) trim(vname(1,idpthr)), xtr(ng)%Rindex
2382 END IF
2383 exit_flag=3
2384 ioerror=status
2385 RETURN
2386 END IF
2387 END IF
2388!
2389! Write time-varying depths of U-points.
2390!
2391 IF (hout(idpthu,ng)) THEN
2392 scale=1.0_dp
2393 DO k=1,n(ng)
2394 DO j=jstr-1,jend+1
2395 DO i=istru-1,iend+1
2396 extract(ng)%z_v(i,j,k)=0.5_r8* &
2397 & (extract(ng)%z_r(i-1,j,k)+ &
2398 & extract(ng)%z_r(i ,j,k))
2399 END DO
2400 END DO
2401 END DO
2402 IF (xtr(ng)%pioVar(idpthu)%dkind.eq.pio_double) THEN
2403 iodesx => iodesx_dp_u3dvar(ng)
2404 ELSE
2405 iodesx => iodesx_sp_u3dvar(ng)
2406 END IF
2407 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idpthu, &
2408 & xtr(ng)%pioVar(idpthu), &
2409 & xtr(ng)%Rindex, &
2410 & iodesx, &
2411 & ilb, iub, jlb, jub, 1, n(ng), scale, &
2412# ifdef MASKING
2413 & extract(ng) % umask, &
2414# endif
2415 & extract(ng) % z_v, &
2416 & setfillval = .false.)
2417 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2418 IF (master) THEN
2419 WRITE (stdout,20) trim(vname(1,idpthu)), xtr(ng)%Rindex
2420 END IF
2421 exit_flag=3
2422 ioerror=status
2423 RETURN
2424 END IF
2425 END IF
2426!
2427! Write time-varying depths of V-points.
2428!
2429 IF (hout(idpthv,ng)) THEN
2430 scale=1.0_dp
2431 DO k=1,n(ng)
2432 DO j=jstrv-1,jend+1
2433 DO i=istr-1,iend+1
2434 extract(ng)%z_v(i,j,k)=0.5_r8* &
2435 & (extract(ng)%z_r(i,j-1,k)+ &
2436 & extract(ng)%z_r(i,j ,k))
2437 END DO
2438 END DO
2439 END DO
2440 IF (xtr(ng)%pioVar(idpthv)%dkind.eq.pio_double) THEN
2441 iodesx => iodesx_dp_v3dvar(ng)
2442 ELSE
2443 iodesx => iodesx_sp_v3dvar(ng)
2444 END IF
2445 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idpthv, &
2446 & xtr(ng)%pioVar(idpthv), &
2447 & xtr(ng)%Rindex, &
2448 & iodesx, &
2449 & ilb, iub, jlb, jub, 1, n(ng), scale, &
2450# ifdef MASKING
2451 & extract(ng) % vmask, &
2452# endif
2453 & extract(ng) % z_v, &
2454 & setfillval = .false.)
2455 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2456 IF (master) THEN
2457 WRITE (stdout,20) trim(vname(1,idpthv)), xtr(ng)%Rindex
2458 END IF
2459 exit_flag=3
2460 ioerror=status
2461 RETURN
2462 END IF
2463 END IF
2464!
2465! Write time-varying depths of W-points.
2466!
2467 IF (hout(idpthw,ng)) THEN
2468 scale=1.0_dp
2469 IF (xtr(ng)%pioVar(idpthw)%dkind.eq.pio_double) THEN
2470 iodesx => iodesx_dp_w3dvar(ng)
2471 ELSE
2472 iodesx => iodesx_sp_w3dvar(ng)
2473 END IF
2474 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idpthw, &
2475 & xtr(ng)%pioVar(idpthw), &
2476 & xtr(ng)%Rindex, &
2477 & iodesx, &
2478 & ilb, iub, jlb, jub, 0, n(ng), scale, &
2479# ifdef MASKING
2480 & extract(ng) % rmask, &
2481# endif
2482 & extract(ng) % z_w, &
2483 & setfillval = .false.)
2484 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2485 IF (master) THEN
2486 WRITE (stdout,20) trim(vname(1,idpthw)), xtr(ng)%Rindex
2487 END IF
2488 exit_flag=3
2489 ioerror=status
2490 RETURN
2491 END IF
2492 END IF
2493# endif
2494!
2495! Write out free-surface (m)
2496!
2497 IF (hout(idfsur,ng)) THEN
2498 scale=1.0_dp
2499 IF (xtr(ng)%pioVar(idfsur)%dkind.eq.pio_double) THEN
2500 iodesx => iodesx_dp_r2dvar(ng)
2501 ELSE
2502 iodesx => iodesx_sp_r2dvar(ng)
2503 END IF
2504 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idfsur, &
2505 & xtr(ng)%pioVar(idfsur), &
2506 & xtr(ng)%Rindex, &
2507 & iodesx, &
2508 & lbi, ubi, lbj, ubj, scale, &
2509# ifdef MASKING
2510 & grid(ng) % rmask, &
2511# endif
2512 & ocean(ng) % zeta(:,:,kout), &
2513 & setfillval = .false., &
2514 & extractfield = extractflag(ng))
2515 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2516 IF (master) THEN
2517 WRITE (stdout,20) trim(vname(1,idfsur)), xtr(ng)%Rindex
2518 END IF
2519 exit_flag=3
2520 ioerror=status
2521 RETURN
2522 END IF
2523
2524# if defined FORWARD_WRITE && defined FORWARD_RHS
2525!
2526 IF (xtr(ng)%pioVar(idrzet)%dkind.eq.pio_double) THEN
2527 iodesx => iodesx_dp_r2dvar(ng)
2528 ELSE
2529 iodesx => iodesx_sp_r2dvar(ng)
2530 END IF
2531 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idrzet, &
2532 & xtr(ng)%pioVar(idrzet), &
2533 & xtr(ng)%Rindex, &
2534 & iodesx, &
2535 & lbi, ubi, lbj, ubj, scale, &
2536# ifdef MASKING
2537 & grid(ng) % rmask, &
2538# endif
2539 & ocean(ng) % rzeta(:,:,kout), &
2540 & setfillval = .false., &
2541 & extractfield = extractflag(ng))
2542 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2543 IF (master) THEN
2544 WRITE (stdout,20) trim(vname(1,idrzet)), xtr(ng)%Rindex
2545 END IF
2546 exit_flag=3
2547 ioerror=status
2548 RETURN
2549 END IF
2550# endif
2551 END IF
2552
2553# ifdef ADJUST_BOUNDARY
2554!
2555! Write out free-surface open boundaries.
2556!
2557 IF (any(lobc(:,isfsur,ng))) THEN
2558 scale=1.0_dp
2559 IF (xtr(ng)%pioVar(idsbry(isfsur))%dkind.eq.pio_double) THEN
2560 iodesx => iodesx_dp_r2dobc(ng)
2561 ELSE
2562 iodesx => iodesx_sp_r2dobc(ng)
2563 END IF
2564 status=nf_fwrite2d_bry(ng, model, xtr(ng)%name, &
2565 & xtr(ng)%pioFile, &
2566 & vname(1,idsbry(isfsur)), &
2567 & xtr(ng)%pioVar(idsbry(isfsur)), &
2568 & xtr(ng)%Rindex, &
2569 & iodesx, &
2570 & lbij, ubij, nbrec(ng), scale, &
2571 & boundary(ng) % zeta_obc(lbij:,:,:, &
2572 & lbout(ng)), &
2573 & extractfield = extractflag(ng))
2574 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2575 IF (master) THEN
2576 WRITE (stdout,20) trim(vname(1,idsbry(isfsur))), &
2577 & xtr(ng)%Rindex
2578 END IF
2579 exit_flag=3
2580 ioerror=status
2581 RETURN
2582 END IF
2583 END IF
2584# endif
2585!
2586! Write out 2D U-momentum component (m/s).
2587!
2588 IF (hout(idubar,ng)) THEN
2589 scale=1.0_dp
2590 IF (xtr(ng)%pioVar(idubar)%dkind.eq.pio_double) THEN
2591 iodesx => iodesx_dp_u2dvar(ng)
2592 ELSE
2593 iodesx => iodesx_sp_u2dvar(ng)
2594 END IF
2595 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idubar, &
2596 & xtr(ng)%pioVar(idubar), &
2597 & xtr(ng)%Rindex, &
2598 & iodesx, &
2599 & lbi, ubi, lbj, ubj, scale, &
2600# ifdef MASKING
2601 & grid(ng) % umask_full, &
2602# endif
2603 & ocean(ng) % ubar(:,:,kout), &
2604 & setfillval = .false., &
2605 & extractfield = extractflag(ng))
2606 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2607 IF (master) THEN
2608 WRITE (stdout,20) trim(vname(1,idubar)), xtr(ng)%Rindex
2609 END IF
2610 exit_flag=3
2611 ioerror=status
2612 RETURN
2613 END IF
2614
2615# ifdef FORWARD_WRITE
2616# ifdef FORWARD_RHS
2617!
2618 IF (xtr(ng)%pioVar(idru2d)%dkind.eq.pio_double) THEN
2619 iodesx => iodesx_dp_u2dvar(ng)
2620 ELSE
2621 iodesx => iodesx_sp_u2dvar(ng)
2622 END IF
2623 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idru2d, &
2624 & xtr(ng)%pioVar(idru2d), &
2625 & xtr(ng)%Rindex, &
2626 & iodesx, &
2627 & lbi, ubi, lbj, ubj, scale, &
2628# ifdef MASKING
2629 & grid(ng) % umask_full, &
2630# endif
2631 & ocean(ng) % rubar(:,:,kout), &
2632 & setfillval = .false., &
2633 & extractfield = extractflag(ng))
2634 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2635 IF (master) THEN
2636 WRITE (stdout,20) trim(vname(1,idru2d)), xtr(ng)%Rindex
2637 END IF
2638 exit_flag=3
2639 ioerror=status
2640 RETURN
2641 END IF
2642# endif
2643# ifdef SOLVE3D
2644# ifdef FORWARD_RHS
2645!
2646 IF (xtr(ng)%pioVar(idruct)%dkind.eq.pio_double) THEN
2647 iodesx => iodesx_dp_u2dvar(ng)
2648 ELSE
2649 iodesx => iodesx_sp_u2dvar(ng)
2650 END IF
2651 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idruct, &
2652 & xtr(ng)%pioVar(idruct), &
2653 & xtr(ng)%Rindex, &
2654 & iodesx, &
2655 & lbi, ubi, lbj, ubj, scale, &
2656# ifdef MASKING
2657 & grid(ng) % umask_full, &
2658# endif
2659 & coupling(ng) % rufrc, &
2660 & setfillval = .false., &
2661 & extractfield = extractflag(ng))
2662 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2663 IF (master) THEN
2664 WRITE (stdout,20) trim(vname(1,idruct)), xtr(ng)%Rindex
2665 END IF
2666 exit_flag=3
2667 ioerror=status
2668 RETURN
2669 END IF
2670# endif
2671!
2672 IF (xtr(ng)%pioVar(idufx1)%dkind.eq.pio_double) THEN
2673 iodesx => iodesx_dp_u2dvar(ng)
2674 ELSE
2675 iodesx => iodesx_sp_u2dvar(ng)
2676 END IF
2677 IF (.not.allocated(ur2d)) THEN
2678 allocate (ur2d(lbi:ubi,lbj:ubj))
2679 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
2680 END IF
2681 ur2d=extractflag(ng)*coupling(ng)%DU_avg1
2682 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idufx1, &
2683 & xtr(ng)%pioVar(idufx1), &
2684 & xtr(ng)%Rindex, &
2685 & iodesx, &
2686 & lbi, ubi, lbj, ubj, scale, &
2687# ifdef MASKING
2688 & grid(ng) % umask_full, &
2689# endif
2690 & ur2d, &
2691 & setfillval = .false., &
2692 & extractfield = extractflag(ng))
2693 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2694 IF (master) THEN
2695 WRITE (stdout,20) trim(vname(1,idufx1)), xtr(ng)%Rindex
2696 END IF
2697 exit_flag=3
2698 ioerror=status
2699 RETURN
2700 END IF
2701!
2702 IF (xtr(ng)%pioVar(idufx2)%dkind.eq.pio_double) THEN
2703 iodesx => iodesx_dp_u2dvar(ng)
2704 ELSE
2705 iodesx => iodesx_sp_u2dvar(ng)
2706 END IF
2707 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
2708 ur2d=extractflag(ng)*coupling(ng)%DU_avg2
2709 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idufx2, &
2710 & xtr(ng)%pioVar(idufx2), &
2711 & xtr(ng)%Rindex, &
2712 & iodesx, &
2713 & lbi, ubi, lbj, ubj, scale, &
2714# ifdef MASKING
2715 & grid(ng) % umask_full, &
2716# endif
2717 & coupling(ng) % DU_avg2, &
2718 & setfillval = .false., &
2719 & extractfield = extractflag(ng))
2720 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2721 IF (master) THEN
2722 WRITE (stdout,20) trim(vname(1,idufx2)), xtr(ng)%Rindex
2723 END IF
2724 exit_flag=3
2725 ioerror=status
2726 RETURN
2727 END IF
2728 deallocate (ur2d)
2729# endif
2730# endif
2731 END IF
2732
2733# ifdef ADJUST_BOUNDARY
2734!
2735! Write out 2D U-momentum component open boundaries.
2736!
2737 IF (any(lobc(:,isubar,ng))) THEN
2738 scale=1.0_dp
2739 IF (xtr(ng)%pioVar(idsbry(isubar))%dkind.eq.pio_double) THEN
2740 iodesx => iodesx_dp_u2dobc(ng)
2741 ELSE
2742 iodesx => iodesx_sp_u2dobc(ng)
2743 END IF
2744 status=nf_fwrite2d_bry(ng, model, xtr(ng)%name, &
2745 & xtr(ng)%pioFile, &
2746 & vname(1,idsbry(isubar)), &
2747 & xtr(ng)%pioVar(idsbry(isubar)), &
2748 & xtr(ng)%Rindex, &
2749 & iodesx, &
2750 & lbij, ubij, nbrec(ng), scale, &
2751 & boundary(ng) % ubar_obc(lbij:,:,:, &
2752 & lbout(ng)), &
2753 & extractfield = extractflag(ng))
2754 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2755 IF (master) THEN
2756 WRITE (stdout,20) trim(vname(1,idsbry(isubar))), &
2757 & xtr(ng)%Rindex
2758 END IF
2759 exit_flag=3
2760 ioerror=status
2761 RETURN
2762 END IF
2763 END IF
2764# endif
2765!
2766! Write out 2D V-momentum component (m/s).
2767!
2768 IF (hout(idvbar,ng)) THEN
2769 scale=1.0_dp
2770 IF (xtr(ng)%pioVar(idvbar)%dkind.eq.pio_double) THEN
2771 iodesx => iodesx_dp_v2dvar(ng)
2772 ELSE
2773 iodesx => iodesx_sp_v2dvar(ng)
2774 END IF
2775 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvbar, &
2776 & xtr(ng)%pioVar(idvbar), &
2777 & xtr(ng)%Rindex, &
2778 & iodesx, &
2779 & lbi, ubi, lbj, ubj, scale, &
2780# ifdef MASKING
2781 & grid(ng) % vmask_full, &
2782# endif
2783 & ocean(ng) % vbar(:,:,kout), &
2784 & setfillval = .false., &
2785 & extractfield = extractflag(ng))
2786 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2787 IF (master) THEN
2788 WRITE (stdout,20) trim(vname(1,idvbar)), xtr(ng)%Rindex
2789 END IF
2790 exit_flag=3
2791 ioerror=status
2792 RETURN
2793 END IF
2794
2795# ifdef FORWARD_WRITE
2796# ifdef FORWARD_RHS
2797!
2798 IF (xtr(ng)%pioVar(idrv2d)%dkind.eq.pio_double) THEN
2799 iodesx => iodesx_dp_v2dvar(ng)
2800 ELSE
2801 iodesx => iodesx_sp_v2dvar(ng)
2802 END IF
2803 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idrv2d, &
2804 & xtr(ng)%pioVar(idrv2d), &
2805 & xtr(ng)%Rindex, &
2806 & iodesx, &
2807 & lbi, ubi, lbj, ubj, scale, &
2808# ifdef MASKING
2809 & grid(ng) % vmask_full, &
2810# endif
2811 & ocean(ng) % rvbar(:,:,kout), &
2812 & setfillval = .false., &
2813 & extractfield = extractflag(ng))
2814 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2815 IF (master) THEN
2816 WRITE (stdout,20) trim(vname(1,idrv2d)), xtr(ng)%Rindex
2817 END IF
2818 exit_flag=3
2819 ioerror=status
2820 RETURN
2821 END IF
2822# endif
2823# ifdef SOLVE3D
2824# ifdef FORWARD_RHS
2825!
2826 IF (xtr(ng)%pioVar(idrvct)%dkind.eq.pio_double) THEN
2827 iodesx => iodesx_dp_v2dvar(ng)
2828 ELSE
2829 iodesx => iodesx_sp_v2dvar(ng)
2830 END IF
2831 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idrvct, &
2832 & xtr(ng)%pioVar(idrvct), &
2833 & xtr(ng)%Rindex, &
2834 & iodesx, &
2835 & lbi, ubi, lbj, ubj, scale, &
2836# ifdef MASKING
2837 & grid(ng) % vmask_full, &
2838# endif
2839 & coupling(ng) % rvfrc, &
2840 & setfillval = .false., &
2841 & extractfield = extractflag(ng))
2842 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2843 IF (master) THEN
2844 WRITE (stdout,20) trim(vname(1,idrvct)), xtr(ng)%Rindex
2845 END IF
2846 exit_flag=3
2847 ioerror=status
2848 RETURN
2849 END IF
2850# endif
2851!
2852 IF (xtr(ng)%pioVar(idvfx1)%dkind.eq.pio_double) THEN
2853 iodesx => iodesx_dp_v2dvar(ng)
2854 ELSE
2855 iodesx => iodesx_sp_v2dvar(ng)
2856 END IF
2857 IF (.not.allocated(vr2d)) THEN
2858 allocate (vr2d(lbi:ubi,lbj:ubj))
2859 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
2860 END IF
2861 vr2d=extractflag(ng)*coupling(ng)%DV_avg1
2862 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvfx1, &
2863 & xtr(ng)%pioVar(idvfx1), &
2864 & xtr(ng)%Rindex, &
2865 & iodesx, &
2866 & lbi, ubi, lbj, ubj, scale, &
2867# ifdef MASKING
2868 & grid(ng) % vmask_full, &
2869# endif
2870 & vr2d, &
2871 & setfillval = .false., &
2872 & extractfield = extractflag(ng))
2873 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2874 IF (master) THEN
2875 WRITE (stdout,20) trim(vname(1,idvfx1)), xtr(ng)%Rindex
2876 END IF
2877 exit_flag=3
2878 ioerror=status
2879 RETURN
2880 END IF
2881!
2882 IF (xtr(ng)%pioVar(idvfx2)%dkind.eq.pio_double) THEN
2883 iodesx => iodesx_dp_v2dvar(ng)
2884
2885 ELSE
2886 iodesx => iodesx_sp_v2dvar(ng)
2887 END IF
2888 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
2889 vr2d=extractflag(ng)*coupling(ng)%DV_avg2
2890 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvfx2, &
2891 & xtr(ng)%pioVar(idvfx2), &
2892 & xtr(ng)%Rindex, &
2893 & iodesx, &
2894 & lbi, ubi, lbj, ubj, scale, &
2895# ifdef MASKING
2896 & grid(ng) % vmask_full, &
2897# endif
2898 & vr2d, &
2899 & setfillval = .false., &
2900 & extractfield = extractflag(ng))
2901 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2902 IF (master) THEN
2903 WRITE (stdout,20) trim(vname(1,idvfx2)), xtr(ng)%Rindex
2904 END IF
2905 exit_flag=3
2906 ioerror=status
2907 RETURN
2908 END IF
2909 deallocate (vr2d)
2910# endif
2911# endif
2912 END IF
2913
2914# ifdef ADJUST_BOUNDARY
2915!
2916! Write out 2D V-momentum component open boundaries.
2917!
2918 IF (any(lobc(:,isvbar,ng))) THEN
2919 scale=1.0_dp
2920 IF (xtr(ng)%pioVar(idsbry(isvbar))%dkind.eq.pio_double) THEN
2921 iodesx => iodesx_dp_v2dobc(ng)
2922 ELSE
2923 iodesx => iodesx_sp_v2dobc(ng)
2924 END IF
2925 status=nf_fwrite2d_bry(ng, model, xtr(ng)%name, &
2926 & xtr(ng)%pioFile, &
2927 & vname(1,idsbry(isvbar)), &
2928 & xtr(ng)%pioVar(idsbry(isvbar)), &
2929 & xtr(ng)%Rindex, &
2930 & iodesx, &
2931 & lbij, ubij, nbrec(ng), scale, &
2932 & boundary(ng) % vbar_obc(lbij:,:,:, &
2933 & lbout(ng)), &
2934 & extractfield = extractflag(ng))
2935 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2936 IF (master) THEN
2937 WRITE (stdout,20) trim(vname(1,idsbry(isvbar))), &
2938 & xtr(ng)%Rindex
2939 END IF
2940 exit_flag=3
2941 ioerror=status
2942 RETURN
2943 END IF
2944 END IF
2945# endif
2946!
2947! Write out 2D Eastward and Northward momentum components (m/s) at
2948! RHO-points.
2949!
2950 IF (hout(idu2de,ng).and.hout(idv2dn,ng)) THEN
2951 IF (.not.allocated(ur2d)) THEN
2952 allocate (ur2d(lbi:ubi,lbj:ubj))
2953 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
2954 END IF
2955 IF (.not.allocated(vr2d)) THEN
2956 allocate (vr2d(lbi:ubi,lbj:ubj))
2957 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
2958 END IF
2959 CALL uv_rotate2d (ng, tile, .false., .true., &
2960 & lbi, ubi, lbj, ubj, &
2961 & grid(ng) % CosAngler, &
2962 & grid(ng) % SinAngler, &
2963# ifdef MASKING
2964 & grid(ng) % rmask_full, &
2965# endif
2966 & ocean(ng) % ubar(:,:,kout), &
2967 & ocean(ng) % vbar(:,:,kout), &
2968 & ur2d, vr2d)
2969!
2970 scale=1.0_dp
2971 IF (xtr(ng)%pioVar(idu2de)%dkind.eq.pio_double) THEN
2972 iodesx => iodesx_dp_r2dvar(ng)
2973 ELSE
2974 iodesx => iodesx_sp_r2dvar(ng)
2975 END IF
2976 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idu2de, &
2977 & xtr(ng)%pioVar(idu2de), &
2978 & xtr(ng)%Rindex, &
2979 & iodesx, &
2980 & lbi, ubi, lbj, ubj, scale, &
2981# ifdef MASKING
2982 & grid(ng) % rmask_full, &
2983# endif
2984 & ur2d, &
2985 & setfillval = .false., &
2986 & extractfield = extractflag(ng))
2987 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2988 IF (master) THEN
2989 WRITE (stdout,20) trim(vname(1,idu2de)), xtr(ng)%Rindex
2990 END IF
2991 exit_flag=3
2992 ioerror=status
2993 RETURN
2994 END IF
2995!
2996 IF (xtr(ng)%pioVar(idv2dn)%dkind.eq.pio_double) THEN
2997 iodesx => iodesx_dp_r2dvar(ng)
2998 ELSE
2999 iodesx => iodesx_sp_r2dvar(ng)
3000 END IF
3001 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idv2dn, &
3002 & xtr(ng)%pioVar(idv2dn), &
3003 & xtr(ng)%Rindex, &
3004 & iodesx, &
3005 & lbi, ubi, lbj, ubj, scale, &
3006# ifdef MASKING
3007 & grid(ng) % rmask_full, &
3008# endif
3009 & vr2d, &
3010 & setfillval = .false., &
3011 & extractfield = extractflag(ng))
3012 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3013 IF (master) THEN
3014 WRITE (stdout,20) trim(vname(1,idv2dn)), xtr(ng)%Rindex
3015 END IF
3016 exit_flag=3
3017 ioerror=status
3018 RETURN
3019 END IF
3020 deallocate (ur2d)
3021 deallocate (vr2d)
3022 END IF
3023
3024# ifdef SOLVE3D
3025!
3026! Write out 3D U-momentum component (m/s).
3027!
3028 IF (hout(iduvel,ng)) THEN
3029 scale=1.0_dp
3030 IF (xtr(ng)%pioVar(iduvel)%dkind.eq.pio_double) THEN
3031 iodesx => iodesx_dp_u3dvar(ng)
3032 ELSE
3033 iodesx => iodesx_sp_u3dvar(ng)
3034 END IF
3035 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, iduvel, &
3036 & xtr(ng)%pioVar(iduvel), &
3037 & xtr(ng)%Rindex, &
3038 & iodesx, &
3039 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3040# ifdef MASKING
3041 & grid(ng) % umask_full, &
3042# endif
3043 & ocean(ng) % u(:,:,:,nout), &
3044 & setfillval = .false., &
3045 & extractfield = extractflag(ng))
3046 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3047 IF (master) THEN
3048 WRITE (stdout,20) trim(vname(1,iduvel)), xtr(ng)%Rindex
3049 END IF
3050 exit_flag=3
3051 ioerror=status
3052 RETURN
3053 END IF
3054
3055# if defined FORWARD_WRITE && defined FORWARD_RHS
3056!
3057 IF (xtr(ng)%pioVar(idru3d)%dkind.eq.pio_double) THEN
3058 iodesx => iodesx_dp_u3dvar(ng)
3059 ELSE
3060 iodesx => iodesx_sp_u3dvar(ng)
3061 END IF
3062 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idru3d, &
3063 & xtr(ng)%pioVar(idru3d), &
3064 & xtr(ng)%Rindex, &
3065 & iodesx, &
3066 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3067# ifdef MASKING
3068 & grid(ng) % umask_full, &
3069# endif
3070 & ocean(ng) % ru(:,:,:,nout), &
3071 & setfillval = .false., &
3072 & extractfield = extractflag(ng))
3073 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3074 IF (master) THEN
3075 WRITE (stdout,20) trim(vname(1,idru3d)), xtr(ng)%Rindex
3076 END IF
3077 exit_flag=3
3078 ioerror=status
3079 RETURN
3080 END IF
3081# endif
3082 END IF
3083
3084# ifdef ADJUST_BOUNDARY
3085!
3086! Write out 3D U-momentum component open boundaries.
3087!
3088 IF (any(lobc(:,isuvel,ng))) THEN
3089 scale=1.0_dp
3090 IF (xtr(ng)%pioVar(idsbry(isuvel))%dkind.eq.pio_double) THEN
3091 iodesx => iodesx_dp_u3dobc(ng)
3092 ELSE
3093 iodesx => iodesx_sp_u3dobc(ng)
3094 END IF
3095 status=nf_fwrite3d_bry(ng, model, xtr(ng)%name, &
3096 & xtr(ng)%pioFile, &
3097 & vname(1,idsbry(isuvel)), &
3098 & xtr(ng)%pioVar(idsbry(isuvel)), &
3099 & xtr(ng)%Rindex, &
3100 & iodesx, &
3101 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
3102 & boundary(ng) % u_obc(lbij:,:,:,:, &
3103 & lbout(ng)), &
3104 & extractfield = extractflag(ng))
3105 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3106 IF (master) THEN
3107 WRITE (stdout,20) trim(vname(1,idsbry(isuvel))), &
3108 & xtr(ng)%Rindex
3109 END IF
3110 exit_flag=3
3111 ioerror=status
3112 RETURN
3113 END IF
3114 END IF
3115# endif
3116!
3117! Write out 3D V-momentum component (m/s).
3118!
3119 IF (hout(idvvel,ng)) THEN
3120 scale=1.0_dp
3121 IF (xtr(ng)%pioVar(idvvel)%dkind.eq.pio_double) THEN
3122 iodesx => iodesx_dp_v3dvar(ng)
3123 ELSE
3124 iodesx => iodesx_sp_v3dvar(ng)
3125 END IF
3126 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idvvel, &
3127 & xtr(ng)%pioVar(idvvel), &
3128 & xtr(ng)%Rindex, &
3129 & iodesx, &
3130 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3131# ifdef MASKING
3132 & grid(ng) % vmask_full, &
3133# endif
3134 & ocean(ng) % v(:,:,:,nout), &
3135 & setfillval = .false., &
3136 & extractfield = extractflag(ng))
3137 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3138 IF (master) THEN
3139 WRITE (stdout,20) trim(vname(1,idvvel)), xtr(ng)%Rindex
3140 END IF
3141 exit_flag=3
3142 ioerror=status
3143 RETURN
3144 END IF
3145
3146# if defined FORWARD_WRITE && defined FORWARD_RHS
3147!
3148 IF (xtr(ng)%pioVar(idrv3d)%dkind.eq.pio_double) THEN
3149 iodesx => iodesx_dp_v3dvar(ng)
3150 ELSE
3151 iodesx => iodesx_sp_v3dvar(ng)
3152 END IF
3153 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idrv3d, &
3154 & xtr(ng)%pioVar(idrv3d), &
3155 & xtr(ng)%Rindex, &
3156 & iodesx, &
3157 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3158# ifdef MASKING
3159 & grid(ng) % vmask_full, &
3160# endif
3161 & ocean(ng) % rv(:,:,:,nout), &
3162 & setfillval = .false., &
3163 & extractfield = extractflag(ng))
3164 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3165 IF (master) THEN
3166 WRITE (stdout,20) trim(vname(1,idrv3d)), xtr(ng)%Rindex
3167 END IF
3168 exit_flag=3
3169 ioerror=status
3170 RETURN
3171 END IF
3172# endif
3173 END IF
3174
3175# ifdef ADJUST_BOUNDARY
3176!
3177! Write out 3D V-momentum component open boundaries.
3178!
3179 IF (any(lobc(:,isvvel,ng))) THEN
3180 scale=1.0_dp
3181 IF (xtr(ng)%pioVar(idsbry(isvvel))%dkind.eq.pio_double) THEN
3182 iodesx => iodesx_dp_v3dobc(ng)
3183 ELSE
3184 iodesx => iodesx_sp_v3dobc(ng)
3185 END IF
3186 status=nf_fwrite3d_bry(ng, model, xtr(ng)%name, &
3187 & xtr(ng)%pioFile, &
3188 & vname(1,idsbry(isvvel)), &
3189 & xtr(ng)%pioVar(idsbry(isvvel)), &
3190 & xtr(ng)%Rindex, &
3191 & iodesx, &
3192 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
3193 & boundary(ng) % v_obc(lbij:,:,:,:, &
3194 & lbout(ng)), &
3195 & extractfield = extractflag(ng))
3196 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3197 IF (master) THEN
3198 WRITE (stdout,20) trim(vname(1,idsbry(isvvel))), &
3199 & xtr(ng)%Rindex
3200 END IF
3201 exit_flag=3
3202 ioerror=status
3203 RETURN
3204 END IF
3205 END IF
3206# endif
3207!
3208! Write out 3D Eastward and Northward momentum components (m/s) at
3209! RHO-points.
3210!
3211 IF (hout(idu3de,ng).and.hout(idv3dn,ng)) THEN
3212 IF (.not.allocated(ur3d)) THEN
3213 allocate (ur3d(lbi:ubi,lbj:ubj,n(ng)))
3214 ur3d(lbi:ubi,lbj:ubj,1:n(ng))=0.0_r8
3215 END IF
3216 IF (.not.allocated(vr3d)) THEN
3217 allocate (vr3d(lbi:ubi,lbj:ubj,n(ng)))
3218 vr3d(lbi:ubi,lbj:ubj,1:n(ng))=0.0_r8
3219 END IF
3220 CALL uv_rotate3d (ng, tile, .false., .true., &
3221 & lbi, ubi, lbj, ubj, 1, n(ng), &
3222 & grid(ng) % CosAngler, &
3223 & grid(ng) % SinAngler, &
3224# ifdef MASKING
3225 & grid(ng) % rmask_full, &
3226# endif
3227 & ocean(ng) % u(:,:,:,nout), &
3228 & ocean(ng) % v(:,:,:,nout), &
3229 & ur3d, vr3d)
3230!
3231 scale=1.0_dp
3232 IF (xtr(ng)%pioVar(idu3de)%dkind.eq.pio_double) THEN
3233 iodesx => iodesx_dp_r3dvar(ng)
3234 ELSE
3235 iodesx => iodesx_sp_r3dvar(ng)
3236 END IF
3237 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idu3de, &
3238 & xtr(ng)%pioVar(idu3de), &
3239 & xtr(ng)%Rindex, &
3240 & iodesx, &
3241 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3242# ifdef MASKING
3243 & grid(ng) % rmask_full, &
3244# endif
3245 & ur3d, &
3246 & setfillval = .false., &
3247 & extractfield = extractflag(ng))
3248 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3249 IF (master) THEN
3250 WRITE (stdout,20) trim(vname(1,idu3de)), xtr(ng)%Rindex
3251 END IF
3252 exit_flag=3
3253 ioerror=status
3254 RETURN
3255 END IF
3256!
3257 IF (xtr(ng)%pioVar(idv3dn)%dkind.eq.pio_double) THEN
3258 iodesx => iodesx_dp_r3dvar(ng)
3259 ELSE
3260 iodesx => iodesx_sp_r3dvar(ng)
3261 END IF
3262 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idv3dn, &
3263 & xtr(ng)%pioVar(idv3dn), &
3264 & xtr(ng)%Rindex, &
3265 & iodesx, &
3266 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3267# ifdef MASKING
3268 & grid(ng) % rmask_full, &
3269# endif
3270 & vr3d, &
3271 & setfillval = .false., &
3272 & extractfield = extractflag(ng))
3273 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3274 IF (master) THEN
3275 WRITE (stdout,20) trim(vname(1,idv3dn)), xtr(ng)%Rindex
3276 END IF
3277 exit_flag=3
3278 ioerror=status
3279 RETURN
3280 END IF
3281 deallocate (ur3d)
3282 deallocate (vr3d)
3283 END IF
3284!
3285! Write out S-coordinate omega vertical velocity (m/s).
3286!
3287 IF (hout(idovel,ng)) THEN
3288 IF (.not.allocated(wr3d)) THEN
3289 allocate (wr3d(lbi:ubi,lbj:ubj,0:n(ng)))
3290 wr3d(lbi:ubi,lbj:ubj,0:n(ng))=0.0_r8
3291 END IF
3292 scale=1.0_dp
3293 CALL scale_omega (ng, tile, lbi, ubi, lbj, ubj, 0, n(ng), &
3294 & grid(ng) % pm, &
3295 & grid(ng) % pn, &
3296 & ocean(ng) % W, &
3297 & wr3d)
3298!
3299 IF (xtr(ng)%pioVar(idovel)%dkind.eq.pio_double) THEN
3300 iodesx => iodesx_dp_w3dvar(ng)
3301 ELSE
3302 iodesx => iodesx_sp_w3dvar(ng)
3303 END IF
3304 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idovel, &
3305 & xtr(ng)%pioVar(idovel), &
3306 & xtr(ng)%Rindex, &
3307 & iodesx, &
3308 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3309# ifdef MASKING
3310 & grid(ng) % rmask, &
3311# endif
3312 & wr3d, &
3313 & setfillval = .false., &
3314 & extractfield = extractflag(ng))
3315 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3316 IF (master) THEN
3317 WRITE (stdout,20) trim(vname(1,idovel)), xtr(ng)%Rindex
3318 END IF
3319 exit_flag=3
3320 ioerror=status
3321 RETURN
3322 END IF
3323 deallocate (wr3d)
3324 END IF
3325
3326# ifdef OMEGA_IMPLICIT
3327!
3328! Write out S-coordinate implicit omega vertical velocity (m/s).
3329!
3330 IF (hout(idovil,ng)) THEN
3331 IF (.not.allocated(wr3d)) THEN
3332 allocate (wr3d(lbi:ubi,lbj:ubj,0:n(ng)))
3333 wr3d(lbi:ubi,lbj:ubj,0:n(ng))=0.0_r8
3334 END IF
3335 scale=1.0_dp
3336 CALL scale_omega (ng, tile, lbi, ubi, lbj, ubj, 0, n(ng), &
3337 & grid(ng) % pm, &
3338 & grid(ng) % pn, &
3339 & ocean(ng) % Wi, &
3340 & wr3d)
3341!
3342 IF (xtr(ng)%pioVar(idovil)%dkind.eq.pio_double) THEN
3343 iodesx => iodesx_dp_w3dvar(ng)
3344 ELSE
3345 iodesx => iodesx_sp_w3dvar(ng)
3346 END IF
3347 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idovil, &
3348 & xtr(ng)%pioVar(idovil), &
3349 & xtr(ng)%Rindex, &
3350 & iodesx, &
3351 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3352# ifdef MASKING
3353 & grid(ng) % rmask, &
3354# endif
3355 & wr3d, &
3356 & setfillval = .false., &
3357 & extractfield = extractflag(ng))
3358 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3359 IF (master) THEN
3360 WRITE (stdout,20) trim(vname(1,idovil)), xtr(ng)%Rindex
3361 END IF
3362 exit_flag=3
3363 ioerror=status
3364 RETURN
3365 END IF
3366 deallocate (wr3d)
3367 END IF
3368# endif
3369!
3370! Write out vertical velocity (m/s).
3371!
3372 IF (hout(idwvel,ng)) THEN
3373 scale=1.0_dp
3374 IF (xtr(ng)%pioVar(idwvel)%dkind.eq.pio_double) THEN
3375 iodesx => iodesx_dp_w3dvar(ng)
3376 ELSE
3377 iodesx => iodesx_sp_w3dvar(ng)
3378 END IF
3379 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idwvel, &
3380 & xtr(ng)%pioVar(idwvel), &
3381 & xtr(ng)%Rindex, &
3382 & iodesx, &
3383 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3384# ifdef MASKING
3385 & grid(ng) % rmask, &
3386# endif
3387 & ocean(ng) % wvel, &
3388 & setfillval = .false., &
3389 & extractfield = extractflag(ng))
3390 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3391 IF (master) THEN
3392 WRITE (stdout,20) trim(vname(1,idwvel)), xtr(ng)%Rindex
3393 END IF
3394 exit_flag=3
3395 ioerror=status
3396 RETURN
3397 END IF
3398 END IF
3399!
3400! Write out tracer type variables.
3401!
3402 DO itrc=1,nt(ng)
3403 IF (hout(idtvar(itrc),ng)) THEN
3404 scale=1.0_dp
3405 IF (xtr(ng)%pioTrc(itrc)%dkind.eq.pio_double) THEN
3406 iodesx => iodesx_dp_r3dvar(ng)
3407 ELSE
3408 iodesx => iodesx_sp_r3dvar(ng)
3409 END IF
3410 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idtvar(itrc), &
3411 & xtr(ng)%pioTrc(itrc), &
3412 & xtr(ng)%Rindex, &
3413 & iodesx, &
3414 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3415# ifdef MASKING
3416 & grid(ng) % rmask, &
3417# endif
3418 & ocean(ng) % t(:,:,:,nout,itrc), &
3419 & setfillval = .false., &
3420 & extractfield = extractflag(ng))
3421 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3422 IF (master) THEN
3423 WRITE (stdout,20) trim(vname(1,idtvar(itrc))), &
3424 & xtr(ng)%Rindex
3425 END IF
3426 exit_flag=3
3427 ioerror=status
3428 RETURN
3429 END IF
3430 END IF
3431 END DO
3432
3433# ifdef ADJUST_BOUNDARY
3434!
3435! Write out 3D tracers open boundaries.
3436!
3437 DO itrc=1,nt(ng)
3438 IF (any(lobc(:,istvar(itrc),ng))) THEN
3439 scale=1.0_dp
3440 ifield=idsbry(istvar(itrc))
3441 IF (xtr(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
3442 iodesx => iodesx_dp_r3dobc(ng)
3443 ELSE
3444 iodesx => iodesx_sp_r3dobc(ng)
3445 END IF
3446 status=nf_fwrite3d_bry(ng, model, xtr(ng)%name, &
3447 & xtr(ng)%pioFile, &
3448 & vname(1,ifield), &
3449 & xtr(ng)%pioVar(ifield), &
3450 & xtr(ng)%Rindex, &
3451 & iodesx, &
3452 & lbij, ubij, 1, n(ng), nbrec(ng), &
3453 & scale, &
3454 & boundary(ng) % t_obc(lbij:,:,:,:, &
3455 & lbout(ng),itrc), &
3456 & extractfield = extractflag(ng))
3457 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3458 IF (master) THEN
3459 WRITE (stdout,20) trim(vname(1,ifield)), xtr(ng)%Rindex
3460 END IF
3461 exit_flag=3
3462 ioerror=status
3463 RETURN
3464 END IF
3465 END IF
3466 END DO
3467# endif
3468!
3469! Write out density anomaly.
3470!
3471 IF (hout(iddano,ng)) THEN
3472 scale=1.0_dp
3473 IF (xtr(ng)%pioVar(iddano)%dkind.eq.pio_double) THEN
3474 iodesx => iodesx_dp_r3dvar(ng)
3475 ELSE
3476 iodesx => iodesx_sp_r3dvar(ng)
3477 END IF
3478 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, iddano, &
3479 & xtr(ng)%pioVar(iddano), &
3480 & xtr(ng)%Rindex, &
3481 & iodesx, &
3482 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
3483# ifdef MASKING
3484 & grid(ng) % rmask, &
3485# endif
3486 & ocean(ng) % rho, &
3487 & setfillval = .false., &
3488 & extractfield = extractflag(ng))
3489 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3490 IF (master) THEN
3491 WRITE (stdout,20) trim(vname(1,iddano)), xtr(ng)%Rindex
3492 END IF
3493 exit_flag=3
3494 ioerror=status
3495 RETURN
3496 END IF
3497 END IF
3498
3499# ifdef LMD_SKPP
3500!
3501! Write out depth surface boundary layer.
3502!
3503 IF (hout(idhsbl,ng)) THEN
3504 scale=1.0_dp
3505 IF (xtr(ng)%pioVar(idhsbl)%dkind.eq.pio_double) THEN
3506 iodesx => iodesx_dp_r2dvar(ng)
3507 ELSE
3508 iodesx => iodesx_sp_r2dvar(ng)
3509 END IF
3510 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idhsbl, &
3511 & xtr(ng)%pioVar(idhsbl), &
3512 & xtr(ng)%Rindex, &
3513 & iodesx, &
3514 & lbi, ubi, lbj, ubj, scale, &
3515# ifdef MASKING
3516 & grid(ng) % rmask, &
3517# endif
3518 & mixing(ng) % hsbl, &
3519 & setfillval = .false., &
3520 & extractfield = extractflag(ng))
3521 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3522 IF (master) THEN
3523 WRITE (stdout,20) trim(vname(1,idhsbl)), xtr(ng)%Rindex
3524 END IF
3525 exit_flag=3
3526 ioerror=status
3527 RETURN
3528 END IF
3529 END IF
3530# endif
3531# ifdef LMD_BKPP
3532!
3533! Write out depth bottom boundary layer.
3534!
3535 IF (hout(idhbbl,ng)) THEN
3536 scale=1.0_dp
3537 IF (xtr(ng)%pioVar(idhbbl)%dkind.eq.pio_double) THEN
3538 iodesx => iodesx_dp_r2dvar(ng)
3539 ELSE
3540 iodesx => iodesx_sp_r2dvar(ng)
3541 END IF
3542 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idhbbl, &
3543 & xtr(ng)%pioVar(idhbbl), &
3544 & xtr(ng)%Rindex, &
3545 & iodesx, &
3546 & lbi, ubi, lbj, ubj, scale, &
3547# ifdef MASKING
3548 & grid(ng) % rmask, &
3549# endif
3550 & mixing(ng) % hbbl, &
3551 & setfillval = .false., &
3552 & extractfield = extractflag(ng))
3553 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3554 IF (master) THEN
3555 WRITE (stdout,20) trim(vname(1,idhbbl)), xtr(ng)%Rindex
3556 END IF
3557 exit_flag=3
3558 ioerror=status
3559 RETURN
3560 END IF
3561 END IF
3562# endif
3563# if defined FORWARD_WRITE && defined LMD_NONLOCAL
3564!
3565! Write out KPP nonlocal transport.
3566!
3567 DO i=1,nat
3568 IF (hout(idghat(i),ng)) THEN
3569 scale=1.0_dp
3570 IF (xtr(ng)%pioVar(idghat(i))%dkind.eq.pio_double) THEN
3571 iodesx => iodesx_dp_w3dvar(ng)
3572 ELSE
3573 iodesx => iodesx_sp_w3dvar(ng)
3574 END IF
3575 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idghat(i), &
3576 & xtr(ng)%pioVar(idghat(i)), &
3577 & xtr(ng)%Rindex, &
3578 & iodesx, &
3579 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3580# ifdef MASKING
3581 & grid(ng) % rmask, &
3582# endif
3583 & mixing(ng) % ghats(:,:,:,i), &
3584 & setfillval = .false., &
3585 & extractfield = extractflag(ng))
3586 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3587 IF (master) THEN
3588 WRITE (stdout,20) trim(vname(1,idghat(i))), xtr(ng)%Rindex
3589 END IF
3590 exit_flag=3
3591 ioerror=status
3592 RETURN
3593 END IF
3594 END IF
3595 END DO
3596# endif
3597!
3598! Write out vertical viscosity coefficient.
3599!
3600 IF (hout(idvvis,ng)) THEN
3601 scale=1.0_dp
3602 IF (xtr(ng)%pioVar(idvvis)%dkind.eq.pio_double) THEN
3603 iodesx => iodesx_dp_w3dvar(ng)
3604 ELSE
3605 iodesx => iodesx_sp_w3dvar(ng)
3606 END IF
3607 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idvvis, &
3608 & xtr(ng)%pioVar(idvvis), &
3609 & xtr(ng)%Rindex, &
3610 & iodesx, &
3611 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3612# ifdef MASKING
3613 & grid(ng) % rmask, &
3614# endif
3615 & mixing(ng) % Akv, &
3616 & setfillval = .false., &
3617 & extractfield = extractflag(ng))
3618 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3619 IF (master) THEN
3620 WRITE (stdout,20) trim(vname(1,idvvis)), xtr(ng)%Rindex
3621 END IF
3622 exit_flag=3
3623 ioerror=status
3624 RETURN
3625 END IF
3626 END IF
3627!
3628! Write out vertical diffusion coefficient for potential temperature.
3629!
3630 IF (hout(idtdif,ng)) THEN
3631 scale=1.0_dp
3632 IF (xtr(ng)%pioVar(idtdif)%dkind.eq.pio_double) THEN
3633 iodesx => iodesx_dp_w3dvar(ng)
3634 ELSE
3635 iodesx => iodesx_sp_w3dvar(ng)
3636 END IF
3637 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idtdif, &
3638 & xtr(ng)%pioVar(idtdif), &
3639 & xtr(ng)%Rindex, &
3640 & iodesx, &
3641 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3642# ifdef MASKING
3643 & grid(ng) % rmask, &
3644# endif
3645 & mixing(ng) % Akt(:,:,:,itemp), &
3646 & setfillval = .false., &
3647 & extractfield = extractflag(ng))
3648 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3649 IF (master) THEN
3650 WRITE (stdout,20) trim(vname(1,idtdif)), xtr(ng)%Rindex
3651 END IF
3652 exit_flag=3
3653 ioerror=status
3654 RETURN
3655 END IF
3656 END IF
3657
3658# ifdef SALINITY
3659!
3660! Write out vertical diffusion coefficient for salinity.
3661!
3662 IF (hout(idsdif,ng)) THEN
3663 scale=1.0_dp
3664 IF (xtr(ng)%pioVar(idsdif)%dkind.eq.pio_double) THEN
3665 iodesx => iodesx_dp_w3dvar(ng)
3666 ELSE
3667 iodesx => iodesx_sp_w3dvar(ng)
3668 END IF
3669 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idsdif, &
3670 & xtr(ng)%pioVar(idsdif), &
3671 & xtr(ng)%Rindex, &
3672 & iodesx, &
3673 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3674# ifdef MASKING
3675 & grid(ng) % rmask, &
3676# endif
3677 & mixing(ng) % Akt(:,:,:,isalt), &
3678 & setfillval = .false., &
3679 & extractfield = extractflag(ng))
3680 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3681 IF (master) THEN
3682 WRITE (stdout,20) trim(vname(1,idsdif)), xtr(ng)%Rindex
3683 END IF
3684 exit_flag=3
3685 ioerror=status
3686 RETURN
3687 END IF
3688 END IF
3689# endif
3690# if defined GLS_MIXING || defined MY25_MIXING
3691!
3692! Write out turbulent kinetic energy.
3693!
3694 IF (hout(idmtke,ng)) THEN
3695 scale=1.0_dp
3696 IF (xtr(ng)%pioVar(idmtke)%dkind.eq.pio_double) THEN
3697 iodesx => iodesx_dp_w3dvar(ng)
3698 ELSE
3699 iodesx => iodesx_sp_w3dvar(ng)
3700 END IF
3701 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idmtke, &
3702 & xtr(ng)%pioVar(idmtke), &
3703 & xtr(ng)%Rindex, &
3704 & iodesx, &
3705 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3706# ifdef MASKING
3707 & grid(ng) % rmask, &
3708# endif
3709 & mixing(ng) % tke(:,:,:,nout), &
3710 & setfillval = .false., &
3711 & extractfield = extractflag(ng))
3712 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3713 IF (master) THEN
3714 WRITE (stdout,20) trim(vname(1,idmtke)), xtr(ng)%Rindex
3715 END IF
3716 exit_flag=3
3717 ioerror=status
3718 RETURN
3719 END IF
3720
3721# ifdef FORWARD_WRITE
3722!
3723 scale=1.0_dp
3724 IF (xtr(ng)%pioVar(idvmkk)%dkind.eq.pio_double) THEN
3725 iodesx => iodesx_dp_w3dvar(ng)
3726 ELSE
3727 iodesx => iodesx_sp_w3dvar(ng)
3728 END IF
3729 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idvmkk, &
3730 & xtr(ng)%pioVar(idvmkk), &
3731 & xtr(ng)%Rindex, &
3732 & iodesx, &
3733 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3734# ifdef MASKING
3735 & grid(ng) % rmask, &
3736# endif
3737 & mixing(ng) % Akk, &
3738 & setfillval = .false., &
3739 & extractfield = extractflag(ng))
3740 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3741 IF (master) THEN
3742 WRITE (stdout,20) trim(vname(1,idvmkk)), xtr(ng)%Rindex
3743 END IF
3744 exit_flag=3
3745 ioerror=status
3746 RETURN
3747 END IF
3748# endif
3749 END IF
3750!
3751! Write out turbulent length scale field.
3752!
3753 IF (hout(idmtls,ng)) THEN
3754 scale=1.0_dp
3755 IF (xtr(ng)%pioVar(idmtls)%dkind.eq.pio_double) THEN
3756 iodesx => iodesx_dp_w3dvar(ng)
3757 ELSE
3758 iodesx => iodesx_sp_w3dvar(ng)
3759 END IF
3760 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idmtls, &
3761 & xtr(ng)%pioVar(idmtls), &
3762 & xtr(ng)%Rindex, &
3763 & iodesx, &
3764 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3765# ifdef MASKING
3766 & grid(ng) % rmask, &
3767# endif
3768 & mixing(ng) % gls(:,:,:,nout), &
3769 & setfillval = .false., &
3770 & extractfield = extractflag(ng))
3771 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3772 IF (master) THEN
3773 WRITE (stdout,20) trim(vname(1,idmtls)), xtr(ng)%Rindex
3774 END IF
3775 exit_flag=3
3776 ioerror=status
3777 RETURN
3778 END IF
3779
3780# ifdef FORWARD_WRITE
3781!
3782 IF (xtr(ng)%pioVar(idvmls)%dkind.eq.pio_double) THEN
3783 iodesx => iodesx_dp_w3dvar(ng)
3784 ELSE
3785 iodesx => iodesx_sp_w3dvar(ng)
3786 END IF
3787 scale=1.0_dp
3788 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idvmls, &
3789 & xtr(ng)%pioVar(idvmls), &
3790 & xtr(ng)%Rindex, &
3791 & iodesx, &
3792 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3793# ifdef MASKING
3794 & grid(ng) % rmask, &
3795# endif
3796 & mixing(ng) % Lscale, &
3797 & setfillval = .false., &
3798 & extractfield = extractflag(ng))
3799 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3800 IF (master) THEN
3801 WRITE (stdout,20) trim(vname(1,idvmls)), xtr(ng)%Rindex
3802 END IF
3803 exit_flag=3
3804 ioerror=status
3805 RETURN
3806 END IF
3807# endif
3808# if defined FORWARD_WRITE && defined GLS_MIXING
3809!
3810 scale=1.0_dp
3811 IF (xtr(ng)%pioVar(idvmkp)%dkind.eq.pio_double) THEN
3812 iodesx => iodesx_dp_w3dvar(ng)
3813 ELSE
3814 iodesx => iodesx_sp_w3dvar(ng)
3815 END IF
3816 status=nf_fwrite3d(ng, model, xtr(ng)%pioFile, idvmkp, &
3817 & xtr(ng)%pioVar(idvmkp), &
3818 & xtr(ng)%Rindex, &
3819 & iodesx, &
3820 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
3821# ifdef MASKING
3822 & grid(ng) % rmask, &
3823# endif
3824 & mixing(ng) % Akp, &
3825 & setfillval = .false., &
3826 & extractfield = extractflag(ng))
3827 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3828 IF (master) THEN
3829 WRITE (stdout,20) trim(vname(1,idvmkp)), xtr(ng)%Rindex
3830 END IF
3831 exit_flag=3
3832 ioerror=status
3833 RETURN
3834 END IF
3835# endif
3836 END IF
3837# endif
3838# if defined BULK_FLUXES || defined ECOSIM || defined ATM_PRESS
3839!
3840! Write out surface air pressure.
3841!
3842 IF (hout(idpair,ng)) THEN
3843 scale=1.0_dp
3844 IF (xtr(ng)%pioVar(idpair)%dkind.eq.pio_double) THEN
3845 iodesx => iodesx_dp_r2dvar(ng)
3846 ELSE
3847 iodesx => iodesx_sp_r2dvar(ng)
3848 END IF
3849 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idpair, &
3850 & xtr(ng)%pioVar(idpair), &
3851 & xtr(ng)%Rindex, &
3852 & iodesx, &
3853 & lbi, ubi, lbj, ubj, scale, &
3854# ifdef MASKING
3855 & grid(ng) % rmask, &
3856# endif
3857 & forces(ng) % Pair, &
3858 & setfillval = .false., &
3859 & extractfield = extractflag(ng))
3860 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3861 IF (master) THEN
3862 WRITE (stdout,20) trim(vname(1,idpair)), xtr(ng)%Rindex
3863 END IF
3864 exit_flag=3
3865 ioerror=status
3866 RETURN
3867 END IF
3868 END IF
3869# endif
3870# if defined BULK_FLUXES
3871!
3872! Write out surface air temperature.
3873!
3874 IF (hout(idtair,ng)) THEN
3875 scale=1.0_dp
3876 IF (xtr(ng)%pioVar(idtair)%dkind.eq.pio_double) THEN
3877 iodesx => iodesx_dp_r2dvar(ng)
3878 ELSE
3879 iodesx => iodesx_sp_r2dvar(ng)
3880 END IF
3881 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idtair, &
3882 & xtr(ng)%pioVar(idtair), &
3883 & xtr(ng)%Rindex, &
3884 & iodesx, &
3885 & lbi, ubi, lbj, ubj, scale, &
3886# ifdef MASKING
3887 & grid(ng) % rmask, &
3888# endif
3889 & forces(ng) % Tair, &
3890 & setfillval = .false., &
3891 & extractfield = extractflag(ng))
3892 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3893 IF (master) THEN
3894 WRITE (stdout,20) trim(vname(1,idtair)), xtr(ng)%Rindex
3895 END IF
3896 exit_flag=3
3897 ioerror=status
3898 RETURN
3899 END IF
3900 END IF
3901# endif
3902# if defined BULK_FLUXES || defined ECOSIM
3903!
3904! Write out surface winds.
3905!
3906 IF (hout(iduair,ng)) THEN
3907 scale=1.0_dp
3908 IF (xtr(ng)%pioVar(iduair)%dkind.eq.pio_double) THEN
3909 iodesx => iodesx_dp_r2dvar(ng)
3910 ELSE
3911 iodesx => iodesx_sp_r2dvar(ng)
3912 END IF
3913 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, iduair, &
3914 & xtr(ng)%pioVar(iduair), &
3915 & xtr(ng)%Rindex, &
3916 & iodesx, &
3917 & lbi, ubi, lbj, ubj, scale, &
3918# ifdef MASKING
3919 & grid(ng) % rmask, &
3920# endif
3921 & forces(ng) % Uwind, &
3922 & setfillval = .false., &
3923 & extractfield = extractflag(ng))
3924 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3925 IF (master) THEN
3926 WRITE (stdout,20) trim(vname(1,iduair)), xtr(ng)%Rindex
3927 END IF
3928 exit_flag=3
3929 ioerror=status
3930 RETURN
3931 END IF
3932 END IF
3933!
3934 IF (hout(idvair,ng)) THEN
3935 scale=1.0_dp
3936 IF (xtr(ng)%pioVar(idvair)%dkind.eq.pio_double) THEN
3937 iodesx => iodesx_dp_r2dvar(ng)
3938 ELSE
3939 iodesx => iodesx_sp_r2dvar(ng)
3940 END IF
3941 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvair, &
3942 & xtr(ng)%pioVar(idvair), &
3943 & xtr(ng)%Rindex, &
3944 & iodesx, &
3945 & lbi, ubi, lbj, ubj, scale, &
3946# ifdef MASKING
3947 & grid(ng) % rmask, &
3948# endif
3949 & forces(ng) % Vwind, &
3950 & setfillval = .false., &
3951 & extractfield = extractflag(ng))
3952 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3953 IF (master) THEN
3954 WRITE (stdout,20) trim(vname(1,idvair)), xtr(ng)%Rindex
3955 END IF
3956 exit_flag=3
3957 ioerror=status
3958 RETURN
3959 END IF
3960 END IF
3961!
3962! Write out Eastward/Northward surface wind (m/s) at RHO-points.
3963!
3964 IF (hout(iduaie,ng).and.hout(idvain,ng)) THEN
3965 IF (.not.allocated(ur2d)) THEN
3966 allocate (ur2d(lbi:ubi,lbj:ubj))
3967 ur2d(lbi:ubi,lbj:ubj)=0.0_r8
3968 END IF
3969 IF (.not.allocated(vr2d)) THEN
3970 allocate (vr2d(lbi:ubi,lbj:ubj))
3971 vr2d(lbi:ubi,lbj:ubj)=0.0_r8
3972 END IF
3973 CALL uv_rotate2d (ng, tile, .false., .true., &
3974 & lbi, ubi, lbj, ubj, &
3975 & grid(ng) % CosAngler, &
3976 & grid(ng) % SinAngler, &
3977# ifdef MASKING
3978 & grid(ng) % rmask_full, &
3979# endif
3980 & forces(ng) % Uwind, &
3981 & forces(ng) % Vwind, &
3982 & ur2d, vr2d)
3983!
3984 scale=1.0_dp
3985 IF (xtr(ng)%pioVar(iduaie)%dkind.eq.pio_double) THEN
3986 iodesx => iodesx_dp_r2dvar(ng)
3987 ELSE
3988 iodesx => iodesx_sp_r2dvar(ng)
3989 END IF
3990 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, iduaie, &
3991 & xtr(ng)%pioVar(iduaie), &
3992 & xtr(ng)%Rindex, &
3993 & iodesx, &
3994 & lbi, ubi, lbj, ubj, scale, &
3995# ifdef MASKING
3996 & grid(ng) % rmask, &
3997# endif
3998 & ur2d, &
3999 & setfillval = .false., &
4000 & extractfield = extractflag(ng))
4001 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4002 IF (master) THEN
4003 WRITE (stdout,20) trim(vname(1,iduaie)), xtr(ng)%Rindex
4004 END IF
4005 exit_flag=3
4006 ioerror=status
4007 RETURN
4008 END IF
4009!
4010 scale=1.0_dp
4011 IF (xtr(ng)%pioVar(idvain)%dkind.eq.pio_double) THEN
4012 iodesx => iodesx_dp_r2dvar(ng)
4013 ELSE
4014 iodesx => iodesx_sp_r2dvar(ng)
4015 END IF
4016 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvain, &
4017 & xtr(ng)%pioVar(idvain), &
4018 & xtr(ng)%Rindex, &
4019 & iodesx, &
4020 & lbi, ubi, lbj, ubj, scale, &
4021# ifdef MASKING
4022 & grid(ng) % rmask, &
4023# endif
4024 & vr2d, &
4025 & setfillval = .false., &
4026 & extractfield = extractflag(ng))
4027 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4028 IF (master) THEN
4029 WRITE (stdout,20) trim(vname(1,idvain)), xtr(ng)%Rindex
4030 END IF
4031 exit_flag=3
4032 ioerror=status
4033 RETURN
4034 END IF
4035 deallocate (ur2d)
4036 deallocate (vr2d)
4037 END IF
4038# endif
4039!
4040! Write out surface active tracers fluxes.
4041!
4042 DO itrc=1,nat
4043 IF (hout(idtsur(itrc),ng)) THEN
4044 IF (itrc.eq.itemp) THEN
4045# ifdef SO_SEMI
4046 scale=1.0_dp
4047# else
4048 scale=rho0*cp ! Celsius m/s to W/m2
4049# endif
4050 ELSE IF (itrc.eq.isalt) THEN
4051 scale=1.0_dp
4052 END IF
4053 IF (xtr(ng)%pioVar(idtsur(itrc))%dkind.eq.pio_double) THEN
4054 iodesx => iodesx_dp_r2dvar(ng)
4055 ELSE
4056 iodesx => iodesx_sp_r2dvar(ng)
4057 END IF
4058 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idtsur(itrc), &
4059 & xtr(ng)%pioVar(idtsur(itrc)), &
4060 & xtr(ng)%Rindex, &
4061 & iodesx, &
4062 & lbi, ubi, lbj, ubj, scale, &
4063# ifdef MASKING
4064 & grid(ng) % rmask, &
4065# endif
4066 & forces(ng) % stflx(:,:,itrc), &
4067 & setfillval = .false., &
4068 & extractfield = extractflag(ng))
4069 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4070 IF (master) THEN
4071 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), &
4072 & xtr(ng)%Rindex
4073 END IF
4074 exit_flag=3
4075 ioerror=status
4076 RETURN
4077 END IF
4078 END IF
4079 END DO
4080
4081# if defined BULK_FLUXES || defined FRC_COUPLING
4082!
4083! Write out latent heat flux.
4084!
4085 IF (hout(idlhea,ng)) THEN
4086 scale=rho0*cp
4087 IF (xtr(ng)%pioVar(idlhea)%dkind.eq.pio_double) THEN
4088 iodesx => iodesx_dp_r2dvar(ng)
4089 ELSE
4090 iodesx => iodesx_sp_r2dvar(ng)
4091 END IF
4092 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idlhea, &
4093 & xtr(ng)%pioVar(idlhea), &
4094 & xtr(ng)%Rindex, &
4095 & iodesx, &
4096 & lbi, ubi, lbj, ubj, scale, &
4097# ifdef MASKING
4098 & grid(ng) % rmask, &
4099# endif
4100 & forces(ng) % lhflx, &
4101 & setfillval = .false., &
4102 & extractfield = extractflag(ng))
4103 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4104 IF (master) THEN
4105 WRITE (stdout,20) trim(vname(1,idlhea)), xtr(ng)%Rindex
4106 END IF
4107 exit_flag=3
4108 ioerror=status
4109 RETURN
4110 END IF
4111 END IF
4112!
4113! Write out sensible heat flux.
4114!
4115 IF (hout(idshea,ng)) THEN
4116 scale=rho0*cp
4117 IF (xtr(ng)%pioVar(idshea)%dkind.eq.pio_double) THEN
4118 iodesx => iodesx_dp_r2dvar(ng)
4119 ELSE
4120 iodesx => iodesx_sp_r2dvar(ng)
4121 END IF
4122 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idshea, &
4123 & xtr(ng)%pioVar(idshea), &
4124 & xtr(ng)%Rindex, &
4125 & iodesx, &
4126 & lbi, ubi, lbj, ubj, scale, &
4127# ifdef MASKING
4128 & grid(ng) % rmask, &
4129# endif
4130 & forces(ng) % shflx, &
4131 & setfillval = .false., &
4132 & extractfield = extractflag(ng))
4133 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4134 IF (master) THEN
4135 WRITE (stdout,20) trim(vname(1,idshea)), xtr(ng)%Rindex
4136 END IF
4137 exit_flag=3
4138 ioerror=status
4139 RETURN
4140 END IF
4141 END IF
4142!
4143! Write out net longwave radiation flux.
4144!
4145 IF (hout(idlrad,ng)) THEN
4146 scale=rho0*cp
4147 IF (xtr(ng)%pioVar(idlrad)%dkind.eq.pio_double) THEN
4148 iodesx => iodesx_dp_r2dvar(ng)
4149 ELSE
4150 iodesx => iodesx_sp_r2dvar(ng)
4151 END IF
4152 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idlrad, &
4153 & xtr(ng)%pioVar(idlrad), &
4154 & xtr(ng)%Rindex, &
4155 & iodesx, &
4156 & lbi, ubi, lbj, ubj, scale, &
4157# ifdef MASKING
4158 & grid(ng) % rmask, &
4159# endif
4160 & forces(ng) % lrflx, &
4161 & setfillval = .false., &
4162 & extractfield = extractflag(ng))
4163 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4164 IF (master) THEN
4165 WRITE (stdout,20) trim(vname(1,idlrad)), xtr(ng)%Rindex
4166 END IF
4167 exit_flag=3
4168 ioerror=status
4169 RETURN
4170 END IF
4171 END IF
4172# endif
4173
4174# ifdef BULK_FLUXES
4175# ifdef EMINUSP
4176!
4177! Write out evaporation rate (kg/m2/s).
4178!
4179 IF (hout(idevap,ng)) THEN
4180 scale=1.0_dp
4181 IF (xtr(ng)%pioVar(idevap)%dkind.eq.pio_double) THEN
4182 iodesx => iodesx_dp_r2dvar(ng)
4183 ELSE
4184 iodesx => iodesx_sp_r2dvar(ng)
4185 END IF
4186 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idevap, &
4187 & xtr(ng)%pioVar(idevap), &
4188 & xtr(ng)%Rindex, &
4189 & iodesx, &
4190 & lbi, ubi, lbj, ubj, scale, &
4191# ifdef MASKING
4192 & grid(ng) % rmask, &
4193# endif
4194 & forces(ng) % evap, &
4195 & setfillval = .false., &
4196 & extractfield = extractflag(ng))
4197 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4198 IF (master) THEN
4199 WRITE (stdout,20) trim(vname(1,idevap)), xtr(ng)%Rindex
4200 END IF
4201 exit_flag=3
4202 ioerror=status
4203 RETURN
4204 END IF
4205 END IF
4206!
4207! Write out precipitation rate (kg/m2/s).
4208!
4209 IF (hout(idrain,ng)) THEN
4210 scale=1.0_dp
4211 IF (xtr(ng)%pioVar(idrain)%dkind.eq.pio_double) THEN
4212 iodesx => iodesx_dp_r2dvar(ng)
4213 ELSE
4214 iodesx => iodesx_sp_r2dvar(ng)
4215 END IF
4216 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idrain, &
4217 & xtr(ng)%pioVar(idrain), &
4218 & xtr(ng)%Rindex, &
4219 & iodesx, &
4220 & lbi, ubi, lbj, ubj, scale, &
4221# ifdef MASKING
4222 & grid(ng) % rmask, &
4223# endif
4224 & forces(ng) % rain, &
4225 & setfillval = .false., &
4226 & extractfield = extractflag(ng))
4227 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4228 IF (master) THEN
4229 WRITE (stdout,20) trim(vname(1,idrain)), xtr(ng)%Rindex
4230 END IF
4231 exit_flag=3
4232 ioerror=status
4233 RETURN
4234 END IF
4235 END IF
4236# endif
4237# endif
4238!
4239! Write out E-P (m/s).
4240!
4241 IF (hout(idempf,ng)) THEN
4242 scale=1.0_dp
4243 IF (xtr(ng)%pioVar(idempf)%dkind.eq.pio_double) THEN
4244 iodesx => iodesx_dp_r2dvar(ng)
4245 ELSE
4246 iodesx => iodesx_sp_r2dvar(ng)
4247 END IF
4248 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idempf, &
4249 & xtr(ng)%pioVar(idempf), &
4250 & xtr(ng)%Rindex, &
4251 & iodesx, &
4252 & lbi, ubi, lbj, ubj, scale, &
4253# ifdef MASKING
4254 & grid(ng) % rmask, &
4255# endif
4256 & forces(ng) % stflux(:,:,isalt), &
4257 & setfillval = .false., &
4258 & extractfield = extractflag(ng))
4259 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4260 IF (master) THEN
4261 WRITE (stdout,20) trim(vname(1,idempf)), xtr(ng)%Rindex
4262 END IF
4263 exit_flag=3
4264 ioerror=status
4265 RETURN
4266 END IF
4267 END IF
4268
4269# ifdef SHORTWAVE
4270!
4271! Write out net shortwave radiation flux.
4272!
4273 IF (hout(idsrad,ng)) THEN
4274 scale=rho0*cp
4275 IF (xtr(ng)%pioVar(idsrad)%dkind.eq.pio_double) THEN
4276 iodesx => iodesx_dp_r2dvar(ng)
4277 ELSE
4278 iodesx => iodesx_sp_r2dvar(ng)
4279 END IF
4280 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idsrad, &
4281 & xtr(ng)%pioVar(idsrad), &
4282 & xtr(ng)%Rindex, &
4283 & iodesx, &
4284 & lbi, ubi, lbj, ubj, scale, &
4285# ifdef MASKING
4286 & grid(ng) % rmask, &
4287# endif
4288 & forces(ng) % srflx, &
4289 & setfillval = .false., &
4290 & extractfield = extractflag(ng))
4291 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4292 IF (master) THEN
4293 WRITE (stdout,20) trim(vname(1,idsrad)), xtr(ng)%Rindex
4294 END IF
4295 exit_flag=3
4296 ioerror=status
4297 RETURN
4298 END IF
4299 END IF
4300# endif
4301# endif
4302!
4303! Write out surface U-momentum stress.
4304!
4305 IF (hout(idusms,ng)) THEN
4306# ifdef SO_SEMI
4307 scale=1.0_dp
4308# else
4309 scale=rho0 ! m2/s2 to Pa
4310# endif
4311 IF (xtr(ng)%pioVar(idusms)%dkind.eq.pio_double) THEN
4312 iodesx => iodesx_dp_u2dvar(ng)
4313 ELSE
4314 iodesx => iodesx_sp_u2dvar(ng)
4315 END IF
4316 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idusms, &
4317 & xtr(ng)%pioVar(idusms), &
4318 & xtr(ng)%Rindex, &
4319 & iodesx, &
4320 & lbi, ubi, lbj, ubj, scale, &
4321# ifdef MASKING
4322 & grid(ng) % umask, &
4323# endif
4324 & forces(ng) % sustr, &
4325 & setfillval = .false., &
4326 & extractfield = extractflag(ng))
4327 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4328 IF (master) THEN
4329 WRITE (stdout,20) trim(vname(1,idusms)), xtr(ng)%Rindex
4330 END IF
4331 exit_flag=3
4332 ioerror=status
4333 RETURN
4334 END IF
4335 END IF
4336!
4337! Write out surface V-momentum stress.
4338!
4339 IF (hout(idvsms,ng)) THEN
4340# ifdef SO_SEMI
4341 scale=1.0_dp
4342# else
4343 scale=rho0
4344# endif
4345 IF (xtr(ng)%pioVar(idvsms)%dkind.eq.pio_double) THEN
4346 iodesx => iodesx_dp_v2dvar(ng)
4347 ELSE
4348 iodesx => iodesx_sp_v2dvar(ng)
4349 END IF
4350 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvsms, &
4351 & xtr(ng)%pioVar(idvsms), &
4352 & xtr(ng)%Rindex, &
4353 & iodesx, &
4354 & lbi, ubi, lbj, ubj, scale, &
4355# ifdef MASKING
4356 & grid(ng) % vmask, &
4357# endif
4358 & forces(ng) % svstr, &
4359 & setfillval = .false., &
4360 & extractfield = extractflag(ng))
4361 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4362 IF (master) THEN
4363 WRITE (stdout,20) trim(vname(1,idvsms)), xtr(ng)%Rindex
4364 END IF
4365 exit_flag=3
4366 ioerror=status
4367 RETURN
4368 END IF
4369 END IF
4370!
4371! Write out bottom U-momentum stress.
4372!
4373 IF (hout(idubms,ng)) THEN
4374 scale=-rho0
4375 IF (xtr(ng)%pioVar(idubms)%dkind.eq.pio_double) THEN
4376 iodesx => iodesx_dp_u2dvar(ng)
4377 ELSE
4378 iodesx => iodesx_sp_u2dvar(ng)
4379 END IF
4380 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idubms, &
4381 & xtr(ng)%pioVar(idubms), &
4382 & xtr(ng)%Rindex, &
4383 & iodesx, &
4384 & lbi, ubi, lbj, ubj, scale, &
4385# ifdef MASKING
4386 & grid(ng) % umask, &
4387# endif
4388 & forces(ng) % bustr, &
4389 & setfillval = .false., &
4390 & extractfield = extractflag(ng))
4391 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4392 IF (master) THEN
4393 WRITE (stdout,20) trim(vname(1,idubms)), xtr(ng)%Rindex
4394 END IF
4395 exit_flag=3
4396 ioerror=status
4397 RETURN
4398 END IF
4399 END IF
4400!
4401! Write out bottom V-momentum stress.
4402!
4403 IF (hout(idvbms,ng)) THEN
4404 scale=-rho0
4405 IF (xtr(ng)%pioVar(idvbms)%dkind.eq.pio_double) THEN
4406 iodesx => iodesx_dp_v2dvar(ng)
4407 ELSE
4408 iodesx => iodesx_sp_v2dvar(ng)
4409 END IF
4410 status=nf_fwrite2d(ng, model, xtr(ng)%pioFile, idvbms, &
4411 & xtr(ng)%pioVar(idvbms), &
4412 & xtr(ng)%Rindex, &
4413 & iodesx, &
4414 & lbi, ubi, lbj, ubj, scale, &
4415# ifdef MASKING
4416 & grid(ng) % vmask, &
4417# endif
4418 & forces(ng) % bvstr, &
4419 & setfillval = .false., &
4420 & extractfield = extractflag(ng))
4421 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4422 IF (master) THEN
4423 WRITE (stdout,20) trim(vname(1,idvbms)), xtr(ng)%Rindex
4424 END IF
4425 exit_flag=3
4426 ioerror=status
4427 RETURN
4428 END IF
4429 END IF
4430
4431# if (defined BBL_MODEL || defined WAVES_OUTPUT) && defined SOLVE3D
4432!
4433!-----------------------------------------------------------------------
4434! Write out the bottom boundary layer model or waves variables.
4435!-----------------------------------------------------------------------
4436!
4437 CALL bbl_wrt_pio (ng, model, tile, &
4438 & lbi, ubi, lbj, ubj, &
4439 & hout, xtr)
4440 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4441# endif
4442
4443# if defined ICE_MODEL && defined SOLVE3D
4444!
4445!-----------------------------------------------------------------------
4446! Write out the sea-ice model variables.
4447!-----------------------------------------------------------------------
4448!
4449 CALL ice_wrt_pio (ng, model, tile, &
4450 & lbi, ubi, lbj, ubj, &
4451 & hout, xtr)
4452 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4453# endif
4454
4455# if defined SEDIMENT && defined SOLVE3D
4456!
4457!-----------------------------------------------------------------------
4458! Write out the sediment model variables.
4459!-----------------------------------------------------------------------
4460!
4461 CALL sediment_wrt_pio (ng, model, tile, &
4462 & lbi, ubi, lbj, ubj, &
4463 & hout, xtr)
4464 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4465# endif
4466
4467# if defined WEC_VF && defined SOLVE3D
4468!
4469!-----------------------------------------------------------------------
4470! Write out the Waves Effect on Currents variables.
4471!-----------------------------------------------------------------------
4472!
4473 CALL wec_wrt_pio (ng, model, tile, &
4474 & lbi, ubi, lbj, ubj, &
4475 & hout, xtr)
4476 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4477# endif
4478!
4479!-----------------------------------------------------------------------
4480! Synchronize decimate NetCDF file to disk to allow other processes
4481! to access data immediately after it is written.
4482!-----------------------------------------------------------------------
4483!
4484 CALL pio_netcdf_sync (ng, model, xtr(ng)%name, xtr(ng)%pioFile)
4485 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
4486!
4487 10 FORMAT (2x,'WRT_EXTRACT_PIO - writing extract', t42, &
4488# ifdef SOLVE3D
4489# ifdef NESTING
4490 & 'fields (Index=',i1,',',i1,') in record = ',i0,t92,i2.2)
4491# else
4492 & 'fields (Index=',i1,',',i1,') in record = ',i0)
4493# endif
4494# else
4495# ifdef NESTING
4496 & 'fields (Index=',i1,') in record = ',i0,t92,i2.2)
4497# else
4498 & 'fields (Index=',i1,') in record = ',i0)
4499# endif
4500# endif
4501 20 FORMAT (/,' WRT_EXTRACT_PIO - error while writing variable: ',a, &
4502 & /,19x,'into decimate NetCDF file for time record: ',i0)
4503!
4504 RETURN
4505 END SUBROUTINE wrt_extract_pio
4506# endif
4507#endif
4508!
4509 END MODULE wrt_extract_mod
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_bry_mod::nf_fwrite2d_bry
Definition nf_fwrite2d_bry.F:79
nf_fwrite2d_mod::nf_fwrite2d
Definition nf_fwrite2d.F:77
nf_fwrite3d_bry_mod::nf_fwrite3d_bry
Definition nf_fwrite3d_bry.F:81
nf_fwrite3d_mod::nf_fwrite3d
Definition nf_fwrite3d.F:78
bbl_output_mod
Definition bbl_output.F:2
bbl_output_mod::bbl_wrt_pio
subroutine, public bbl_wrt_pio(ng, model, tile, lbi, ubi, lbj, ubj, varout, s)
Definition bbl_output.F:4157
bbl_output_mod::bbl_wrt_nf90
subroutine, public bbl_wrt_nf90(ng, model, tile, lbi, ubi, lbj, ubj, varout, s)
Definition bbl_output.F:1702
extract_field_mod
Definition extract_field.F:2
ice_output_mod
Definition ice_output.F:2
mod_bbl
Definition mod_bbl.F:2
mod_boundary
Definition mod_boundary.F:2
mod_boundary::boundary
type(t_boundary), dimension(:), allocatable boundary
Definition mod_boundary.F:746
mod_coupling
Definition mod_coupling.F:2
mod_coupling::coupling
type(t_coupling), dimension(:), allocatable coupling
Definition mod_coupling.F:102
mod_extract
Definition mod_extract.F:2
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
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::xtr
type(t_io), dimension(:), allocatable xtr
Definition mod_iounits.F:251
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_iounits::sourcefile
character(len=256) sourcefile
Definition mod_iounits.F:317
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::iddano
integer iddano
Definition mod_ncparam.F:200
mod_ncparam::idvair
integer idvair
Definition mod_ncparam.F:358
mod_ncparam::idvmls
integer idvmls
Definition mod_ncparam.F:374
mod_ncparam::hout
logical, dimension(:,:), allocatable hout
Definition mod_ncparam.F:168
mod_ncparam::idevap
integer idevap
Definition mod_ncparam.F:204
mod_ncparam::io_nf90
integer, parameter io_nf90
Definition mod_ncparam.F:95
mod_ncparam::idrv3d
integer idrv3d
Definition mod_ncparam.F:282
mod_ncparam::idubar
integer idubar
Definition mod_ncparam.F:325
mod_ncparam::idwvel
integer idwvel
Definition mod_ncparam.F:421
mod_ncparam::idvvel
integer idvvel
Definition mod_ncparam.F:381
mod_ncparam::idhsbl
integer idhsbl
Definition mod_ncparam.F:213
mod_ncparam::idvsms
integer idvsms
Definition mod_ncparam.F:377
mod_ncparam::idpthw
integer idpthw
Definition mod_ncparam.F:271
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::idpair
integer idpair
Definition mod_ncparam.F:263
mod_ncparam::idrwet
integer idrwet
Definition mod_ncparam.F:285
mod_ncparam::idv2dn
integer idv2dn
Definition mod_ncparam.F:387
mod_ncparam::idsdif
integer idsdif
Definition mod_ncparam.F:290
mod_ncparam::idvfx2
integer idvfx2
Definition mod_ncparam.F:373
mod_ncparam::idtsur
integer, dimension(:), allocatable idtsur
Definition mod_ncparam.F:453
mod_ncparam::idru2d
integer idru2d
Definition mod_ncparam.F:278
mod_ncparam::idvmkp
integer idvmkp
Definition mod_ncparam.F:376
mod_ncparam::idempf
integer idempf
Definition mod_ncparam.F:203
mod_ncparam::idvain
integer idvain
Definition mod_ncparam.F:359
mod_ncparam::idtdif
integer idtdif
Definition mod_ncparam.F:306
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::idhbbl
integer idhbbl
Definition mod_ncparam.F:212
mod_ncparam::idvfx1
integer idvfx1
Definition mod_ncparam.F:372
mod_ncparam::isuvel
integer isuvel
Definition mod_ncparam.F:506
mod_ncparam::idufx2
integer idufx2
Definition mod_ncparam.F:338
mod_ncparam::isfsur
integer isfsur
Definition mod_ncparam.F:503
mod_ncparam::idvbms
integer idvbms
Definition mod_ncparam.F:365
mod_ncparam::iduair
integer iduair
Definition mod_ncparam.F:323
mod_ncparam::idmtke
integer idmtke
Definition mod_ncparam.F:237
mod_ncparam::iduvel
integer iduvel
Definition mod_ncparam.F:343
mod_ncparam::idv3dn
integer idv3dn
Definition mod_ncparam.F:390
mod_ncparam::idghat
integer, dimension(2) idghat
Definition mod_ncparam.F:209
mod_ncparam::idovel
integer idovel
Definition mod_ncparam.F:261
mod_ncparam::iduwet
integer iduwet
Definition mod_ncparam.F:346
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::idshea
integer idshea
Definition mod_ncparam.F:297
mod_ncparam::idpwet
integer idpwet
Definition mod_ncparam.F:265
mod_ncparam::idlrad
integer idlrad
Definition mod_ncparam.F:229
mod_ncparam::idru3d
integer idru3d
Definition mod_ncparam.F:279
mod_ncparam::idpthu
integer idpthu
Definition mod_ncparam.F:269
mod_ncparam::idusms
integer idusms
Definition mod_ncparam.F:339
mod_ncparam::idvmkk
integer idvmkk
Definition mod_ncparam.F:375
mod_ncparam::idvvis
integer idvvis
Definition mod_ncparam.F:382
mod_ncparam::idu3de
integer idu3de
Definition mod_ncparam.F:352
mod_ncparam::idpthv
integer idpthv
Definition mod_ncparam.F:270
mod_ncparam::idrzet
integer idrzet
Definition mod_ncparam.F:286
mod_ncparam::idrvct
integer idrvct
Definition mod_ncparam.F:280
mod_ncparam::idufx1
integer idufx1
Definition mod_ncparam.F:337
mod_ncparam::idu2de
integer idu2de
Definition mod_ncparam.F:349
mod_ncparam::idlhea
integer idlhea
Definition mod_ncparam.F:228
mod_ncparam::idrain
integer idrain
Definition mod_ncparam.F:287
mod_ncparam::idubms
integer idubms
Definition mod_ncparam.F:330
mod_ncparam::idovil
integer idovil
Definition mod_ncparam.F:262
mod_ncparam::idvwet
integer idvwet
Definition mod_ncparam.F:384
mod_ncparam::idsrad
integer idsrad
Definition mod_ncparam.F:293
mod_ncparam::idmtls
integer idmtls
Definition mod_ncparam.F:238
mod_ncparam::idruct
integer idruct
Definition mod_ncparam.F:277
mod_ncparam::iduaie
integer iduaie
Definition mod_ncparam.F:324
mod_ncparam::idpthr
integer idpthr
Definition mod_ncparam.F:268
mod_ncparam::idtair
integer idtair
Definition mod_ncparam.F:305
mod_ncparam::idrv2d
integer idrv2d
Definition mod_ncparam.F:281
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_param
Definition mod_param.F:2
mod_param::nat
integer nat
Definition mod_param.F:499
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::r3dvar
integer, parameter r3dvar
Definition mod_param.F:721
mod_param::u3dvar
integer, parameter u3dvar
Definition mod_param.F:722
mod_param::u2dvar
integer, parameter u2dvar
Definition mod_param.F:718
mod_param::w3dvar
integer, parameter w3dvar
Definition mod_param.F:724
mod_param::p2dvar
integer, parameter p2dvar
Definition mod_param.F:716
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
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::pio_netcdf_sync
subroutine, public pio_netcdf_sync(ng, model, ncname, piofile)
Definition mod_pio_netcdf.F:9275
mod_scalars
Definition mod_scalars.F:2
mod_scalars::lobc
logical, dimension(:,:,:), allocatable lobc
Definition mod_scalars.F:1127
mod_scalars::cp
real(dp) cp
Definition mod_scalars.F:456
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::extractflag
integer, dimension(:), allocatable extractflag
Definition mod_scalars.F:1098
mod_scalars::isalt
integer isalt
Definition mod_scalars.F:127
mod_scalars::itemp
integer itemp
Definition mod_scalars.F:126
mod_scalars::time
real(dp), dimension(:), allocatable time
Definition mod_scalars.F:262
mod_scalars::rho0
real(dp) rho0
Definition mod_scalars.F:787
mod_scalars::nbrec
integer, dimension(:), allocatable nbrec
Definition mod_scalars.F:1119
mod_scalars::noerror
integer noerror
Definition mod_scalars.F:561
mod_sedbed
Definition sedbed_mod.h:1
mod_sediment
Definition sediment_mod.h:1
mod_stepping
Definition mod_stepping.F:2
mod_stepping::lbout
integer, dimension(:), allocatable lbout
Definition mod_stepping.F:97
nf_fwrite2d_bry_mod
Definition nf_fwrite2d_bry.F:2
nf_fwrite2d_mod
Definition nf_fwrite2d.F:2
nf_fwrite3d_bry_mod
Definition nf_fwrite3d_bry.F:2
nf_fwrite3d_mod
Definition nf_fwrite3d.F:2
omega_mod
Definition omega.F:2
omega_mod::scale_omega
subroutine, public scale_omega(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, pm, pn, w, wscl)
Definition omega.F:382
sediment_output_mod
Definition sediment_output.F:2
sediment_output_mod::sediment_wrt_nf90
subroutine, public sediment_wrt_nf90(ng, model, tile, lbi, ubi, lbj, ubj, varout, s)
Definition sediment_output.F:998
sediment_output_mod::sediment_wrt_pio
subroutine, public sediment_wrt_pio(ng, model, tile, lbi, ubi, lbj, ubj, varout, s)
Definition sediment_output.F:2345
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
uv_rotate_mod
Definition uv_rotate.F:2
uv_rotate_mod::uv_rotate3d
subroutine, public uv_rotate3d(ng, tile, add, lboundary, lbi, ubi, lbj, ubj, lbk, ubk, cosangler, sinangler, rmask_full, uinp, vinp, uout, vout)
Definition uv_rotate.F:155
uv_rotate_mod::uv_rotate2d
subroutine, public uv_rotate2d(ng, tile, add, lboundary, lbi, ubi, lbj, ubj, cosangler, sinangler, rmask_full, uinp, vinp, uout, vout)
Definition uv_rotate.F:35
wrt_extract_mod
Definition wrt_extract.F:2