ROMS
Loading...
Searching...
No Matches
tl_wrt_his.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE tl_wrt_his_mod
3#if defined TANGENT || defined TL_IOMS
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! This module writes fields into output tangent linear history file !
13! using either the standard NetCDF library or the Parallel-IO (PIO) !
14! library. !
15! !
16!=======================================================================
17!
18 USE mod_param
19 USE mod_parallel
20# ifdef ADJUST_BOUNDARY
21 USE mod_boundary
22# endif
23# ifdef SOLVE3D
24 USE mod_coupling
25# endif
26# if defined ADJUST_STFLUX || defined ADJUST_WSTRESS || \
27 defined forcing_sv || defined stochastic_opt || \
28 defined hessian_so || defined hessian_fsv
29 USE mod_forces
30# endif
31 USE mod_grid
32 USE mod_iounits
33# ifdef SOLVE3D
34 USE mod_mixing
35# endif
36 USE mod_ncparam
37 USE mod_ocean
38 USE mod_scalars
39# if defined SEDIMENT_NOT_YET || defined BBL_MODEL_NOT_YET
40 USE mod_sediment
41# endif
42 USE mod_stepping
43!
44 USE nf_fwrite2d_mod, ONLY : nf_fwrite2d
45# ifdef ADJUST_BOUNDARY
46 USE nf_fwrite2d_bry_mod, ONLY : nf_fwrite2d_bry
47# endif
48# ifdef SOLVE3D
49 USE nf_fwrite3d_mod, ONLY : nf_fwrite3d
50# ifdef ADJUST_BOUNDARY
51 USE nf_fwrite3d_bry_mod, ONLY : nf_fwrite3d_bry
52# endif
53# endif
54 USE strings_mod, ONLY : founderror
55!
56 implicit none
57!
58 PUBLIC :: tl_wrt_his
59 PRIVATE :: tl_wrt_his_nf90
60# if defined PIO_LIB && defined DISTRIBUTE
61 PRIVATE :: tl_wrt_his_pio
62# endif
63!
64 CONTAINS
65!
66!***********************************************************************
67 SUBROUTINE tl_wrt_his (ng, tile)
68!***********************************************************************
69!
70! Imported variable declarations.
71!
72 integer, intent(in) :: ng, tile
73!
74! Local variable declarations.
75!
76# ifdef ADJUST_BOUNDARY
77 integer :: lbij, ubij
78# endif
79 integer :: lbi, ubi, lbj, ubj
80!
81 character (len=*), parameter :: myfile = &
82 & __FILE__
83!
84!-----------------------------------------------------------------------
85! Write out history fields according to IO type.
86!-----------------------------------------------------------------------
87!
88# ifdef ADJUST_BOUNDARY
89 lbij=bounds(ng)%LBij
90 ubij=bounds(ng)%UBij
91# endif
92 lbi=bounds(ng)%LBi(tile)
93 ubi=bounds(ng)%UBi(tile)
94 lbj=bounds(ng)%LBj(tile)
95 ubj=bounds(ng)%UBj(tile)
96!
97 SELECT CASE (tlm(ng)%IOtype)
98 CASE (io_nf90)
99 CALL tl_wrt_his_nf90 (ng, itlm, tile, &
100# ifdef ADJUST_BOUNDARY
101 & lbij, ubij, &
102# endif
103 & lbi, ubi, lbj, ubj)
104
105# if defined PIO_LIB && defined DISTRIBUTE
106 CASE (io_pio)
107 CALL tl_wrt_his_pio (ng, itlm, tile, &
108# ifdef ADJUST_BOUNDARY
109 & lbij, ubij, &
110# endif
111 & lbi, ubi, lbj, ubj)
112# endif
113 CASE DEFAULT
114 IF (master) WRITE (stdout,10) tlm(ng)%IOtype
115 exit_flag=3
116 END SELECT
117 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
118!
119 10 FORMAT (' TL_WRT_HIS - Illegal output file type, io_type = ',i0, &
120 & /,14x,'Check KeyWord ''OUT_LIB'' in ''roms.in''.')
121!
122 RETURN
123 END SUBROUTINE tl_wrt_his
124!
125!***********************************************************************
126 SUBROUTINE tl_wrt_his_nf90 (ng, model, tile, &
127# ifdef ADJUST_BOUNDARY
128 & LBij, UBij, &
129# endif
130 & LBi, UBi, LBj, UBj)
131!***********************************************************************
132!
133 USE mod_netcdf
134!
135! Imported variable declarations.
136!
137 integer, intent(in) :: ng, model, tile
138# ifdef ADJUST_BOUNDARY
139 integer, intent(in) :: lbij, ubij
140# endif
141 integer, intent(in) :: lbi, ubi, lbj, ubj
142!
143! Local variable declarations.
144!
145 integer :: fcount, gfactor, gtype, status
146# ifdef SOLVE3D
147 integer :: i, itrc, j, k
148# endif
149!
150 real(dp) :: scale
151 real(r8) :: tval(1)
152!
153 character (len=*), parameter :: myfile = &
154 & __FILE__//", tl_wrt_his_nf90"
155!
156 sourcefile=myfile
157!
158!-----------------------------------------------------------------------
159! Write out tangent linear fields.
160!-----------------------------------------------------------------------
161!
162 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
163!
164! Set grid type factor to write full (gfactor=1) fields or water
165! points (gfactor=-1) fields only.
166!
167# if defined WRITE_WATER && defined MASKING
168 gfactor=-1
169# else
170 gfactor=1
171# endif
172!
173! Set time record index.
174!
175 tlm(ng)%Rindex=tlm(ng)%Rindex+1
176 fcount=tlm(ng)%load
177 tlm(ng)%Nrec(fcount)=tlm(ng)%Nrec(fcount)+1
178!
179! Report.
180!
181# ifdef SOLVE3D
182# ifdef NESTING
183 IF (master) WRITE (stdout,10) kout, nout, tlm(ng)%Rindex, ng
184# else
185 IF (master) WRITE (stdout,10) kout, nout, tlm(ng)%Rindex
186# endif
187# else
188# ifdef NESTING
189 IF (master) WRITE (stdout,10) kout, tlm(ng)%Rindex, ng
190# else
191 IF (master) WRITE (stdout,10) kout, tlm(ng)%Rindex
192# endif
193# endif
194!
195! If requested, set time index to recycle time records in the tangent
196! linear file.
197!
198 IF (lcycletlm(ng)) THEN
199 tlm(ng)%Rindex=mod(tlm(ng)%Rindex-1,2)+1
200 END IF
201!
202! Write out model time (s).
203!
204 IF (lwrtper(ng)) THEN
205 tval(1)=real(tlm(ng)%Rindex,r8)*day2sec
206 ELSE
207 tval(1)=time(ng)
208 END IF
209 CALL netcdf_put_fvar (ng, model, tlm(ng)%name, &
210 & trim(vname(1,idtime)), tval, &
211 & (/tlm(ng)%Rindex/), (/1/), &
212 & ncid = tlm(ng)%ncid, &
213 & varid = tlm(ng)%Vid(idtime))
214 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
215
216# ifdef ADJUST_WSTRESS
217!
218! Write out surface U-momentum stress. Notice that the stress has its
219! own fixed time-dimension (of size Nfrec) to allow 4DVAR adjustments
220! at other times in addition to initialization time.
221!
222 scale=1.0_dp ! m2/s2
223 gtype=gfactor*u3dvar
224 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idusms, &
225 & tlm(ng)%Vid(idusms), &
226 & tlm(ng)%Rindex, gtype, &
227 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
228# ifdef MASKING
229 & grid(ng) % umask, &
230# endif
231 & forces(ng) % tl_ustr(:,:,:,lfout(ng)))
232 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
233 IF (master) THEN
234 WRITE (stdout,20) trim(vname(1,idusms)), lfout(ng)
235 END IF
236 exit_flag=3
237 ioerror=status
238 RETURN
239 END IF
240!
241! Write out surface V-momentum stress.
242!
243 scale=1.0_dp ! m2/s2
244 gtype=gfactor*v3dvar
245 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idvsms, &
246 & tlm(ng)%Vid(idvsms), &
247 & tlm(ng)%Rindex, gtype, &
248 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
249# ifdef MASKING
250 & grid(ng) % vmask, &
251# endif
252 & forces(ng) % tl_vstr(:,:,:,lfout(ng)))
253 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
254 IF (master) THEN
255 WRITE (stdout,20) trim(vname(1,idvsms)), lfout(ng)
256 END IF
257 exit_flag=3
258 ioerror=status
259 RETURN
260 END IF
261# endif
262# if defined ADJUST_STFLUX && defined SOLVE3D
263!
264! Write out surface net tracers fluxes. Notice that fluxes have their
265! own fixed time-dimension (of size Nfrec) to allow 4DVAR adjustments
266! at other times in addition to initialization time.
267!
268 DO itrc=1,nt(ng)
269 IF (lstflux(itrc,ng)) THEN
270 scale=1.0_dp ! kinematic flux units
271 gtype=gfactor*r3dvar
272 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idtsur(itrc), &
273 & tlm(ng)%Vid(idtsur(itrc)), &
274 & tlm(ng)%Rindex, gtype, &
275 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
276# ifdef MASKING
277 & grid(ng) % rmask, &
278# endif
279 & forces(ng)% tl_tflux(:,:,:,lfout(ng),itrc))
280 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
281 IF (master) THEN
282 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), lfout(ng)
283 END IF
284 exit_flag=3
285 ioerror=status
286 RETURN
287 END IF
288 END IF
289 END DO
290# endif
291# if defined FORCING_SV || defined STOCHASTIC_OPT || \
292 defined hessian_so || defined hessian_fsv
293!
294! Write out surface U-momentum stress.
295!
296 IF (hout(idusms,ng)) THEN
297 scale=1.0_dp
298 gtype=gfactor*u2dvar
299 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idusms, &
300 & tlm(ng)%Vid(idusms), &
301 & tlm(ng)%Rindex, gtype, &
302 & lbi, ubi, lbj, ubj, scale, &
303# ifdef MASKING
304 & grid(ng) % umask, &
305# endif
306 & forces(ng) % tl_sustr)
307 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
308 IF (master) THEN
309 WRITE (stdout,20) trim(vname(1,idusms)), tlm(ng)%Rindex
310 END IF
311 exit_flag=3
312 ioerror=status
313 RETURN
314 END IF
315 END IF
316!
317! Write out surface V-momentum stress.
318!
319 IF (hout(idvsms,ng)) THEN
320 scale=1.0_dp
321 gtype=gfactor*v2dvar
322 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idvsms, &
323 & tlm(ng)%Vid(idvsms), &
324 & tlm(ng)%Rindex, gtype, &
325 & lbi, ubi, lbj, ubj, scale, &
326# ifdef MASKING
327 & grid(ng) % vmask, &
328# endif
329 & forces(ng) % tl_svstr)
330 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
331 IF (master) THEN
332 WRITE (stdout,20) trim(vname(1,idvsms)), tlm(ng)%Rindex
333 END IF
334 exit_flag=3
335 ioerror=status
336 RETURN
337 END IF
338 END IF
339
340# ifdef SOLVE3D
341!
342! Write out net surface active tracer fluxes.
343!
344 DO itrc=1,nt(ng)
345 IF (hout(idtsur(itrc),ng)) THEN
346 scale=1.0_dp
347 gtype=gfactor*r2dvar
348 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idtsur(itrc), &
349 & tlm(ng)%Vid(idtsur(itrc)), &
350 & tlm(ng)%Rindex, gtype, &
351 & lbi, ubi, lbj, ubj, scale, &
352# ifdef MASKING
353 & grid(ng) % rmask, &
354# endif
355 & forces(ng) % tl_stflx(:,:,itrc))
356 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
357 IF (master) THEN
358 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), &
359 & tlm(ng)%Rindex
360 END IF
361 exit_flag=3
362 ioerror=status
363 RETURN
364 END IF
365 END IF
366 END DO
367# endif
368# endif
369# ifdef SOLVE3D
370!
371! Write time-varying depths of RHO-points.
372!
373 IF (hout(idpthr,ng)) THEN
374 scale=1.0_dp
375 gtype=gfactor*r3dvar
376 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idpthr, &
377 & tlm(ng)%Vid(idpthr), &
378 & tlm(ng)%Rindex, gtype, &
379 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
380# ifdef MASKING
381 & grid(ng) % rmask, &
382# endif
383 & grid(ng) % tl_z_r, &
384 & setfillval = .false.)
385 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
386 IF (master) THEN
387 WRITE (stdout,20) trim(vname(1,idpthr)), tlm(ng)%Rindex
388 END IF
389 exit_flag=3
390 ioerror=status
391 RETURN
392 END IF
393 END IF
394!
395! Write time-varying depths of W-points.
396!
397 IF (hout(idpthw,ng)) THEN
398 scale=1.0_dp
399 gtype=gfactor*w3dvar
400 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idpthw, &
401 & tlm(ng)%Vid(idpthw), &
402 & tlm(ng)%Rindex, gtype, &
403 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
404# ifdef MASKING
405 & grid(ng) % rmask, &
406# endif
407 & grid(ng) % tl_z_w, &
408 & setfillval = .false.)
409 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
410 IF (master) THEN
411 WRITE (stdout,20) trim(vname(1,idpthw)), tlm(ng)%Rindex
412 END IF
413 exit_flag=3
414 ioerror=status
415 RETURN
416 END IF
417 END IF
418# endif
419!
420! Write out free-surface (m)
421!
422 IF (hout(idfsur,ng)) THEN
423 scale=1.0_dp
424 gtype=gfactor*r2dvar
425 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idfsur, &
426 & tlm(ng)%Vid(idfsur), &
427 & tlm(ng)%Rindex, gtype, &
428 & lbi, ubi, lbj, ubj, scale, &
429# ifdef MASKING
430 & grid(ng) % rmask, &
431# endif
432# ifdef WET_DRY
433 & ocean(ng) % tl_zeta(:,:,kout), &
434 & setfillval = .false.)
435# else
436# ifdef FORCING_SV
437 & ocean(ng) % f_zeta(:,:))
438# else
439 & ocean(ng) % tl_zeta(:,:,kout))
440# endif
441# endif
442 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
443 IF (master) THEN
444 WRITE (stdout,20) trim(vname(1,idfsur)), tlm(ng)%Rindex
445 END IF
446 exit_flag=3
447 ioerror=status
448 RETURN
449 END IF
450
451# if defined FORWARD_WRITE && defined FORWARD_RHS
452!
453 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idrzet, &
454 & tlm(ng)%Vid(idrzet), &
455 & tlm(ng)%Rindex, gtype, &
456 & lbi, ubi, lbj, ubj, scale, &
457# ifdef MASKING
458 & grid(ng) % rmask, &
459# endif
460 & ocean(ng) % tl_rzeta(:,:,kout))
461 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
462 IF (master) THEN
463 WRITE (stdout,20) trim(vname(1,idrzet)), tlm(ng)%Rindex
464 END IF
465 exit_flag=3
466 ioerror=status
467 RETURN
468 END IF
469# endif
470 END IF
471
472# ifdef ADJUST_BOUNDARY
473!
474! Write out free-surface open boundaries.
475!
476 IF (any(lobc(:,isfsur,ng))) THEN
477 scale=1.0_dp
478 status=nf_fwrite2d_bry(ng, model, tlm(ng)%name, tlm(ng)%ncid, &
479 & vname(1,idsbry(isfsur)), &
480 & tlm(ng)%Vid(idsbry(isfsur)), &
481 & tlm(ng)%Rindex, r2dvar, &
482 & lbij, ubij, nbrec(ng), scale, &
483 & boundary(ng) % tl_zeta_obc(lbij:,:,:, &
484 & lbout(ng)))
485 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
486 IF (master) THEN
487 WRITE (stdout,20) trim(vname(1,idsbry(isfsur))), &
488 & tlm(ng)%Rindex
489 END IF
490 exit_flag=3
491 ioerror=status
492 RETURN
493 END IF
494 END IF
495# endif
496!
497! Write out 2D U-momentum component (m/s).
498!
499 IF (hout(idubar,ng)) THEN
500 scale=1.0_dp
501 gtype=gfactor*u2dvar
502 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idubar, &
503 & tlm(ng)%Vid(idubar), &
504 & tlm(ng)%Rindex, gtype, &
505 & lbi, ubi, lbj, ubj, scale, &
506# ifdef MASKING
507 & grid(ng) % umask_full, &
508# endif
509# ifdef FORCING_SV
510 & ocean(ng) % f_ubar(:,:))
511# else
512 & ocean(ng) % tl_ubar(:,:,kout))
513# endif
514 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
515 IF (master) THEN
516 WRITE (stdout,20) trim(vname(1,idubar)), tlm(ng)%Rindex
517 END IF
518 exit_flag=3
519 ioerror=status
520 RETURN
521 END IF
522
523# ifdef FORWARD_WRITE
524# ifdef FORWARD_RHS
525!
526 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idru2d, &
527 & tlm(ng)%Vid(idru2d), &
528 & tlm(ng)%Rindex, gtype, &
529 & lbi, ubi, lbj, ubj, scale, &
530# ifdef MASKING
531 & grid(ng) % umask_full, &
532# endif
533 & ocean(ng) % tl_rubar(:,:,kout))
534 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
535 IF (master) THEN
536 WRITE (stdout,20) trim(vname(1,idru2d)), tlm(ng)%Rindex
537 END IF
538 exit_flag=3
539 ioerror=status
540 RETURN
541 END IF
542# endif
543# ifdef SOLVE3D
544# ifdef FORWARD_RHS
545!
546 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idruct, &
547 & tlm(ng)%Vid(idruct), &
548 & tlm(ng)%Rindex, gtype, &
549 & lbi, ubi, lbj, ubj, scale, &
550# ifdef MASKING
551 & grid(ng) % umask_full, &
552# endif
553 & coupling(ng) % tl_rufrc)
554 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
555 IF (master) THEN
556 WRITE (stdout,20) trim(vname(1,idruct)), tlm(ng)%Rindex
557 END IF
558 exit_flag=3
559 ioerror=status
560 RETURN
561 END IF
562# endif
563!
564 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idufx1, &
565 & tlm(ng)%Vid(idufx1), &
566 & tlm(ng)%Rindex, gtype, &
567 & lbi, ubi, lbj, ubj, scale, &
568# ifdef MASKING
569 & grid(ng) % umask_full, &
570# endif
571 & coupling(ng) % tl_DU_avg1)
572 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
573 IF (master) THEN
574 WRITE (stdout,20) trim(vname(1,idufx1)), tlm(ng)%Rindex
575 END IF
576 exit_flag=3
577 ioerror=status
578 RETURN
579 END IF
580!
581 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idufx2, &
582 & tlm(ng)%Vid(idufx2), &
583 & tlm(ng)%Rindex, gtype, &
584 & lbi, ubi, lbj, ubj, scale, &
585# ifdef MASKING
586 & grid(ng) % umask_full, &
587# endif
588 & coupling(ng) % tl_DU_avg2)
589 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
590 IF (master) THEN
591 WRITE (stdout,20) trim(vname(1,idufx2)), tlm(ng)%Rindex
592 END IF
593 exit_flag=3
594 ioerror=status
595 RETURN
596 END IF
597# endif
598# endif
599 END IF
600
601# ifdef ADJUST_BOUNDARY
602!
603! Write out 2D U-momentum component open boundaries.
604!
605 IF (any(lobc(:,isubar,ng))) THEN
606 scale=1.0_dp
607 status=nf_fwrite2d_bry(ng, model, tlm(ng)%name, tlm(ng)%ncid, &
608 & vname(1,idsbry(isubar)), &
609 & tlm(ng)%Vid(idsbry(isubar)), &
610 & tlm(ng)%Rindex, u2dvar, &
611 & lbij, ubij, nbrec(ng), scale, &
612 & boundary(ng) % tl_ubar_obc(lbij:,:,:, &
613 & lbout(ng)))
614 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
615 IF (master) THEN
616 WRITE (stdout,20) trim(vname(1,idsbry(isubar))), &
617 & tlm(ng)%Rindex
618 END IF
619 exit_flag=3
620 ioerror=status
621 RETURN
622 END IF
623 END IF
624# endif
625!
626! Write out 2D V-momentum component (m/s).
627!
628 IF (hout(idvbar,ng)) THEN
629 scale=1.0_dp
630 gtype=gfactor*v2dvar
631 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idvbar, &
632 & tlm(ng)%Vid(idvbar), &
633 & tlm(ng)%Rindex, gtype, &
634 & lbi, ubi, lbj, ubj, scale, &
635# ifdef MASKING
636 & grid(ng) % vmask_full, &
637# endif
638# ifdef FORCING_SV
639 & ocean(ng) % f_vbar(:,:))
640# else
641 & ocean(ng) % tl_vbar(:,:,kout))
642# endif
643 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
644 IF (master) THEN
645 WRITE (stdout,20) trim(vname(1,idvbar)), tlm(ng)%Rindex
646 END IF
647 exit_flag=3
648 ioerror=status
649 RETURN
650 END IF
651
652# ifdef FORWARD_WRITE
653# ifdef FORWARD_RHS
654!
655 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idrv2d, &
656 & tlm(ng)%Vid(idrv2d), &
657 & tlm(ng)%Rindex, gtype, &
658 & lbi, ubi, lbj, ubj, scale, &
659# ifdef MASKING
660 & grid(ng) % vmask_full, &
661# endif
662 & ocean(ng) % tl_rvbar(:,:,kout))
663 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
664 IF (master) THEN
665 WRITE (stdout,20) trim(vname(1,idrv2d)), tlm(ng)%Rindex
666 END IF
667 exit_flag=3
668 ioerror=status
669 RETURN
670 END IF
671# endif
672# ifdef SOLVE3D
673# ifdef FORWARD_RHS
674!
675 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idrvct, &
676 & tlm(ng)%Vid(idrvct), &
677 & tlm(ng)%Rindex, gtype, &
678 & lbi, ubi, lbj, ubj, scale, &
679# ifdef MASKING
680 & grid(ng) % vmask_full, &
681# endif
682 & coupling(ng) % tl_rvfrc)
683 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
684 IF (master) THEN
685 WRITE (stdout,20) trim(vname(1,idrvct)), tlm(ng)%Rindex
686 END IF
687 exit_flag=3
688 ioerror=status
689 RETURN
690 END IF
691# endif
692!
693 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idvfx1, &
694 & tlm(ng)%Vid(idvfx1), &
695 & tlm(ng)%Rindex, gtype, &
696 & lbi, ubi, lbj, ubj, scale, &
697# ifdef MASKING
698 & grid(ng) % vmask_full, &
699# endif
700 & coupling(ng) % tl_DV_avg1)
701 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
702 IF (master) THEN
703 WRITE (stdout,20) trim(vname(1,idvfx1)), tlm(ng)%Rindex
704 END IF
705 exit_flag=3
706 ioerror=status
707 RETURN
708 END IF
709!
710 status=nf_fwrite2d(ng, model, tlm(ng)%ncid, idvfx2, &
711 & tlm(ng)%Vid(idvfx2), &
712 & tlm(ng)%Rindex, gtype, &
713 & lbi, ubi, lbj, ubj, scale, &
714# ifdef MASKING
715 & grid(ng) % vmask_full, &
716# endif
717 & coupling(ng) % tl_DV_avg2)
718 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
719 IF (master) THEN
720 WRITE (stdout,20) trim(vname(1,idvfx2)), tlm(ng)%Rindex
721 END IF
722 exit_flag=3
723 ioerror=status
724 RETURN
725 END IF
726# endif
727# endif
728 END IF
729
730# ifdef ADJUST_BOUNDARY
731!
732! Write out 2D V-momentum component open boundaries.
733!
734 IF (any(lobc(:,isvbar,ng))) THEN
735 scale=1.0_dp
736 status=nf_fwrite2d_bry(ng, model, tlm(ng)%name, tlm(ng)%ncid, &
737 & vname(1,idsbry(isvbar)), &
738 & tlm(ng)%Vid(idsbry(isvbar)), &
739 & tlm(ng)%Rindex, v2dvar, &
740 & lbij, ubij, nbrec(ng), scale, &
741 & boundary(ng) % tl_vbar_obc(lbij:,:,:, &
742 & lbout(ng)))
743 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
744 IF (master) THEN
745 WRITE (stdout,20) trim(vname(1,idsbry(isvbar))), &
746 & tlm(ng)%Rindex
747 END IF
748 exit_flag=3
749 ioerror=status
750 RETURN
751 END IF
752 END IF
753# endif
754# ifdef SOLVE3D
755!
756! Write out 3D U-momentum component (m/s).
757!
758 IF (hout(iduvel,ng)) THEN
759 scale=1.0_dp
760 gtype=gfactor*u3dvar
761 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, iduvel, &
762 & tlm(ng)%Vid(iduvel), &
763 & tlm(ng)%Rindex, gtype, &
764 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
765# ifdef MASKING
766 & grid(ng) % umask_full, &
767# endif
768# ifdef FORCING_SV
769 & ocean(ng) % f_u(:,:,:))
770# else
771 & ocean(ng) % tl_u(:,:,:,nout))
772# endif
773 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
774 IF (master) THEN
775 WRITE (stdout,20) trim(vname(1,iduvel)), tlm(ng)%Rindex
776 END IF
777 exit_flag=3
778 ioerror=status
779 RETURN
780 END IF
781
782# if defined FORWARD_WRITE && defined FORWARD_RHS
783!
784 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idru3d, &
785 & tlm(ng)%Vid(idru3d), &
786 & tlm(ng)%Rindex, gtype, &
787 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
788# ifdef MASKING
789 & grid(ng) % umask_full, &
790# endif
791 & ocean(ng) % tl_ru(:,:,:,nout))
792 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
793 IF (master) THEN
794 WRITE (stdout,20) trim(vname(1,idru3d)), tlm(ng)%Rindex
795 END IF
796 exit_flag=3
797 ioerror=status
798 RETURN
799 END IF
800# endif
801 END IF
802
803# ifdef ADJUST_BOUNDARY
804!
805! Write out 3D U-momentum component open boundaries.
806!
807 IF (any(lobc(:,isuvel,ng))) THEN
808 scale=1.0_dp
809 status=nf_fwrite3d_bry(ng, model, tlm(ng)%name, tlm(ng)%ncid, &
810 & vname(1,idsbry(isuvel)), &
811 & tlm(ng)%Vid(idsbry(isuvel)), &
812 & tlm(ng)%Rindex, u3dvar, &
813 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
814 & boundary(ng) % tl_u_obc(lbij:,:,:,:, &
815 & lbout(ng)))
816 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
817 IF (master) THEN
818 WRITE (stdout,20) trim(vname(1,idsbry(isuvel))), &
819 & tlm(ng)%Rindex
820 END IF
821 exit_flag=3
822 ioerror=status
823 RETURN
824 END IF
825 END IF
826# endif
827!
828! Write out 3D V-momentum component (m/s).
829!
830 IF (hout(idvvel,ng)) THEN
831 scale=1.0_dp
832 gtype=gfactor*v3dvar
833 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idvvel, &
834 & tlm(ng)%Vid(idvvel), &
835 & tlm(ng)%Rindex, gtype, &
836 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
837# ifdef MASKING
838 & grid(ng) % vmask_full, &
839# endif
840# ifdef FORCING_SV
841 & ocean(ng) % f_v(:,:,:))
842# else
843 & ocean(ng) % tl_v(:,:,:,nout))
844# endif
845 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
846 IF (master) THEN
847 WRITE (stdout,20) trim(vname(1,idvvel)), tlm(ng)%Rindex
848 END IF
849 exit_flag=3
850 ioerror=status
851 RETURN
852 END IF
853
854# if defined FORWARD_WRITE && defined FORWARD_RHS
855!
856 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idrv3d, &
857 & tlm(ng)%Vid(idrv3d), &
858 & tlm(ng)%Rindex, gtype, &
859 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
860# ifdef MASKING
861 & grid(ng) % vmask_full, &
862# endif
863 & ocean(ng) % tl_rv(:,:,:,nout))
864 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
865 IF (master) THEN
866 WRITE (stdout,20) trim(vname(1,idrv3d)), tlm(ng)%Rindex
867 END IF
868 exit_flag=3
869 ioerror=status
870 RETURN
871 END IF
872# endif
873 END IF
874
875# ifdef ADJUST_BOUNDARY
876!
877! Write out 3D V-momentum component open boundaries.
878!
879 IF (any(lobc(:,isvvel,ng))) THEN
880 scale=1.0_dp
881 status=nf_fwrite3d_bry(ng, model, tlm(ng)%name, tlm(ng)%ncid, &
882 & vname(1,idsbry(isvvel)), &
883 & tlm(ng)%Vid(idsbry(isvvel)), &
884 & tlm(ng)%Rindex, v3dvar, &
885 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
886 & boundary(ng) % tl_v_obc(lbij:,:,:,:, &
887 & lbout(ng)))
888 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
889 IF (master) THEN
890 WRITE (stdout,20) trim(vname(1,idsbry(isvvel))), &
891 & tlm(ng)%Rindex
892 END IF
893 exit_flag=3
894 ioerror=status
895 RETURN
896 END IF
897 END IF
898# endif
899# ifdef UV_DESTAGGERED
900!
901! Write out 3D Eastward momentum (m/s) at RHO-points, A-grid.
902!
903 IF (hout(idu3de,ng)) THEN
904 scale=1.0_dp
905 gtype=gfactor*r3dvar
906 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idu3de, &
907 & tlm(ng)%Vid(idu3de), &
908 & tlm(ng)%Rindex, gtype, &
909 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
910# ifdef MASKING
911 & grid(ng) % rmask_full, &
912# endif
913 & ocean(ng) % tl_ua)
914 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
915 IF (master) THEN
916 WRITE (stdout,20) trim(vname(1,idu3de)), tlm(ng)%Rindex
917 END IF
918 exit_flag=3
919 ioerror=status
920 RETURN
921 END IF
922 END IF
923!
924! Write out 3D Northward momentum (m/s) at RHO-points, A-grid.
925!
926 IF (hout(idv3dn,ng)) THEN
927 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idv3dn, &
928 & tlm(ng)%Vid(idv3dn), &
929 & tlm(ng)%Rindex, gtype, &
930 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
931# ifdef MASKING
932 & grid(ng) % rmask_full, &
933# endif
934 & ocean(ng) % tl_va)
935 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
936 IF (master) THEN
937 WRITE (stdout,20) trim(vname(1,idv3dn)), tlm(ng)%Rindex
938 END IF
939 exit_flag=3
940 ioerror=status
941 RETURN
942 END IF
943 END IF
944# endif
945!
946! Write out tracer type variables.
947!
948 DO itrc=1,nt(ng)
949 IF (hout(idtvar(itrc),ng)) THEN
950 scale=1.0_dp
951 gtype=gfactor*r3dvar
952 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idtvar(itrc), &
953 & tlm(ng)%Tid(itrc), &
954 & tlm(ng)%Rindex, gtype, &
955 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
956# ifdef MASKING
957 & grid(ng) % rmask, &
958# endif
959# ifdef FORCING_SV
960 & ocean(ng) % f_t(:,:,:,itrc))
961# else
962 & ocean(ng) % tl_t(:,:,:,nout,itrc))
963# endif
964 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
965 IF (master) THEN
966 WRITE (stdout,20) trim(vname(1,idtvar(itrc))), &
967 & tlm(ng)%Rindex
968 END IF
969 exit_flag=3
970 ioerror=status
971 RETURN
972 END IF
973 END IF
974 END DO
975
976# ifdef ADJUST_BOUNDARY
977!
978! Write out tracers open boundaries.
979!
980 DO itrc=1,nt(ng)
981 IF (any(lobc(:,istvar(itrc),ng))) THEN
982 scale=1.0_dp
983 status=nf_fwrite3d_bry(ng, model, tlm(ng)%name, tlm(ng)%ncid, &
984 & vname(1,idsbry(istvar(itrc))), &
985 & tlm(ng)%Vid(idsbry(istvar(itrc))), &
986 & tlm(ng)%Rindex, r3dvar, &
987 & lbij, ubij, 1, n(ng), nbrec(ng), &
988 & scale, &
989 & boundary(ng) % tl_t_obc(lbij:,:,:,:, &
990 & lbout(ng),itrc))
991 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
992 IF (master) THEN
993 WRITE (stdout,20) trim(vname(1,idsbry(istvar(itrc)))), &
994 & tlm(ng)%Rindex
995 END IF
996 exit_flag=3
997 ioerror=status
998 RETURN
999 END IF
1000 END IF
1001 END DO
1002# endif
1003!
1004! Write out density anomaly.
1005!
1006 IF (hout(iddano,ng)) THEN
1007 scale=1.0_dp
1008 gtype=gfactor*r3dvar
1009 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, iddano, &
1010 & tlm(ng)%Vid(iddano), &
1011 & tlm(ng)%Rindex, gtype, &
1012 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1013# ifdef MASKING
1014 & grid(ng) % rmask, &
1015# endif
1016 & ocean(ng) % tl_rho)
1017 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1018 IF (master) THEN
1019 WRITE (stdout,20) trim(vname(1,iddano)), tlm(ng)%Rindex
1020 END IF
1021 exit_flag=3
1022 ioerror=status
1023 RETURN
1024 END IF
1025 END IF
1026
1027# if defined FORWARD_MIXING && \
1028 (defined bvf_mixing || defined gls_mixing || \
1029 defined lmd_mixing || defined my25_mixing)
1030!
1031! Write out vertical viscosity coefficient.
1032!
1033 IF (hout(idvvis,ng)) THEN
1034 scale=1.0_dp
1035 gtype=gfactor*w3dvar
1036 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idvvis, &
1037 & tlm(ng)%Vid(idvvis), &
1038 & tlm(ng)%Rindex, gtype, &
1039 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1040# ifdef MASKING
1041 & grid(ng) % rmask, &
1042# endif
1043# ifdef WEAK_CONSTRAINT
1044 & mixing(ng) % Akv, &
1045# else
1046 & mixing(ng) % tl_Akv, &
1047# endif
1048 & setfillval = .false.)
1049 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1050 IF (master) THEN
1051 WRITE (stdout,20) trim(vname(1,idvvis)), tlm(ng)%Rindex
1052 END IF
1053 exit_flag=3
1054 ioerror=status
1055 RETURN
1056 END IF
1057 END IF
1058!
1059! Write out vertical diffusion coefficient for potential temperature.
1060!
1061 IF (hout(idtdif,ng)) THEN
1062 scale=1.0_dp
1063 gtype=gfactor*w3dvar
1064 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idtdif, &
1065 & tlm(ng)%Vid(idtdif), &
1066 & tlm(ng)%Rindex, gtype, &
1067 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1068# ifdef MASKING
1069 & grid(ng) % rmask, &
1070# endif
1071# ifdef WEAK_CONSTRAINT
1072 & mixing(ng) % Akt(:,:,:,itemp), &
1073# else
1074 & mixing(ng) % tl_Akt(:,:,:,itemp), &
1075# endif
1076 & setfillval = .false.)
1077 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1078 IF (master) THEN
1079 WRITE (stdout,20) trim(vname(1,idtdif)), tlm(ng)%Rindex
1080 END IF
1081 exit_flag=3
1082 ioerror=status
1083 RETURN
1084 END IF
1085 END IF
1086
1087# ifdef SALINITY
1088!
1089! Write out vertical diffusion coefficient for salinity.
1090!
1091 IF (hout(idsdif,ng)) THEN
1092 scale=1.0_dp
1093 gtype=gfactor*w3dvar
1094 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idsdif, &
1095 & tlm(ng)%Vid(idsdif), &
1096 & tlm(ng)%Rindex, gtype, &
1097 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1098# ifdef MASKING
1099 & grid(ng) % rmask, &
1100# endif
1101# ifdef WEAK_CONSTRAINT
1102 & mixing(ng) % Akt(:,:,:,isalt), &
1103# else
1104 & mixing(ng) % tl_Akt(:,:,:,isalt), &
1105# endif
1106 & setfillval = .false.)
1107 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1108 IF (master) THEN
1109 WRITE (stdout,20) trim(vname(1,idsdif)), tlm(ng)%Rindex
1110 END IF
1111 exit_flag=3
1112 ioerror=status
1113 RETURN
1114 END IF
1115 END IF
1116# endif
1117# if defined GLS_MIXING_NOT_YET || defined MY25_MIXING_NOT_YET
1118!
1119! Write out turbulent kinetic energy.
1120!
1121 IF (hout(idmtke,ng)) THEN
1122 scale=1.0_dp
1123 gtype=gfactor*w3dvar
1124 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idmtke, &
1125 & tlm(ng)%Vid(idmtke), &
1126 & tlm(ng)%Rindex, gtype, &
1127 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1128# ifdef MASKING
1129 & grid(ng) % rmask, &
1130# endif
1131 & mixing(ng) % tl_tke(:,:,:,nout), &
1132 & setfillval = .false.)
1133 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1134 IF (master) THEN
1135 WRITE (stdout,20) trim(vname(1,idmtke)), tlm(ng)%Rindex
1136 END IF
1137 exit_flag=3
1138 ioerror=status
1139 RETURN
1140 END IF
1141!
1142 scale=1.0_dp
1143 gtype=gfactor*w3dvar
1144 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idvmkk, &
1145 & tlm(ng)%Vid(idvmkk), &
1146 & tlm(ng)%Rindex, gtype, &
1147 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1148# ifdef MASKING
1149 & grid(ng) % rmask, &
1150# endif
1151 & mixing(ng) % tl_Akk)
1152 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1153 IF (master) THEN
1154 WRITE (stdout,20) trim(vname(1,idvmkk)), tlm(ng)%Rindex
1155 END IF
1156 exit_flag=3
1157 ioerror=status
1158 RETURN
1159 END IF
1160 END IF
1161!
1162! Write out turbulent length scale field.
1163!
1164 IF (hout(idmtls,ng)) THEN
1165 scale=1.0_dp
1166 gtype=gfactor*w3dvar
1167 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idmtls, &
1168 & tlm(ng)%Vid(idmtls), &
1169 & tlm(ng)%Rindex, gtype, &
1170 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1171# ifdef MASKING
1172 & grid(ng) % rmask, &
1173# endif
1174 & mixing(ng) % tl_gls(:,:,:,nout), &
1175 & setfillval = .false.)
1176 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1177 IF (master) THEN
1178 WRITE (stdout,20) trim(vname(1,idmtls)), tlm(ng)%Rindex
1179 END IF
1180 exit_flag=3
1181 ioerror=status
1182 RETURN
1183 END IF
1184!
1185 scale=1.0_dp
1186 gtype=gfactor*w3dvar
1187 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idvmls, &
1188 & tlm(ng)%Vid(idvmls), &
1189 & tlm(ng)%Rindex, gtype, &
1190 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1191# ifdef MASKING
1192 & grid(ng) % rmask, &
1193# endif
1194 & mixing(ng) % tl_Lscale)
1195 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1196 IF (master) THEN
1197 WRITE (stdout,20) trim(vname(1,idvmls)), tlm(ng)%Rindex
1198 END IF
1199 exit_flag=3
1200 ioerror=status
1201 RETURN
1202 END IF
1203
1204# ifdef GSL_MIXING
1205 scale=1.0_dp
1206 gtype=gfactor*w3dvar
1207 status=nf_fwrite3d(ng, model, tlm(ng)%ncid, idvmkp, &
1208 & tlm(ng)%Vid(idvmkp), &
1209 & tlm(ng)%Rindex, gtype, &
1210 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1211# ifdef MASKING
1212 & grid(ng) % rmask, &
1213# endif
1214 & mixing(ng) % tl_Akp)
1215 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
1216 IF (master) THEN
1217 WRITE (stdout,20) trim(vname(1,idvmkp)), tlm(ng)%Rindex
1218 END IF
1219 exit_flag=3
1220 ioerror=status
1221 RETURN
1222 END IF
1223# endif
1224 END IF
1225# endif
1226# endif
1227# endif
1228!
1229!-----------------------------------------------------------------------
1230! Synchronize tangent NetCDF file to disk to allow other processes
1231! to access data immediately after it is written.
1232!-----------------------------------------------------------------------
1233!
1234 CALL netcdf_sync (ng, model, tlm(ng)%name, tlm(ng)%ncid)
1235 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1236!
1237 10 FORMAT (2x,'TL_WRT_HIS_NF90 - writing history', t42, &
1238# ifdef SOLVE3D
1239# ifdef NESTING
1240 & 'fields (Index=',i1,',',i1,') in record = ',i0,t92,i2.2)
1241# else
1242 & 'fields (Index=',i1,',',i1,') in record = ',i0)
1243# endif
1244# else
1245# ifdef NESTING
1246 & 'fields (Index=',i1,') in record = ',i0,t92,i2.2)
1247# else
1248 & 'fields (Index=',i1,') in record = ',i0)
1249# endif
1250# endif
1251 20 FORMAT (/,' TL_WRT_HIS_NF90 - error while writing variable: ',a, &
1252 & /,19x,'into tangent NetCDF file for time record: ',i0)
1253!
1254 RETURN
1255 END SUBROUTINE tl_wrt_his_nf90
1256
1257# if defined PIO_LIB && defined DISTRIBUTE
1258!
1259!***********************************************************************
1260 SUBROUTINE tl_wrt_his_pio (ng, model, tile, &
1261# ifdef ADJUST_BOUNDARY
1262 & LBij, UBij, &
1263# endif
1264 & LBi, UBi, LBj, UBj)
1265!***********************************************************************
1266!
1267 USE mod_pio_netcdf
1268!
1269! Imported variable declarations.
1270!
1271 integer, intent(in) :: ng, model, tile
1272# ifdef ADJUST_BOUNDARY
1273 integer, intent(in) :: lbij, ubij
1274# endif
1275 integer, intent(in) :: lbi, ubi, lbj, ubj
1276!
1277! Local variable declarations.
1278!
1279 integer :: fcount, ifield, status
1280# ifdef SOLVE3D
1281 integer :: i, itrc, j, k
1282# endif
1283!
1284 real(dp) :: scale
1285 real(r8) :: tval(1)
1286!
1287 character (len=*), parameter :: myfile = &
1288 & __FILE__//", tl_wrt_his_pio"
1289!
1290 TYPE (io_desc_t), pointer :: iodesc
1291!
1292 sourcefile=myfile
1293!
1294!-----------------------------------------------------------------------
1295! Write out tangent linear fields.
1296!-----------------------------------------------------------------------
1297!
1298 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1299!
1300! Set time record index.
1301!
1302 tlm(ng)%Rindex=tlm(ng)%Rindex+1
1303 fcount=tlm(ng)%load
1304 tlm(ng)%Nrec(fcount)=tlm(ng)%Nrec(fcount)+1
1305!
1306! Report.
1307!
1308# ifdef SOLVE3D
1309# ifdef NESTING
1310 IF (master) WRITE (stdout,10) kout, nout, tlm(ng)%Rindex, ng
1311# else
1312 IF (master) WRITE (stdout,10) kout, nout, tlm(ng)%Rindex
1313# endif
1314# else
1315# ifdef NESTING
1316 IF (master) WRITE (stdout,10) kout, tlm(ng)%Rindex, ng
1317# else
1318 IF (master) WRITE (stdout,10) kout, tlm(ng)%Rindex
1319# endif
1320# endif
1321!
1322! If requested, set time index to recycle time records in the tangent
1323! linear file.
1324!
1325 IF (lcycletlm(ng)) THEN
1326 tlm(ng)%Rindex=mod(tlm(ng)%Rindex-1,2)+1
1327 END IF
1328!
1329! Write out model time (s).
1330!
1331 IF (lwrtper(ng)) THEN
1332 tval(1)=real(tlm(ng)%Rindex,r8)*day2sec
1333 ELSE
1334 tval(1)=time(ng)
1335 END IF
1336 CALL pio_netcdf_put_fvar (ng, model, tlm(ng)%name, &
1337 & trim(vname(1,idtime)), tval, &
1338 & (/tlm(ng)%Rindex/), (/1/), &
1339 & piofile = tlm(ng)%pioFile, &
1340 & piovar = tlm(ng)%pioVar(idtime)%vd)
1341 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1342
1343# ifdef ADJUST_WSTRESS
1344!
1345! Write out surface U-momentum stress. Notice that the stress has its
1346! own fixed time-dimension (of size Nfrec) to allow 4DVAR adjustments
1347! at other times in addition to initialization time.
1348!
1349 scale=1.0_dp ! m2/s2
1350 IF (tlm(ng)%pioVar(idusms)%dkind.eq.pio_double) THEN
1351 iodesc => iodesc_dp_u2dfrc(ng)
1352 ELSE
1353 iodesc => iodesc_sp_u2dfrc(ng)
1354 END IF
1355!
1356 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idusms, &
1357 & tlm(ng)%pioVar(idusms), &
1358 & tlm(ng)%Rindex, iodesc, &
1359 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
1360# ifdef MASKING
1361 & grid(ng) % umask, &
1362# endif
1363 & forces(ng) % tl_ustr(:,:,:,lfout(ng)))
1364 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1365 IF (master) THEN
1366 WRITE (stdout,20) trim(vname(1,idusms)), lfout(ng)
1367 END IF
1368 exit_flag=3
1369 ioerror=status
1370 RETURN
1371 END IF
1372!
1373! Write out surface V-momentum stress.
1374!
1375 scale=1.0_dp ! m2/s2
1376 IF (tlm(ng)%pioVar(idvsms)%dkind.eq.pio_double) THEN
1377 iodesc => iodesc_dp_v2dfrc(ng)
1378 ELSE
1379 iodesc => iodesc_sp_v2dfrc(ng)
1380 END IF
1381!
1382 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idvsms, &
1383 & tlm(ng)%pioVar(idvsms), &
1384 & tlm(ng)%Rindex, iodesc, &
1385 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
1386# ifdef MASKING
1387 & grid(ng) % vmask, &
1388# endif
1389 & forces(ng) % tl_vstr(:,:,:,lfout(ng)))
1390 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1391 IF (master) THEN
1392 WRITE (stdout,20) trim(vname(1,idvsms)), lfout(ng)
1393 END IF
1394 exit_flag=3
1395 ioerror=status
1396 RETURN
1397 END IF
1398# endif
1399# if defined ADJUST_STFLUX && defined SOLVE3D
1400!
1401! Write out surface net tracers fluxes. Notice that fluxes have their
1402! own fixed time-dimension (of size Nfrec) to allow 4DVAR adjustments
1403! at other times in addition to initialization time.
1404!
1405 DO itrc=1,nt(ng)
1406 IF (lstflux(itrc,ng)) THEN
1407 scale=1.0_dp ! kinematic flux units
1408 IF (tlm(ng)%pioVar(idtsur(itrc))%dkind.eq.pio_double) THEN
1409 iodesc => iodesc_dp_r2dfrc(ng)
1410 ELSE
1411 iodesc => iodesc_sp_r2dfrc(ng)
1412 END IF
1413!
1414 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idtsur(itrc), &
1415 & tlm(ng)%pioVar(idtsur(itrc)), &
1416 & tlm(ng)%Rindex, iodesc, &
1417 & lbi, ubi, lbj, ubj, 1, nfrec(ng), scale, &
1418# ifdef MASKING
1419 & grid(ng) % rmask, &
1420# endif
1421 & forces(ng)% tl_tflux(:,:,:,lfout(ng),itrc))
1422 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1423 IF (master) THEN
1424 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), lfout(ng)
1425 END IF
1426 exit_flag=3
1427 ioerror=status
1428 RETURN
1429 END IF
1430 END IF
1431 END DO
1432# endif
1433# if defined FORCING_SV || defined STOCHASTIC_OPT || \
1434 defined hessian_so || defined hessian_fsv
1435!
1436! Write out surface U-momentum stress.
1437!
1438 IF (hout(idusms,ng)) THEN
1439 scale=1.0_dp
1440 IF (tlm(ng)%pioVar(idusms)%dkind.eq.pio_double) THEN
1441 iodesc => iodesc_dp_u2dvar(ng)
1442 ELSE
1443 iodesc => iodesc_sp_u2dvar(ng)
1444 END IF
1445!
1446 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idusms, &
1447 & tlm(ng)%pioVar(idusms), &
1448 & tlm(ng)%Rindex, iodesc, &
1449 & lbi, ubi, lbj, ubj, scale, &
1450# ifdef MASKING
1451 & grid(ng) % umask, &
1452# endif
1453 & forces(ng) % tl_sustr)
1454 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1455 IF (master) THEN
1456 WRITE (stdout,20) trim(vname(1,idusms)), tlm(ng)%Rindex
1457 END IF
1458 exit_flag=3
1459 ioerror=status
1460 RETURN
1461 END IF
1462 END IF
1463!
1464! Write out surface V-momentum stress.
1465!
1466 IF (hout(idvsms,ng)) THEN
1467 scale=1.0_dp
1468 IF (tlm(ng)%pioVar(idvsms)%dkind.eq.pio_double) THEN
1469 iodesc => iodesc_dp_v2dvar(ng)
1470 ELSE
1471 iodesc => iodesc_sp_v2dvar(ng)
1472 END IF
1473!
1474 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idvsms, &
1475 & tlm(ng)%pioVar(idvsms), &
1476 & tlm(ng)%Rindex, iodesc, &
1477 & lbi, ubi, lbj, ubj, scale, &
1478# ifdef MASKING
1479 & grid(ng) % vmask, &
1480# endif
1481 & forces(ng) % tl_svstr)
1482 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1483 IF (master) THEN
1484 WRITE (stdout,20) trim(vname(1,idvsms)), tlm(ng)%Rindex
1485 END IF
1486 exit_flag=3
1487 ioerror=status
1488 RETURN
1489 END IF
1490 END IF
1491
1492# ifdef SOLVE3D
1493!
1494! Write out net surface active tracer fluxes.
1495!
1496 DO itrc=1,nt(ng)
1497 IF (hout(idtsur(itrc),ng)) THEN
1498 scale=1.0_dp
1499 IF (tlm(ng)%pioVar(idtsur(itrc))%dkind.eq.pio_double) THEN
1500 iodesc => iodesc_dp_r2dvar(ng)
1501 ELSE
1502 iodesc => iodesc_sp_r2dvar(ng)
1503 END IF
1504!
1505 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idtsur(itrc), &
1506 & tlm(ng)%pioVar(idtsur(itrc)), &
1507 & tlm(ng)%Rindex, iodesc, &
1508 & lbi, ubi, lbj, ubj, scale, &
1509# ifdef MASKING
1510 & grid(ng) % rmask, &
1511# endif
1512 & forces(ng) % tl_stflx(:,:,itrc))
1513 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1514 IF (master) THEN
1515 WRITE (stdout,20) trim(vname(1,idtsur(itrc))), &
1516 & tlm(ng)%Rindex
1517 END IF
1518 exit_flag=3
1519 ioerror=status
1520 RETURN
1521 END IF
1522 END IF
1523 END DO
1524# endif
1525# endif
1526# ifdef SOLVE3D
1527!
1528! Write time-varying depths of RHO-points.
1529!
1530 IF (hout(idpthr,ng)) THEN
1531 scale=1.0_dp
1532 IF (his(ng)%pioVar(idpthr)%dkind.eq.pio_double) THEN
1533 iodesc => iodesc_dp_r3dvar(ng)
1534 ELSE
1535 iodesc => iodesc_sp_r3dvar(ng)
1536 END IF
1537 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idpthr, &
1538 & tlm(ng)%pioVar(idpthr), &
1539 & tlm(ng)%Rindex, &
1540 & iodesc, &
1541 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
1542# ifdef MASKING
1543 & grid(ng) % rmask, &
1544# endif
1545 & grid(ng) % tl_z_r, &
1546 & setfillval = .false.)
1547 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1548 IF (master) THEN
1549 WRITE (stdout,20) trim(vname(1,idpthr)), tlm(ng)%Rindex
1550 END IF
1551 exit_flag=3
1552 ioerror=status
1553 RETURN
1554 END IF
1555 END IF
1556!
1557! Write time-varying depths of W-points.
1558!
1559 IF (hout(idpthw,ng)) THEN
1560 scale=1.0_dp
1561 IF (his(ng)%pioVar(idpthw)%dkind.eq.pio_double) THEN
1562 iodesc => iodesc_dp_w3dvar(ng)
1563 ELSE
1564 iodesc => iodesc_sp_w3dvar(ng)
1565 END IF
1566 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idpthw, &
1567 & tlm(ng)%pioVar(idpthw), &
1568 & tlm(ng)%Rindex, &
1569 & iodesc, &
1570 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
1571# ifdef MASKING
1572 & grid(ng) % rmask, &
1573# endif
1574 & grid(ng) % tl_z_w, &
1575 & setfillval = .false.)
1576 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1577 IF (master) THEN
1578 WRITE (stdout,20) trim(vname(1,idpthw)), tlm(ng)%Rindex
1579 END IF
1580 exit_flag=3
1581 ioerror=status
1582 RETURN
1583 END IF
1584 END IF
1585# endif
1586!
1587! Write out free-surface (m)
1588!
1589 IF (hout(idfsur,ng)) THEN
1590 scale=1.0_dp
1591 IF (tlm(ng)%pioVar(idfsur)%dkind.eq.pio_double) THEN
1592 iodesc => iodesc_dp_r2dvar(ng)
1593 ELSE
1594 iodesc => iodesc_sp_r2dvar(ng)
1595 END IF
1596
1597 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idfsur, &
1598 & tlm(ng)%pioVar(idfsur), &
1599 & tlm(ng)%Rindex, iodesc, &
1600 & lbi, ubi, lbj, ubj, scale, &
1601# ifdef MASKING
1602 & grid(ng) % rmask, &
1603# endif
1604# ifdef WET_DRY
1605 & ocean(ng) % tl_zeta(:,:,kout), &
1606 & setfillval = .false.)
1607# else
1608# ifdef FORCING_SV
1609 & ocean(ng) % f_zeta(:,:))
1610# else
1611 & ocean(ng) % tl_zeta(:,:,kout))
1612# endif
1613# endif
1614 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1615 IF (master) THEN
1616 WRITE (stdout,20) trim(vname(1,idfsur)), tlm(ng)%Rindex
1617 END IF
1618 exit_flag=3
1619 ioerror=status
1620 RETURN
1621 END IF
1622
1623# if defined FORWARD_WRITE && defined FORWARD_RHS
1624!
1625 IF (tlm(ng)%pioVar(idrzet)%dkind.eq.pio_double) THEN
1626 iodesc => iodesc_dp_r2dvar(ng)
1627 ELSE
1628 iodesc => iodesc_sp_r2dvar(ng)
1629 END IF
1630
1631 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idrzet, &
1632 & tlm(ng)%pioVar(idrzet), &
1633 & tlm(ng)%Rindex, iodesc, &
1634 & lbi, ubi, lbj, ubj, scale, &
1635# ifdef MASKING
1636 & grid(ng) % rmask, &
1637# endif
1638 & ocean(ng) % tl_rzeta(:,:,kout))
1639 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1640 IF (master) THEN
1641 WRITE (stdout,20) trim(vname(1,idrzet)), tlm(ng)%Rindex
1642 END IF
1643 exit_flag=3
1644 ioerror=status
1645 RETURN
1646 END IF
1647# endif
1648 END IF
1649
1650# ifdef ADJUST_BOUNDARY
1651!
1652! Write out free-surface open boundaries.
1653!
1654 IF (any(lobc(:,isfsur,ng))) THEN
1655 scale=1.0_dp
1656 ifield=idsbry(isfsur)
1657 IF (tlm(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
1658 iodesc => iodesc_dp_r2dobc(ng)
1659 ELSE
1660 iodesc => iodesc_sp_r2dobc(ng)
1661 END IF
1662!
1663 status=nf_fwrite2d_bry(ng, model, tlm(ng)%name, &
1664 & tlm(ng)%pioFile, &
1665 & vname(1,ifield), &
1666 & tlm(ng)%pioVar(ifield), &
1667 & tlm(ng)%Rindex, iodesc, &
1668 & lbij, ubij, nbrec(ng), scale, &
1669 & boundary(ng) % tl_zeta_obc(lbij:,:,:, &
1670 & lbout(ng)))
1671 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1672 IF (master) THEN
1673 WRITE (stdout,20) trim(vname(1,ifield)), tlm(ng)%Rindex
1674 END IF
1675 exit_flag=3
1676 ioerror=status
1677 RETURN
1678 END IF
1679 END IF
1680# endif
1681!
1682! Write out 2D U-momentum component (m/s).
1683!
1684 IF (hout(idubar,ng)) THEN
1685 scale=1.0_dp
1686 IF (tlm(ng)%pioVar(idubar)%dkind.eq.pio_double) THEN
1687 iodesc => iodesc_dp_u2dvar(ng)
1688 ELSE
1689 iodesc => iodesc_sp_u2dvar(ng)
1690 END IF
1691
1692 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idubar, &
1693 & tlm(ng)%pioVar(idubar), &
1694 & tlm(ng)%Rindex, iodesc, &
1695 & lbi, ubi, lbj, ubj, scale, &
1696# ifdef MASKING
1697 & grid(ng) % umask_full, &
1698# endif
1699# ifdef FORCING_SV
1700 & ocean(ng) % f_ubar(:,:))
1701# else
1702 & ocean(ng) % tl_ubar(:,:,kout))
1703# endif
1704 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1705 IF (master) THEN
1706 WRITE (stdout,20) trim(vname(1,idubar)), tlm(ng)%Rindex
1707 END IF
1708 exit_flag=3
1709 ioerror=status
1710 RETURN
1711 END IF
1712
1713# ifdef FORWARD_WRITE
1714# ifdef FORWARD_RHS
1715!
1716 IF (tlm(ng)%pioVar(idru2d)%dkind.eq.pio_double) THEN
1717 iodesc => iodesc_dp_u2dvar(ng)
1718 ELSE
1719 iodesc => iodesc_sp_u2dvar(ng)
1720 END IF
1721
1722 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idru2d, &
1723 & tlm(ng)%pioVar(idru2d), &
1724 & tlm(ng)%Rindex, iodesc, &
1725 & lbi, ubi, lbj, ubj, scale, &
1726# ifdef MASKING
1727 & grid(ng) % umask_full, &
1728# endif
1729 & ocean(ng) % tl_rubar(:,:,kout))
1730 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1731 IF (master) THEN
1732 WRITE (stdout,20) trim(vname(1,idru2d)), tlm(ng)%Rindex
1733 END IF
1734 exit_flag=3
1735 ioerror=status
1736 RETURN
1737 END IF
1738# endif
1739# ifdef SOLVE3D
1740# ifdef FORWARD_RHS
1741!
1742 IF (tlm(ng)%pioVar(idruct)%dkind.eq.pio_double) THEN
1743 iodesc => iodesc_dp_u2dvar(ng)
1744 ELSE
1745 iodesc => iodesc_sp_u2dvar(ng)
1746 END IF
1747
1748 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idruct, &
1749 & tlm(ng)%pioVar(idruct), &
1750 & tlm(ng)%Rindex, iodesc, &
1751 & lbi, ubi, lbj, ubj, scale, &
1752# ifdef MASKING
1753 & grid(ng) % umask_full, &
1754# endif
1755 & coupling(ng) % tl_rufrc)
1756 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1757 IF (master) THEN
1758 WRITE (stdout,20) trim(vname(1,idruct)), tlm(ng)%Rindex
1759 END IF
1760 exit_flag=3
1761 ioerror=status
1762 RETURN
1763 END IF
1764# endif
1765!
1766 IF (tlm(ng)%pioVar(idufx1)%dkind.eq.pio_double) THEN
1767 iodesc => iodesc_dp_u2dvar(ng)
1768 ELSE
1769 iodesc => iodesc_sp_u2dvar(ng)
1770 END IF
1771
1772 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idufx1, &
1773 & tlm(ng)%pioVar(idufx1), &
1774 & tlm(ng)%Rindex, iodesc, &
1775 & lbi, ubi, lbj, ubj, scale, &
1776# ifdef MASKING
1777 & grid(ng) % umask_full, &
1778# endif
1779 & coupling(ng) % tl_DU_avg1)
1780 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1781 IF (master) THEN
1782 WRITE (stdout,20) trim(vname(1,idufx1)), tlm(ng)%Rindex
1783 END IF
1784 exit_flag=3
1785 ioerror=status
1786 RETURN
1787 END IF
1788!
1789 IF (tlm(ng)%pioVar(idufx2)%dkind.eq.pio_double) THEN
1790 iodesc => iodesc_dp_u2dvar(ng)
1791 ELSE
1792 iodesc => iodesc_sp_u2dvar(ng)
1793 END IF
1794
1795 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idufx2, &
1796 & tlm(ng)%pioVar(idufx2), &
1797 & tlm(ng)%Rindex, iodesc, &
1798 & lbi, ubi, lbj, ubj, scale, &
1799# ifdef MASKING
1800 & grid(ng) % umask_full, &
1801# endif
1802 & coupling(ng) % tl_DU_avg2)
1803 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1804 IF (master) THEN
1805 WRITE (stdout,20) trim(vname(1,idufx2)), tlm(ng)%Rindex
1806 END IF
1807 exit_flag=3
1808 ioerror=status
1809 RETURN
1810 END IF
1811# endif
1812# endif
1813 END IF
1814
1815# ifdef ADJUST_BOUNDARY
1816!
1817! Write out 2D U-momentum component open boundaries.
1818!
1819 IF (any(lobc(:,isubar,ng))) THEN
1820 scale=1.0_dp
1821 ifield=idsbry(isubar)
1822 IF (tlm(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
1823 iodesc => iodesc_dp_u2dobc(ng)
1824 ELSE
1825 iodesc => iodesc_sp_u2dobc(ng)
1826 END IF
1827
1828 status=nf_fwrite2d_bry(ng, model, tlm(ng)%name, &
1829 & tlm(ng)%pioFile, &
1830 & vname(1,ifield), &
1831 & tlm(ng)%pioVar(ifield), &
1832 & tlm(ng)%Rindex, iodesc, &
1833 & lbij, ubij, nbrec(ng), scale, &
1834 & boundary(ng) % tl_ubar_obc(lbij:,:,:, &
1835 & lbout(ng)))
1836 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1837 IF (master) THEN
1838 WRITE (stdout,20) trim(vname(1,ifield)), tlm(ng)%Rindex
1839 END IF
1840 exit_flag=3
1841 ioerror=status
1842 RETURN
1843 END IF
1844 END IF
1845# endif
1846!
1847! Write out 2D V-momentum component (m/s).
1848!
1849 IF (hout(idvbar,ng)) THEN
1850 scale=1.0_dp
1851 IF (tlm(ng)%pioVar(idvbar)%dkind.eq.pio_double) THEN
1852 iodesc => iodesc_dp_v2dvar(ng)
1853 ELSE
1854 iodesc => iodesc_sp_v2dvar(ng)
1855 END IF
1856
1857 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idvbar, &
1858 & tlm(ng)%pioVar(idvbar), &
1859 & tlm(ng)%Rindex, iodesc, &
1860 & lbi, ubi, lbj, ubj, scale, &
1861# ifdef MASKING
1862 & grid(ng) % vmask_full, &
1863# endif
1864# ifdef FORCING_SV
1865 & ocean(ng) % f_vbar(:,:))
1866# else
1867 & ocean(ng) % tl_vbar(:,:,kout))
1868# endif
1869 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1870 IF (master) THEN
1871 WRITE (stdout,20) trim(vname(1,idvbar)), tlm(ng)%Rindex
1872 END IF
1873 exit_flag=3
1874 ioerror=status
1875 RETURN
1876 END IF
1877
1878# ifdef FORWARD_WRITE
1879# ifdef FORWARD_RHS
1880!
1881 IF (tlm(ng)%pioVar(idrv2d)%dkind.eq.pio_double) THEN
1882 iodesc => iodesc_dp_v2dvar(ng)
1883 ELSE
1884 iodesc => iodesc_sp_v2dvar(ng)
1885 END IF
1886
1887 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idrv2d, &
1888 & tlm(ng)%pioVar(idrv2d), &
1889 & tlm(ng)%Rindex, iodesc, &
1890 & lbi, ubi, lbj, ubj, scale, &
1891# ifdef MASKING
1892 & grid(ng) % vmask_full, &
1893# endif
1894 & ocean(ng) % tl_rvbar(:,:,kout))
1895 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1896 IF (master) THEN
1897 WRITE (stdout,20) trim(vname(1,idrv2d)), tlm(ng)%Rindex
1898 END IF
1899 exit_flag=3
1900 ioerror=status
1901 RETURN
1902 END IF
1903# endif
1904# ifdef SOLVE3D
1905# ifdef FORWARD_RHS
1906!
1907 IF (tlm(ng)%pioVar(idrvct)%dkind.eq.pio_double) THEN
1908 iodesc => iodesc_dp_v2dvar(ng)
1909 ELSE
1910 iodesc => iodesc_sp_v2dvar(ng)
1911 END IF
1912
1913 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idrvct, &
1914 & tlm(ng)%pioVar(idrvct), &
1915 & tlm(ng)%Rindex, iodesc, &
1916 & lbi, ubi, lbj, ubj, scale, &
1917# ifdef MASKING
1918 & grid(ng) % vmask_full, &
1919# endif
1920 & coupling(ng) % tl_rvfrc)
1921 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1922 IF (master) THEN
1923 WRITE (stdout,20) trim(vname(1,idrvct)), tlm(ng)%Rindex
1924 END IF
1925 exit_flag=3
1926 ioerror=status
1927 RETURN
1928 END IF
1929# endif
1930!
1931 IF (tlm(ng)%pioVar(idvfx1)%dkind.eq.pio_double) THEN
1932 iodesc => iodesc_dp_v2dvar(ng)
1933 ELSE
1934 iodesc => iodesc_sp_v2dvar(ng)
1935 END IF
1936
1937 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idvfx1, &
1938 & tlm(ng)%pioVar(idvfx1), &
1939 & tlm(ng)%Rindex, iodesc, &
1940 & lbi, ubi, lbj, ubj, scale, &
1941# ifdef MASKING
1942 & grid(ng) % vmask_full, &
1943# endif
1944 & coupling(ng) % tl_DV_avg1)
1945 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1946 IF (master) THEN
1947 WRITE (stdout,20) trim(vname(1,idvfx1)), tlm(ng)%Rindex
1948 END IF
1949 exit_flag=3
1950 ioerror=status
1951 RETURN
1952 END IF
1953!
1954 IF (tlm(ng)%pioVar(idvfx2)%dkind.eq.pio_double) THEN
1955 iodesc => iodesc_dp_v2dvar(ng)
1956 ELSE
1957 iodesc => iodesc_sp_v2dvar(ng)
1958 END IF
1959
1960 status=nf_fwrite2d(ng, model, tlm(ng)%pioFile, idvfx2, &
1961 & tlm(ng)%pioVar(idvfx2), &
1962 & tlm(ng)%Rindex, iodesc, &
1963 & lbi, ubi, lbj, ubj, scale, &
1964# ifdef MASKING
1965 & grid(ng) % vmask_full, &
1966# endif
1967 & coupling(ng) % tl_DV_avg2)
1968 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
1969 IF (master) THEN
1970 WRITE (stdout,20) trim(vname(1,idvfx2)), tlm(ng)%Rindex
1971 END IF
1972 exit_flag=3
1973 ioerror=status
1974 RETURN
1975 END IF
1976# endif
1977# endif
1978 END IF
1979
1980# ifdef ADJUST_BOUNDARY
1981!
1982! Write out 2D V-momentum component open boundaries.
1983!
1984 IF (any(lobc(:,isvbar,ng))) THEN
1985 scale=1.0_dp
1986 ifield=idsbry(isvbar)
1987 IF (tlm(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
1988 iodesc => iodesc_dp_v2dobc(ng)
1989 ELSE
1990 iodesc => iodesc_sp_v2dobc(ng)
1991 END IF
1992!
1993 status=nf_fwrite2d_bry(ng, model, tlm(ng)%name, &
1994 & tlm(ng)%pioFile, &
1995 & vname(1,ifield), &
1996 & tlm(ng)%pioVar(ifield), &
1997 & tlm(ng)%Rindex, iodesc, &
1998 & lbij, ubij, nbrec(ng), scale, &
1999 & boundary(ng) % tl_vbar_obc(lbij:,:,:, &
2000 & lbout(ng)))
2001 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2002 IF (master) THEN
2003 WRITE (stdout,20) trim(vname(1,ifield)), tlm(ng)%Rindex
2004 END IF
2005 exit_flag=3
2006 ioerror=status
2007 RETURN
2008 END IF
2009 END IF
2010# endif
2011# ifdef SOLVE3D
2012!
2013! Write out 3D U-momentum component (m/s).
2014!
2015 IF (hout(iduvel,ng)) THEN
2016 scale=1.0_dp
2017 IF (tlm(ng)%pioVar(iduvel)%dkind.eq.pio_double) THEN
2018 iodesc => iodesc_dp_u3dvar(ng)
2019 ELSE
2020 iodesc => iodesc_sp_u3dvar(ng)
2021 END IF
2022
2023 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, iduvel, &
2024 & tlm(ng)%pioVar(iduvel), &
2025 & tlm(ng)%Rindex, iodesc, &
2026 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2027# ifdef MASKING
2028 & grid(ng) % umask_full, &
2029# endif
2030# ifdef FORCING_SV
2031 & ocean(ng) % f_u(:,:,:))
2032# else
2033 & ocean(ng) % tl_u(:,:,:,nout))
2034# endif
2035 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2036 IF (master) THEN
2037 WRITE (stdout,20) trim(vname(1,iduvel)), tlm(ng)%Rindex
2038 END IF
2039 exit_flag=3
2040 ioerror=status
2041 RETURN
2042 END IF
2043
2044# if defined FORWARD_WRITE && defined FORWARD_RHS
2045!
2046 IF (tlm(ng)%pioVar(idru3d)%dkind.eq.pio_double) THEN
2047 iodesc => iodesc_dp_u3dvar(ng)
2048 ELSE
2049 iodesc => iodesc_sp_u3dvar(ng)
2050 END IF
2051
2052 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idru3d, &
2053 & tlm(ng)%pioVar(idru3d), &
2054 & tlm(ng)%Rindex, iodesc, &
2055 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2056# ifdef MASKING
2057 & grid(ng) % umask_full, &
2058# endif
2059 & ocean(ng) % tl_ru(:,:,:,nout))
2060 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2061 IF (master) THEN
2062 WRITE (stdout,20) trim(vname(1,idru3d)), tlm(ng)%Rindex
2063 END IF
2064 exit_flag=3
2065 ioerror=status
2066 RETURN
2067 END IF
2068# endif
2069 END IF
2070
2071# ifdef ADJUST_BOUNDARY
2072!
2073! Write out 3D U-momentum component open boundaries.
2074!
2075 IF (any(lobc(:,isuvel,ng))) THEN
2076 scale=1.0_dp
2077 ifield=idsbry(isuvel)
2078 IF (tlm(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
2079 iodesc => iodesc_dp_u3dobc(ng)
2080 ELSE
2081 iodesc => iodesc_sp_u3dobc(ng)
2082 END IF
2083!
2084 status=nf_fwrite3d_bry(ng, model, tlm(ng)%name, &
2085 & tlm(ng)%pioFile, &
2086 & vname(1,ifield), &
2087 & tlm(ng)%pioVar(ifield), &
2088 & tlm(ng)%Rindex, iodesc, &
2089 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
2090 & boundary(ng) % tl_u_obc(lbij:,:,:,:, &
2091 & lbout(ng)))
2092 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2093 IF (master) THEN
2094 WRITE (stdout,20) trim(vname(1,ifield)), tlm(ng)%Rindex
2095 END IF
2096 exit_flag=3
2097 ioerror=status
2098 RETURN
2099 END IF
2100 END IF
2101# endif
2102!
2103! Write out 3D V-momentum component (m/s).
2104!
2105 IF (hout(idvvel,ng)) THEN
2106 scale=1.0_dp
2107 IF (tlm(ng)%pioVar(idvvel)%dkind.eq.pio_double) THEN
2108 iodesc => iodesc_dp_v3dvar(ng)
2109 ELSE
2110 iodesc => iodesc_sp_v3dvar(ng)
2111 END IF
2112
2113 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idvvel, &
2114 & tlm(ng)%pioVar(idvvel), &
2115 & tlm(ng)%Rindex, iodesc, &
2116 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2117# ifdef MASKING
2118 & grid(ng) % vmask_full, &
2119# endif
2120# ifdef FORCING_SV
2121 & ocean(ng) % f_v(:,:,:))
2122# else
2123 & ocean(ng) % tl_v(:,:,:,nout))
2124# endif
2125 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2126 IF (master) THEN
2127 WRITE (stdout,20) trim(vname(1,idvvel)), tlm(ng)%Rindex
2128 END IF
2129 exit_flag=3
2130 ioerror=status
2131 RETURN
2132 END IF
2133
2134# if defined FORWARD_WRITE && defined FORWARD_RHS
2135!
2136 IF (tlm(ng)%pioVar(idrv3d)%dkind.eq.pio_double) THEN
2137 iodesc => iodesc_dp_v3dvar(ng)
2138 ELSE
2139 iodesc => iodesc_sp_v3dvar(ng)
2140 END IF
2141
2142 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idrv3d, &
2143 & tlm(ng)%pioVar(idrv3d), &
2144 & tlm(ng)%Rindex, iodesc, &
2145 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2146# ifdef MASKING
2147 & grid(ng) % vmask_full, &
2148# endif
2149 & ocean(ng) % tl_rv(:,:,:,nout))
2150 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2151 IF (master) THEN
2152 WRITE (stdout,20) trim(vname(1,idrv3d)), tlm(ng)%Rindex
2153 END IF
2154 exit_flag=3
2155 ioerror=status
2156 RETURN
2157 END IF
2158# endif
2159 END IF
2160
2161# ifdef ADJUST_BOUNDARY
2162!
2163! Write out 3D V-momentum component open boundaries.
2164!
2165 IF (any(lobc(:,isvvel,ng))) THEN
2166 scale=1.0_dp
2167 ifield=idsbry(isvvel)
2168 IF (tlm(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
2169 iodesc => iodesc_dp_v3dobc(ng)
2170 ELSE
2171 iodesc => iodesc_sp_v3dobc(ng)
2172 END IF
2173!
2174 status=nf_fwrite3d_bry(ng, model, tlm(ng)%name, &
2175 & tlm(ng)%pioFile, &
2176 & vname(1,ifield), &
2177 & tlm(ng)%pioVar(ifield), &
2178 & tlm(ng)%Rindex, iodesc, &
2179 & lbij, ubij, 1, n(ng), nbrec(ng), scale, &
2180 & boundary(ng) % tl_v_obc(lbij:,:,:,:, &
2181 & lbout(ng)))
2182 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2183 IF (master) THEN
2184 WRITE (stdout,20) trim(vname(1,ifield)), tlm(ng)%Rindex
2185 END IF
2186 exit_flag=3
2187 ioerror=status
2188 RETURN
2189 END IF
2190 END IF
2191# endif
2192# ifdef UV_DESTAGGERED
2193!
2194! Write out 3D Eastward momentum (m/s) at RHO-points, A-grid
2195!
2196 IF (hout(idu3de,ng)) THEN
2197 scale=1.0_dp
2198 IF (tlm(ng)%pioVar(idu3de)%dkind.eq.pio_double) THEN
2199 iodesc => iodesc_dp_r3dvar(ng)
2200 ELSE
2201 iodesc => iodesc_sp_r3dvar(ng)
2202 END IF
2203 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idu3de, &
2204 & tlm(ng)%pioVar(idu3de), &
2205 & tlm(ng)%Rindex, &
2206 & iodesc, &
2207 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2208# ifdef MASKING
2209 & grid(ng) % rmask_full, &
2210# endif
2211 & ocean(ng) % tl_ua)
2212 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2213 IF (master) THEN
2214 WRITE (stdout,20) trim(vname(1,idu3de)), tlm(ng)%Rindex
2215 END IF
2216 exit_flag=3
2217 ioerror=status
2218 RETURN
2219 END IF
2220 END IF
2221!
2222! Write out 3D Northward momentum (m/s) at RHO-points, A-grid
2223!
2224 IF (hout(idv3dn,ng)) THEN
2225 IF (tlm(ng)%pioVar(idv3dn)%dkind.eq.pio_double) THEN
2226 iodesc => iodesc_dp_r3dvar(ng)
2227 ELSE
2228 iodesc => iodesc_sp_r3dvar(ng)
2229 END IF
2230 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idv3dn, &
2231 & tlm(ng)%pioVar(idv3dn), &
2232 & tlm(ng)%Rindex, &
2233 & iodesc, &
2234 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2235# ifdef MASKING
2236 & grid(ng) % rmask_full, &
2237# endif
2238 & ocean(ng) % tl_va)
2239 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2240 IF (master) THEN
2241 WRITE (stdout,20) trim(vname(1,idv3dn)), tlm(ng)%Rindex
2242 END IF
2243 exit_flag=3
2244 ioerror=status
2245 RETURN
2246 END IF
2247 END IF
2248# endif
2249!
2250! Write out tracer type variables.
2251!
2252 DO itrc=1,nt(ng)
2253 IF (hout(idtvar(itrc),ng)) THEN
2254 scale=1.0_dp
2255 IF (tlm(ng)%pioTrc(itrc)%dkind.eq.pio_double) THEN
2256 iodesc => iodesc_dp_r3dvar(ng)
2257 ELSE
2258 iodesc => iodesc_sp_r3dvar(ng)
2259 END IF
2260
2261 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idtvar(itrc), &
2262 & tlm(ng)%pioTrc(itrc), &
2263 & tlm(ng)%Rindex, iodesc, &
2264 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2265# ifdef MASKING
2266 & grid(ng) % rmask, &
2267# endif
2268# ifdef FORCING_SV
2269 & ocean(ng) % f_t(:,:,:,itrc))
2270# else
2271 & ocean(ng) % tl_t(:,:,:,nout,itrc))
2272# endif
2273 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2274 IF (master) THEN
2275 WRITE (stdout,20) trim(vname(1,idtvar(itrc))), &
2276 & tlm(ng)%Rindex
2277 END IF
2278 exit_flag=3
2279 ioerror=status
2280 RETURN
2281 END IF
2282 END IF
2283 END DO
2284
2285# ifdef ADJUST_BOUNDARY
2286!
2287! Write out tracers open boundaries.
2288!
2289 DO itrc=1,nt(ng)
2290 IF (any(lobc(:,istvar(itrc),ng))) THEN
2291 scale=1.0_dp
2292 ifield=idsbry(istvar(itrc))
2293 IF (tlm(ng)%pioVar(ifield)%dkind.eq.pio_double) THEN
2294 iodesc => iodesc_dp_r3dobc(ng)
2295 ELSE
2296 iodesc => iodesc_sp_r3dobc(ng)
2297 END IF
2298!
2299 status=nf_fwrite3d_bry(ng, model, tlm(ng)%name, &
2300 & tlm(ng)%pioFile, &
2301 & vname(1,ifield), &
2302 & tlm(ng)%pioVar(ifield), &
2303 & tlm(ng)%Rindex, iodesc, &
2304 & lbij, ubij, 1, n(ng), nbrec(ng), &
2305 & scale, &
2306 & boundary(ng) % tl_t_obc(lbij:,:,:,:, &
2307 & lbout(ng),itrc))
2308 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2309 IF (master) THEN
2310 WRITE (stdout,20) trim(vname(1,ifield)), tlm(ng)%Rindex
2311 END IF
2312 exit_flag=3
2313 ioerror=status
2314 RETURN
2315 END IF
2316 END IF
2317 END DO
2318# endif
2319!
2320! Write out density anomaly.
2321!
2322 IF (hout(iddano,ng)) THEN
2323 scale=1.0_dp
2324 IF (tlm(ng)%pioVar(iddano)%dkind.eq.pio_double) THEN
2325 iodesc => iodesc_dp_r3dvar(ng)
2326 ELSE
2327 iodesc => iodesc_sp_r3dvar(ng)
2328 END IF
2329!
2330 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, iddano, &
2331 & tlm(ng)%pioVar(iddano), &
2332 & tlm(ng)%Rindex, iodesc, &
2333 & lbi, ubi, lbj, ubj, 1, n(ng), scale, &
2334# ifdef MASKING
2335 & grid(ng) % rmask, &
2336# endif
2337 & ocean(ng) % tl_rho)
2338 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2339 IF (master) THEN
2340 WRITE (stdout,20) trim(vname(1,iddano)), tlm(ng)%Rindex
2341 END IF
2342 exit_flag=3
2343 ioerror=status
2344 RETURN
2345 END IF
2346 END IF
2347
2348# if defined FORWARD_MIXING && \
2349 (defined bvf_mixing || defined gls_mixing || \
2350 defined lmd_mixing || defined my25_mixing)
2351!
2352! Write out vertical viscosity coefficient.
2353!
2354 IF (hout(idvvis,ng)) THEN
2355 scale=1.0_dp
2356 IF (tlm(ng)%pioVar(idvvis)%dkind.eq.pio_double) THEN
2357 iodesc => iodesc_dp_w3dvar(ng)
2358 ELSE
2359 iodesc => iodesc_sp_w3dvar(ng)
2360 END IF
2361!
2362 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idvvis, &
2363 & tlm(ng)%pioVar(idvvis), &
2364 & tlm(ng)%Rindex, iodesc, &
2365 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2366# ifdef MASKING
2367 & grid(ng) % rmask, &
2368# endif
2369# ifdef WEAK_CONSTRAINT
2370 & mixing(ng) % Akv, &
2371# else
2372 & mixing(ng) % tl_Akv, &
2373# endif
2374 & setfillval = .false.)
2375 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2376 IF (master) THEN
2377 WRITE (stdout,20) trim(vname(1,idvvis)), tlm(ng)%Rindex
2378 END IF
2379 exit_flag=3
2380 ioerror=status
2381 RETURN
2382 END IF
2383 END IF
2384!
2385! Write out vertical diffusion coefficient for potential temperature.
2386!
2387 IF (hout(idtdif,ng)) THEN
2388 scale=1.0_dp
2389 IF (tlm(ng)%pioVar(idtdif)%dkind.eq.pio_double) THEN
2390 iodesc => iodesc_dp_w3dvar(ng)
2391 ELSE
2392 iodesc => iodesc_sp_w3dvar(ng)
2393 END IF
2394!
2395 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idtdif, &
2396 & tlm(ng)%pioVar(idtdif), &
2397 & tlm(ng)%Rindex, iodesc, &
2398 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2399# ifdef MASKING
2400 & grid(ng) % rmask, &
2401# endif
2402# ifdef WEAK_CONSTRAINT
2403 & mixing(ng) % Akt(:,:,:,itemp), &
2404# else
2405 & mixing(ng) % tl_Akt(:,:,:,itemp), &
2406# endif
2407 & setfillval = .false.)
2408 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2409 IF (master) THEN
2410 WRITE (stdout,20) trim(vname(1,idtdif)), tlm(ng)%Rindex
2411 END IF
2412 exit_flag=3
2413 ioerror=status
2414 RETURN
2415 END IF
2416 END IF
2417
2418# ifdef SALINITY
2419!
2420! Write out vertical diffusion coefficient for salinity.
2421!
2422 IF (hout(idsdif,ng)) THEN
2423 scale=1.0_dp
2424 IF (tlm(ng)%pioVar(idsdif)%dkind.eq.pio_double) THEN
2425 iodesc => iodesc_dp_w3dvar(ng)
2426 ELSE
2427 iodesc => iodesc_sp_w3dvar(ng)
2428 END IF
2429
2430 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idsdif, &
2431 & tlm(ng)%pioVar(idsdif), &
2432 & tlm(ng)%Rindex, iodesc, &
2433 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2434# ifdef MASKING
2435 & grid(ng) % rmask, &
2436# endif
2437# ifdef WEAK_CONSTRAINT
2438 & mixing(ng) % Akt(:,:,:,isalt), &
2439# else
2440 & mixing(ng) % tl_Akt(:,:,:,isalt), &
2441# endif
2442 & setfillval = .false.)
2443 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2444 IF (master) THEN
2445 WRITE (stdout,20) trim(vname(1,idsdif)), tlm(ng)%Rindex
2446 END IF
2447 exit_flag=3
2448 ioerror=status
2449 RETURN
2450 END IF
2451 END IF
2452# endif
2453# if defined GLS_MIXING_NOT_YET || defined MY25_MIXING_NOT_YET
2454!
2455! Write out turbulent kinetic energy.
2456!
2457 IF (hout(idmtke,ng)) THEN
2458 scale=1.0_dp
2459 IF (tlm(ng)%pioVar(idmtke)%dkind.eq.pio_double) THEN
2460 iodesc => iodesc_dp_w3dvar(ng)
2461 ELSE
2462 iodesc => iodesc_sp_w3dvar(ng)
2463 END IF
2464
2465 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idmtke, &
2466 & tlm(ng)%pioVar(idmtke), &
2467 & tlm(ng)%Rindex, iodesc, &
2468 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2469# ifdef MASKING
2470 & grid(ng) % rmask, &
2471# endif
2472 & mixing(ng) % tl_tke(:,:,:,nout), &
2473 & setfillval = .false.)
2474 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2475 IF (master) THEN
2476 WRITE (stdout,20) trim(vname(1,idmtke)), tlm(ng)%Rindex
2477 END IF
2478 exit_flag=3
2479 ioerror=status
2480 RETURN
2481 END IF
2482!
2483 scale=1.0_dp
2484 IF (tlm(ng)%pioVar(idvmkk)%dkind.eq.pio_double) THEN
2485 iodesc => iodesc_dp_w3dvar(ng)
2486 ELSE
2487 iodesc => iodesc_sp_w3dvar(ng)
2488 END IF
2489
2490 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idvmkk, &
2491 & tlm(ng)%pioVar(idvmkk), &
2492 & tlm(ng)%Rindex, iodesc, &
2493 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2494# ifdef MASKING
2495 & grid(ng) % rmask, &
2496# endif
2497 & mixing(ng) % tl_Akk)
2498 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2499 IF (master) THEN
2500 WRITE (stdout,20) trim(vname(1,idvmkk)), tlm(ng)%Rindex
2501 END IF
2502 exit_flag=3
2503 ioerror=status
2504 RETURN
2505 END IF
2506 END IF
2507!
2508! Write out turbulent length scale field.
2509!
2510 IF (hout(idmtls,ng)) THEN
2511 scale=1.0_dp
2512 IF (tlm(ng)%pioVar(idmtld)%dkind.eq.pio_double) THEN
2513 iodesc => iodesc_dp_w3dvar(ng)
2514 ELSE
2515 iodesc => iodesc_sp_w3dvar(ng)
2516 END IF
2517
2518 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idmtls, &
2519 & tlm(ng)%pioVar(idmtls), &
2520 & tlm(ng)%Rindex, iodesc, &
2521 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2522# ifdef MASKING
2523 & grid(ng) % rmask, &
2524# endif
2525 & mixing(ng) % tl_gls(:,:,:,nout), &
2526 & setfillval = .false.)
2527 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2528 IF (master) THEN
2529 WRITE (stdout,20) trim(vname(1,idmtls)), tlm(ng)%Rindex
2530 END IF
2531 exit_flag=3
2532 ioerror=status
2533 RETURN
2534 END IF
2535!
2536 scale=1.0_dp
2537 IF (tlm(ng)%pioVar(idvmls)%dkind.eq.pio_double) THEN
2538 iodesc => iodesc_dp_w3dvar(ng)
2539 ELSE
2540 iodesc => iodesc_sp_w3dvar(ng)
2541 END IF
2542
2543 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idvmls, &
2544 & tlm(ng)%pioVar(idvmls), &
2545 & tlm(ng)%Rindex, iodesc, &
2546 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2547# ifdef MASKING
2548 & grid(ng) % rmask, &
2549# endif
2550 & mixing(ng) % tl_Lscale)
2551 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2552 IF (master) THEN
2553 WRITE (stdout,20) trim(vname(1,idvmls)), tlm(ng)%Rindex
2554 END IF
2555 exit_flag=3
2556 ioerror=status
2557 RETURN
2558 END IF
2559
2560# ifdef GSL_MIXING
2561!
2562 scale=1.0_dp
2563 IF (tlm(ng)%pioVar(idvmkp)%dkind.eq.pio_double) THEN
2564 iodesc => iodesc_dp_w3dvar(ng)
2565 ELSE
2566 iodesc => iodesc_sp_w3dvar(ng)
2567 END IF
2568
2569 status=nf_fwrite3d(ng, model, tlm(ng)%pioFile, idvmkp, &
2570 & tlm(ng)%pioVar(idvmkp), &
2571 & tlm(ng)%Rindex, iodesc, &
2572 & lbi, ubi, lbj, ubj, 0, n(ng), scale, &
2573# ifdef MASKING
2574 & grid(ng) % rmask, &
2575# endif
2576 & mixing(ng) % tl_Akp)
2577 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
2578 IF (master) THEN
2579 WRITE (stdout,20) trim(vname(1,idvmkp)), tlm(ng)%Rindex
2580 END IF
2581 exit_flag=3
2582 ioerror=status
2583 RETURN
2584 END IF
2585# endif
2586 END IF
2587# endif
2588# endif
2589# endif
2590!
2591!-----------------------------------------------------------------------
2592! Synchronize tangent NetCDF file to disk to allow other processes
2593! to access data immediately after it is written.
2594!-----------------------------------------------------------------------
2595!
2596 CALL pio_netcdf_sync (ng, model, tlm(ng)%name, tlm(ng)%pioFile)
2597 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2598!
2599 10 FORMAT (2x,'TL_WRT_HIS_PIO - writing history', t42, &
2600# ifdef SOLVE3D
2601# ifdef NESTING
2602 & 'fields (Index=',i1,',',i1,') in record = ',i0,t92,i2.2)
2603# else
2604 & 'fields (Index=',i1,',',i1,') in record = ',i0)
2605# endif
2606# else
2607# ifdef NESTING
2608 & 'fields (Index=',i1,') in record = ',i0,t92,i2.2)
2609# else
2610 & 'fields (Index=',i1,') in record = ',i0)
2611# endif
2612# endif
2613 20 FORMAT (/,' TL_WRT_HIS_PIO - error while writing variable: ',a, &
2614 & /,19x,'into tangent NetCDF file for time record: ',i0)
2615!
2616 RETURN
2617 END SUBROUTINE tl_wrt_his_pio
2618# endif
2619#endif
2620 END MODULE tl_wrt_his_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
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_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::his
type(t_io), dimension(:), allocatable his
Definition mod_iounits.F:222
mod_iounits::tlm
type(t_io), dimension(:), allocatable tlm
Definition mod_iounits.F:250
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::idvmls
integer idvmls
Definition mod_ncparam.F:374
mod_ncparam::hout
logical, dimension(:,:), allocatable hout
Definition mod_ncparam.F:168
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::idvvel
integer idvvel
Definition mod_ncparam.F:381
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::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::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::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::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::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::idru3d
integer idru3d
Definition mod_ncparam.F:279
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::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::idmtls
integer idmtls
Definition mod_ncparam.F:238
mod_ncparam::idruct
integer idruct
Definition mod_ncparam.F:277
mod_ncparam::idpthr
integer idpthr
Definition mod_ncparam.F:268
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::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::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_param::w3dvar
integer, parameter w3dvar
Definition mod_param.F:724
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::iodesc_sp_w3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_w3dvar
Definition mod_pio_netcdf.F:212
mod_pio_netcdf::iodesc_sp_v2dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dobc
Definition mod_pio_netcdf.F:217
mod_pio_netcdf::iodesc_dp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r3dvar
Definition mod_pio_netcdf.F:248
mod_pio_netcdf::iodesc_sp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u3dvar
Definition mod_pio_netcdf.F:210
mod_pio_netcdf::iodesc_dp_v2dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dobc
Definition mod_pio_netcdf.F:256
mod_pio_netcdf::iodesc_sp_u2dfrc
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dfrc
Definition mod_pio_netcdf.F:228
mod_pio_netcdf::iodesc_dp_v3dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_v3dobc
Definition mod_pio_netcdf.F:260
mod_pio_netcdf::pio_netcdf_sync
subroutine, public pio_netcdf_sync(ng, model, ncname, piofile)
Definition mod_pio_netcdf.F:9275
mod_pio_netcdf::iodesc_sp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dvar
Definition mod_pio_netcdf.F:195
mod_pio_netcdf::iodesc_dp_u3dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_u3dobc
Definition mod_pio_netcdf.F:259
mod_pio_netcdf::iodesc_sp_r3dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_r3dobc
Definition mod_pio_netcdf.F:219
mod_pio_netcdf::iodesc_dp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u3dvar
Definition mod_pio_netcdf.F:249
mod_pio_netcdf::iodesc_dp_u2dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dobc
Definition mod_pio_netcdf.F:255
mod_pio_netcdf::iodesc_sp_r2dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dobc
Definition mod_pio_netcdf.F:215
mod_pio_netcdf::iodesc_sp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dvar
Definition mod_pio_netcdf.F:194
mod_pio_netcdf::iodesc_sp_u3dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_u3dobc
Definition mod_pio_netcdf.F:220
mod_pio_netcdf::iodesc_dp_u2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dfrc
Definition mod_pio_netcdf.F:267
mod_pio_netcdf::iodesc_dp_r2dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dobc
Definition mod_pio_netcdf.F:254
mod_pio_netcdf::iodesc_sp_u2dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dobc
Definition mod_pio_netcdf.F:216
mod_pio_netcdf::iodesc_dp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dvar
Definition mod_pio_netcdf.F:234
mod_pio_netcdf::iodesc_dp_v2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dfrc
Definition mod_pio_netcdf.F:268
mod_pio_netcdf::iodesc_dp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v3dvar
Definition mod_pio_netcdf.F:250
mod_pio_netcdf::iodesc_sp_v2dfrc
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dfrc
Definition mod_pio_netcdf.F:229
mod_pio_netcdf::iodesc_dp_w3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_w3dvar
Definition mod_pio_netcdf.F:251
mod_pio_netcdf::iodesc_dp_r2dfrc
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dfrc
Definition mod_pio_netcdf.F:264
mod_pio_netcdf::iodesc_dp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dvar
Definition mod_pio_netcdf.F:235
mod_pio_netcdf::iodesc_sp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v3dvar
Definition mod_pio_netcdf.F:211
mod_pio_netcdf::iodesc_sp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r3dvar
Definition mod_pio_netcdf.F:209
mod_pio_netcdf::iodesc_dp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dvar
Definition mod_pio_netcdf.F:233
mod_pio_netcdf::iodesc_dp_r3dobc
type(io_desc_t), dimension(:), pointer iodesc_dp_r3dobc
Definition mod_pio_netcdf.F:258
mod_pio_netcdf::iodesc_sp_v3dobc
type(io_desc_t), dimension(:), pointer iodesc_sp_v3dobc
Definition mod_pio_netcdf.F:221
mod_pio_netcdf::iodesc_sp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dvar
Definition mod_pio_netcdf.F:196
mod_pio_netcdf::iodesc_sp_r2dfrc
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dfrc
Definition mod_pio_netcdf.F:225
mod_scalars
Definition mod_scalars.F:2
mod_scalars::day2sec
real(dp), parameter day2sec
Definition mod_scalars.F:816
mod_scalars::lobc
logical, dimension(:,:,:), allocatable lobc
Definition mod_scalars.F:1127
mod_scalars::lstflux
logical, dimension(:,:), allocatable lstflux
Definition mod_scalars.F:1156
mod_scalars::nfrec
integer, dimension(:), allocatable nfrec
Definition mod_scalars.F:1148
mod_scalars::lcycletlm
logical, dimension(:), allocatable lcycletlm
Definition mod_scalars.F:1198
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::isalt
integer isalt
Definition mod_scalars.F:127
mod_scalars::lwrtper
logical, dimension(:), allocatable lwrtper
Definition mod_scalars.F:997
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::nbrec
integer, dimension(:), allocatable nbrec
Definition mod_scalars.F:1119
mod_scalars::noerror
integer noerror
Definition mod_scalars.F:561
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
mod_stepping::lfout
integer, dimension(:), allocatable lfout
Definition mod_stepping.F:103
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
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
tl_wrt_his_mod
Definition tl_wrt_his.F:2
tl_wrt_his_mod::tl_wrt_his
subroutine, public tl_wrt_his(ng, tile)
Definition tl_wrt_his.F:68
tl_wrt_his_mod::tl_wrt_his_pio
subroutine, private tl_wrt_his_pio(ng, model, tile, lbij, ubij, lbi, ubi, lbj, ubj)
Definition tl_wrt_his.F:1265
tl_wrt_his_mod::tl_wrt_his_nf90
subroutine, private tl_wrt_his_nf90(ng, model, tile, lbij, ubij, lbi, ubi, lbj, ubj)
Definition tl_wrt_his.F:131