tl_output.F

Go to the documentation of this file.

#include "cppdefs.h"
#ifdef TANGENT
      SUBROUTINE tl_output (ng)
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group                              !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  This routine manages tangent linear model output. It creates output !
!  NetCDF files and writes out data into NetCDF files.  If  requested, !
!  it can create several tangent history files to avoid generating too !
!  large files during a single model run.                              !
!                                                                      !
!=======================================================================
!
      USE mod_param
      USE mod_parallel
# ifdef FOUR_DVAR
      USE mod_fourdvar
# endif
      USE mod_iounits
      USE mod_ncparam
      USE mod_scalars
!
      USE close_io_mod,   ONLY : close_file
# ifdef TL_AVERAGES
      USE def_avg_mod,    ONLY : def_avg
# endif
# ifdef DISTRIBUTE
      USE distribute_mod, ONLY : mp_bcasts
# endif
# ifdef OBSERVATIONS
      USE obs_read_mod,   ONLY : obs_read
      USE obs_write_mod,  ONLY : obs_write
# endif
      USE strings_mod,    ONLY : founderror
      USE tl_def_his_mod, ONLY : tl_def_his
      USE tl_wrt_his_mod, ONLY : tl_wrt_his
# ifdef TL_AVERAGES
      USE wrt_avg_mod,    ONLY : def_avg
# endif
!
      implicit none
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng
!
!  Local variable declarations.
!
      logical :: Ldefine, Lupdate, NewFile
!
      integer :: Fcount, ifile, status, tile
!
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__
!
      sourcefile=myfile
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on output data time wall clock.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, itlm, 8, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  If appropriate, process tangent linear history NetCDF file.
!-----------------------------------------------------------------------
!
!  Turn off checking for analytical header files.
!
      IF (lanafile) THEN
        lanafile=.false.
      END IF
!
!  If appropriate, set switch for updating biology header file global
!  attribute in output NetCDF files.
!
#ifdef BIOLOGY
      lupdate=.true.
#else
      lupdate=.false.
#endif
!
!  Create output tangent NetCDF file or prepare existing file to
!  append new data to it.  Also,  notice that it is possible to
!  create several files during a single model run.
!
      IF (ldeftlm(ng)) THEN
        IF (ndeftlm(ng).gt.0) THEN
          IF (ideftlm(ng).lt.0) THEN
            ideftlm(ng)=((ntstart(ng)-1)/ndeftlm(ng))*ndeftlm(ng)
            IF (ideftlm(ng).lt.iic(ng)-1) THEN
              ideftlm(ng)=ideftlm(ng)+ndeftlm(ng)
            END IF
          END IF
          IF ((nrrec(ng).ne.0).and.(iic(ng).eq.ntstart(ng))) THEN
            IF ((iic(ng)-1).eq.ideftlm(ng)) THEN
              tlm(ng)%load=0                  ! restart, reset counter
              ldefine=.false.                 ! finished file, delay
            ELSE                              ! creation of next file
              ldefine=.true.
              newfile=.false.                 ! unfinished file, inquire
            END IF                            ! content for appending
            ideftlm(ng)=ideftlm(ng)+ntlm(ng)  ! restart offset
          ELSE IF ((iic(ng)-1).eq.ideftlm(ng)) THEN
            ideftlm(ng)=ideftlm(ng)+ndeftlm(ng)
            IF (ntlm(ng).ne.ndeftlm(ng).and.iic(ng).eq.ntstart(ng)) THEN
              ideftlm(ng)=ideftlm(ng)+ntlm(ng)  ! multiple record offset
            END IF
            ldefine=.true.
            newfile=.true.
          ELSE
            ldefine=.false.
          END IF
          IF (ldefine) THEN                     ! create new file or
            IF (iic(ng).eq.ntstart(ng)) THEN    ! inquire existing file
              tlm(ng)%load=0                    ! reset filename counter
            END IF
            ifile=(iic(ng)-1)/ndeftlm(ng)+1     ! next filename suffix
            tlm(ng)%load=tlm(ng)%load+1
            IF (tlm(ng)%load.gt.tlm(ng)%Nfiles) THEN
              IF (master) THEN
                WRITE (stdout,10) 'TLM(ng)%load = ', tlm(ng)%load,      &
     &                            tlm(ng)%Nfiles, trim(tlm(ng)%base),   &
     &                            ifile
              END IF
              exit_flag=4
              IF (founderror(exit_flag, noerror,                        &
     &                       __line__, myfile)) RETURN
            END IF
            fcount=tlm(ng)%load
            tlm(ng)%Nrec(fcount)=0
            IF (master) THEN
              WRITE (tlm(ng)%name,20) trim(tlm(ng)%base), ifile
            END IF
# ifdef DISTRIBUTE
            CALL mp_bcasts (ng, itlm, tlm(ng)%name)
# endif
            tlm(ng)%files(fcount)=trim(tlm(ng)%name)
            CALL close_file (ng, itlm, tlm(ng), tlm(ng)%name, lupdate)
            CALL tl_def_his (ng, newfile)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END IF
          IF ((iic(ng).eq.ntstart(ng)).and.(nrrec(ng).ne.0)) THEN
            lwrttlm(ng)=.false.                 ! avoid writing initial
          ELSE                                  ! fields during restart
            lwrttlm(ng)=.true.
          END IF
        ELSE
          IF (iic(ng).eq.ntstart(ng)) THEN
            CALL tl_def_his (ng, ldefout(ng))
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
            lwrttlm(ng)=.true.
            ldeftlm(ng)=.false.
          END IF
        END IF
      END IF
!
!  Write out data into tangent NetCDF file.  Avoid writing initial
!  conditions in perturbation mode computations.
!
      IF (lwrttlm(ng)) THEN
# if defined STOCHASTIC_OPT || defined FORCING_SV || \
     defined hessian_so     || defined hessian_fsv
!
!  Write only on first time step.
!
        IF (iic(ng).eq.1) THEN
#  ifdef DISTRIBUTE
          CALL tl_wrt_his (ng, myrank)
#  else
          CALL tl_wrt_his (ng, -1)
#  endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END IF
# else
        IF (lwrtper(ng)) THEN
          IF ((iic(ng).gt.ntstart(ng)).and.                             &
     &        (mod(iic(ng)-1,ntlm(ng)).eq.0)) THEN
#  ifdef DISTRIBUTE
            CALL tl_wrt_his (ng, myrank)
#  else
            CALL tl_wrt_his (ng, -1)
#  endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END IF
        ELSE
          IF ((mod(iic(ng)-1,ntlm(ng)).eq.0).and.                       &
     &        ((nrrec(ng).eq.0).or.(iic(ng).ne.ntstart(ng)))) THEN
#  ifdef DISTRIBUTE
            CALL tl_wrt_his (ng, myrank)
#  else
            CALL tl_wrt_his (ng, -1)
#  endif
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
          END IF
        END IF
# endif
      END IF
 
# ifdef TL_AVERAGES
!
!-----------------------------------------------------------------------
!  If appropriate, process time-averaged NetCDF file.
!-----------------------------------------------------------------------
!
!  Create output time-averaged NetCDF file or prepare existing file
!  to append new data to it. Also, notice that it is possible to
!  create several files during a single model run.
!
      IF (ldefavg(ng)) THEN
        IF (ndefavg(ng).gt.0) THEN
          IF (idefavg(ng).lt.0) THEN
            idefavg(ng)=((ntstart(ng)-1)/ndefavg(ng))*ndefavg(ng)
            IF ((ndefavg(ng).eq.navg(ng)).and.(idefavg(ng).le.0)) THEN
              idefavg(ng)=ndefavg(ng)         ! one file per record
            ELSE IF (idefavg(ng).lt.iic(ng)-1) THEN
              idefavg(ng)=idefavg(ng)+ndefavg(ng)
            END IF
          END IF
          IF ((nrrec(ng).ne.0).and.(iic(ng).eq.ntstart(ng))) THEN
            IF ((iic(ng)-1).eq.idefavg(ng)) THEN
              avg(ng)%load=0                  ! restart, reset counter
              ldefine=.false.                 ! finished file, delay
            ELSE                              ! creation of next file
              newfile=.false.
              ldefine=.true.                  ! unfinished file, inquire
            END IF                            ! content for appending
            idefavg(ng)=idefavg(ng)+navg(ng)  ! restart offset
          ELSE IF ((iic(ng)-1).eq.idefavg(ng)) THEN
            idefavg(ng)=idefavg(ng)+ndefavg(ng)
            IF (navg(ng).ne.ndefavg(ng).and.iic(ng).eq.ntstart(ng)) THEN
              idefavg(ng)=idefavg(ng)+navg(ng)
            END IF
            ldefine=.true.
            newfile=.true.
          ELSE
            ldefine=.false.
          END IF
          IF (ldefine) THEN
            IF (iic(ng).eq.ntstart(ng)) THEN
              avg(ng)%load=0                  ! reset filename counter
            END IF
            avg(ng)%load=avg(ng)%load+1
            IF (ndefavg(ng).eq.navg(ng)) THEN ! next filename suffix
              ifile=(iic(ng)-1)/ndefavg(ng)
            ELSE
              ifile=(iic(ng)-1)/ndefavg(ng)+1
            END IF
            IF (avg(ng)%load.gt.avg(ng)%Nfiles) THEN
              IF (master) THEN
                WRITE (stdout,10) 'AVG(ng)%load = ', avg(ng)%load,      &
     &                            avg(ng)%Nfiles, trim(avg(ng)%base),   &
     &                            ifile
              END IF
              exit_flag=4
              IF (founderror(exit_flag, noerror,                        &
     &                       __line__, myfile)) RETURN
            END IF
            fcount=avg(ng)%load
            avg(ng)%Nrec(fcount)=0
            IF (master) THEN
              WRITE (avg(ng)%name,20) trim(avg(ng)%base), ifile
            END IF
#  ifdef DISTRIBUTE
            CALL mp_bcasts (ng, itlm, avg(ng)%name)
#  endif
            avg(ng)%files(fcount)=trim(avg(ng)%name)
            CALL close_file (ng, itlm, avg(ng), avg(ng)%name, lupdate)
            CALL def_avg (ng, newfile)
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
            lwrtavg(ng)=.true.
          END IF
        ELSE
          IF (iic(ng).eq.ntstart(ng)) THEN
            CALL def_avg (ng, ldefout(ng))
            IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
            lwrtavg(ng)=.true.
            ldefavg(ng)=.false.
          END IF
        END IF
      END IF
!
!  Write out data into time-averaged NetCDF file.
!
      IF (lwrtavg(ng)) THEN
        IF ((iic(ng).gt.ntstart(ng)).and.                               &
     &      (mod(iic(ng)-1,navg(ng)).eq.0)) THEN
#  ifdef DISTRIBUTE
          CALL wrt_avg (ng, myrank)
#  else
          CALL wrt_avg (ng, -1)
#  endif
          IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
        END IF
      END IF
# endif
 
# if defined FOUR_DVAR
#  ifdef OBSERVATIONS
!
!-----------------------------------------------------------------------
!  If appropriate, process and write model state at observation
!  locations. Compute misfit (model-observations) cost function.
!-----------------------------------------------------------------------
!
        IF (((time(ng)-0.5_r8*dt(ng)).le.obstime(ng)).and.              &
     &      (obstime(ng).lt.(time(ng)+0.5_r8*dt(ng)))) THEN
          processobs(ng)=.true.
#   ifdef DISTRIBUTE
          tile=myrank
#   else
          tile=-1
#   endif
          CALL obs_read (ng, itlm, .false.)
#   ifdef SP4DVAR
!
!  Do not assimilate obs on the last time step unless inter=Nsaddle.
!
          IF (iic(ng).ne.ntend(ng)+1.or.lsadd(ng)) THEN
            CALL obs_write (ng, tile, itlm)
          END IF
#   else
          CALL obs_write (ng, tile, itlm)
#   endif
#   ifndef WEAK_CONSTRAINT
          CALL obs_cost (ng, itlm)
#   endif
        ELSE
          processobs(ng)=.false.
        END IF
#  endif
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off output data time wall clock.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, itlm, 8, __line__, myfile)
# endif
!
 10   FORMAT (/,' TL_OUTPUT - multi-file counter ',a,i0,                &
     &          ', is greater than Nfiles = ',i0,1x,'dimension',        &
     &        /,13x,'in structure when creating next file: ',           &
     &           a,'_',i4.4,'.nc',                                      &
     &        /,13x,'Incorrect OutFiles logic in ''read_phypar''.')
 20   FORMAT (a,'_',i4.4,'.nc')
!
      RETURN
      END SUBROUTINE tl_output
#else
      SUBROUTINE tl_output
      RETURN
      END SUBROUTINE tl_output
#endif