rp_output.F

Go to the documentation of this file.

#include "cppdefs.h"
#ifdef TL_IOMS
      SUBROUTINE rp_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 RP_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
# if defined FOUR_DVAR && !defined WEAK_CONSTRAINT
      USE tl_def_ini_mod, ONLY : tl_def_ini
# endif
      USE tl_wrt_his_mod, ONLY : tl_wrt_his
# ifdef RP_AVERAGES
      USE wrt_avg_mod,    ONLY : wrt_avg
# endif
!
      implicit none
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng
!
!  Local variable declarations.
!
      logical, save :: First = .true.
      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, irpm, 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, irpm, tlm(ng)%name)
# endif
            tlm(ng)%files(fcount)=trim(tlm(ng)%name)
            CALL close_file (ng, irpm, 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 (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
      END IF
 
# ifdef RP_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
            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
            avg(ng)%load=avg(ng)%load+1
            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, irpm, avg(ng)%name)
#  endif
            avg(ng)%files(fcount)=trim(avg(ng)%name)
            CALL close_file (ng, irpm, 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
 
# ifdef FOUR_DVAR
#  ifndef WEAK_CONSTRAINT
!
!-----------------------------------------------------------------------
!  Create tangent linear model initial conditions file, if necessary.
!-----------------------------------------------------------------------
!
!  If start of descent algorithm iterations, create initial conditions
!  file or prepare existing file to append new data to it.
!
      IF (first) THEN
        first=.false.
        CALL tl_def_ini (ng)
        IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
      END IF
#  endif
#  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, irpm, .false.)
        CALL obs_write (ng, tile, irpm)
#   if defined R4DVAR    || defined R4DVAR_ANA_SENSITIVITY || \
       defined tl_r4dvar
        CALL obs_cost (ng, irpm)
#   endif
      ELSE
        processobs(ng)=.false.
      END IF
#  endif
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off output data time wall clock.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, irpm, 8, __line__, myfile)
# endif
!
 10   FORMAT (/,' RP_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 rp_output
#else
      SUBROUTINE rp_output
      RETURN
      END SUBROUTINE rp_output
#endif