129
130
132
133
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
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
166
167
168 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
169
170
171
172
173# if defined WRITE_WATER && defined MASKING
174 gfactor=-1
175# else
176 gfactor=1
177# endif
178
179
180
181
182
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
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
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
229
230
231 IF (lcycleadj(ng)) THEN
232 adm(ng)%Rindex=mod(adm(ng)%Rindex-1,2)+1
233 END IF
234
235
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
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
258
259
260
261 scale=1.0_dp
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
281
282 scale=1.0_dp
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
304
305
306
307 DO itrc=1,nt(ng)
308 IF (lstflux(itrc,ng)) THEN
309 scale=1.0_dp
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
1158
1159 IF (hout(idusms,ng)) THEN
1160# if defined AD_SENSITIVITY || defined I4DVAR_ANA_SENSITIVITY || \
1161 defined opt_observations
1162
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
1187
1188 IF (hout(idvsms,ng)) THEN
1189
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
1217
1218 IF (hout(idubms,ng)) THEN
1219
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
1241
1242 IF (hout(idvbms,ng)) THEN
1243
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
1266
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
subroutine, public netcdf_sync(ng, model, ncname, ncid)