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