edit_multifile.F

Go to the documentation of this file.

#include "cppdefs.h"
      SUBROUTINE edit_multifile (task)
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group                              !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  Edits and updates derived type structure TYPE(T_IO) for the I/O     !
!  manipulation in some algorithms.                                    !
!                                                                      !
!  For example, the forward trajectory files can be split into several !
!  multifiles to avoid creating large files in 4D-Var.                 !
!                                                                      !
!  Notice the base filename is not modified to preserve the root value !
!  specified by the user.                                              !
!                                                                      !
!=======================================================================
!
      USE mod_param
      USE mod_iounits
      USE mod_ncparam
      USE mod_scalars
!
      USE close_io_mod, ONLY : close_file
!
!  Imported variable declarations.
!
      character (len=*) :: task
!
!  Local variable declarations.
!
      integer :: Iunder, ifile, lstr, ng
      integer :: Nfiles
!
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__
!
      sourcefile=myfile
!
!-----------------------------------------------------------------------
!  Edit and update multi-file structure acconding to requested task.
!-----------------------------------------------------------------------
!
!  If multiple history files, close the last one created by the
!  nonlinear model to avoid exceeding the number of allowed opened
!  files in UNIX. Recall that the 4D-Var algorithms will open and
!  close the forward multi-file many times in the TLM and ADM in
!  the inner loops.
!
      DO ng=1,ngrids
!
        SELECT CASE (trim(adjustl(task)))
!
!  Load HIS information into the FWD structure so it can be used to
!  process the NLM background trajectory by the ADM and TLM kernels.
!
          CASE ('HIS2FWD')
            fwd(ng)%IOtype=his(ng)%IOtype
            IF (ndefhis(ng).gt.0) THEN
              CALL close_file (ng, inlm, his(ng), his(ng)%name)
              nfiles=ntimes(ng)/ndefhis(ng)
              IF (nhis(ng).eq.ndefhis(ng)) nfiles=nfiles+1
              CALL edit_file_struct (ng, nfiles, fwd)
              DO ifile=1,nfiles
                fwd(ng)%files(ifile)=trim(his(ng)%files(ifile))
              END DO
              fwd(ng)%name=trim(fwd(ng)%files(1))
            ELSE
              IF (fwd(ng)%IOtype.eq.io_nf90) THEN
                fwd(ng)%ncid=his(ng)%ncid
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (fwd(ng)%IOtype.eq.io_pio) THEN
                fwd(ng)%pioFile=his(ng)%pioFile
#endif
              END IF
              fwd(ng)%name=trim(his(ng)%name)
              fwd(ng)%files(1)=trim(his(ng)%name)
            END IF
!
!  Load HIS information into the BLK structure so it can be used to
!  process the NLM background surface forcing to be read and processd
!  by the ADM and TLM kernels.
!
          CASE ('HIS2BLK')
            blk(ng)%IOtype=his(ng)%IOtype
            IF (ndefhis(ng).gt.0) THEN
              CALL close_file (ng, inlm, his(ng), his(ng)%name)
              nfiles=ntimes(ng)/ndefhis(ng)
              IF (nhis(ng).eq.ndefhis(ng)) nfiles=nfiles+1
              CALL edit_file_struct (ng, nfiles, blk)
              DO ifile=1,nfiles
                blk(ng)%files(ifile)=trim(his(ng)%files(ifile))
              END DO
              blk(ng)%name=trim(blk(ng)%files(1))
            ELSE
              IF (blk(ng)%IOtype.eq.io_nf90) THEN
                blk(ng)%ncid=-1
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (blk(ng)%IOtype.eq.io_pio) THEN
                blk(ng)%pioFile%fh=-1
#endif
              END IF
              blk(ng)%name=trim(his(ng)%name)
              blk(ng)%files(1)=trim(his(ng)%name)
            END IF
!
!  Load QCK information into the BLK structure so it can be used to
!  process the NLM background surface forcing to be read and processed
!  by the TLM, RPM, and ADM kernels.
!
          CASE ('QCK2BLK')
            blk(ng)%IOtype=qck(ng)%IOtype
            IF (ndefqck(ng).gt.0) THEN
              CALL close_file (ng, inlm, qck(ng), qck(ng)%name)
              nfiles=ntimes(ng)/ndefqck(ng)
              IF (nqck(ng).eq.ndefqck(ng)) nfiles=nfiles+1
              CALL edit_file_struct (ng, nfiles, blk)
              DO ifile=1,nfiles
                blk(ng)%files(ifile)=trim(qck(ng)%files(ifile))
              END DO
              blk(ng)%name=trim(blk(ng)%files(1))
            ELSE
              IF (blk(ng)%IOtype.eq.io_nf90) THEN
                blk(ng)%ncid=-1
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (blk(ng)%IOtype.eq.io_pio) THEN
                blk(ng)%pioFile%fh=-1
#endif
              END IF
              blk(ng)%name=trim(qck(ng)%name)
              blk(ng)%files(1)=trim(qck(ng)%name)
            END IF
!
!  Load FWD information into the BLK structure so it can be used to
!  process the NLM background surface forcing to be read and processd
!  by the ADM and TLM kernels.
!
          CASE ('FWD2BLK')
            blk(ng)%IOtype=fwd(ng)%IOtype
            nfiles=fwd(ng)%Nfiles
            IF (nfiles.gt.1) THEN
              CALL close_file (ng, inlm, blk(ng), blk(ng)%name)
              CALL edit_file_struct (ng, nfiles, blk)
              DO ifile=1,nfiles
                blk(ng)%files(ifile)=trim(fwd(ng)%files(ifile))
              END DO
              blk(ng)%name=trim(blk(ng)%files(1))
            ELSE
              IF (blk(ng)%IOtype.eq.io_nf90) THEN
                blk(ng)%ncid=-1
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (blk(ng)%IOtype.eq.io_pio) THEN
                blk(ng)%pioFile%fh=-1
#endif
              END IF
              blk(ng)%name=trim(fwd(ng)%name)
              blk(ng)%files(1)=trim(fwd(ng)%name)
            END IF
 
#ifdef RBL4DVAR_FCT_SENSITIVITY
!
!  Save FWD information into the HIS structure so it can be used to
!  process the NLM background trajectory by the ADM and TLM kernels.
!  If multi-file, FWD(ng)%head and FWD(ng)%base is overwritten to
!  default values. The initialized values in "load_s1d" are incorrect
!  because of specified input filenames are already split.
!
          CASE ('FWD2HIS')
            his(ng)%IOtype=fwd(ng)%IOtype
            nfiles=fwd(ng)%Nfiles
            IF (nfiles.gt.1) THEN
              CALL close_file (ng, inlm, his(ng), his(ng)%name)
              CALL edit_file_struct (ng, nfiles, his)
              DO ifile=1,nfiles
                his(ng)%files(ifile)=trim(fwd(ng)%files(ifile))
              END DO
              his(ng)%name=trim(his(ng)%files(1))
              istring=index(his(ng)%name,'_outer',back=.false.)
              IF (istring.gt.0) THEN     ! outer loop prefix
                lstr=istring-1
                his(ng)%head=trim(adjustl(his(ng)%name(1:lstr)))
                fwd(ng)%head=trim(adjustl(his(ng)%name(1:lstr)))
              END IF
              istring=index(his(ng)%name,char(95),back=.true.)
              IF (istring.gt.0) THEN   ! first underscode backwards
                lstr=istring-1
                his(ng)%base=trim(adjustl(his(ng)%name(1:lstr)))
                fwd(ng)%base=trim(adjustl(his(ng)%name(1:lstr)))
              END IF
            ELSE
              IF (his(ng)%IOtype.eq.io_nf90) THEN
                his(ng)%ncid=fwd(ng)%ncid
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (his(ng)%IOtype.eq.io_pio) THEN
                his(ng)%pioFile=fwd(ng)%pioFile
#endif
              END IF
              his(ng)%files(1)=trim(fwd(ng)%files(1))
              his(ng)%name=trim(his(ng)%files(1))
              istring=index(his(ng)%name,'_outer',back=.false.)
              IF (istring.gt.0) THEN     ! outer loop prefix
                lstr=istring-1
                his(ng)%head=trim(adjustl(his(ng)%name(1:lstr)))
                his(ng)%base=trim(adjustl(his(ng)%name(1:lstr)))
              END IF
            END IF
!
!  Load FCTA information into the FWD structure so it can be used to
!  process the NLM background trajectory by the ADM and TLM kernels.
!
          CASE ('FCTA2FWD')
            fwd(ng)%IOtype=fcta(ng)%IOtype
            nfiles=fcta(ng)%Nfiles
            IF (nfiles.gt.1) THEN
              CALL close_file (ng, inlm, fcta(ng), fcta(ng)%name)
              CALL edit_file_struct (ng, nfiles, fwd)
              DO ifile=1,nfiles
                fwd(ng)%files(ifile)=trim(fcta(ng)%files(ifile))
              END DO
              fwd(ng)%name=trim(fwd(ng)%files(1))
            ELSE
              IF (fwd(ng)%IOtype.eq.io_nf90) THEN
                fwd(ng)%ncid=fcta(ng)%ncid
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (fwd(ng)%IOtype.eq.io_pio) THEN
                fwd(ng)%pioFile=fcta(ng)%pioFile
#endif
              END IF
              fwd(ng)%name=trim(fcta(ng)%name)
              fwd(ng)%files(1)=trim(fcta(ng)%name)
            END IF
!
!  Load FCTA information into the BLK structure so it can be used to
!  process the NLM background surface forcing to be read and processd
!  by the ADM and TLM kernels.
!
          CASE ('FCTA2BLK')
            blk(ng)%IOtype=fcta(ng)%IOtype
            nfiles=fcta(ng)%Nfiles
            IF (nfiles.gt.1) THEN
              CALL close_file (ng, inlm, fcta(ng), fcta(ng)%name)
              CALL edit_file_struct (ng, nfiles, blk)
              DO ifile=1,nfiles
                blk(ng)%files(ifile)=trim(fcta(ng)%files(ifile))
              END DO
              blk(ng)%name=trim(blk(ng)%files(1))
            ELSE
              IF (blk(ng)%IOtype.eq.io_nf90) THEN
                blk(ng)%ncid=-1
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (blk(ng)%IOtype.eq.io_pio) THEN
                blk(ng)%pioFile%fh=-1
#endif
              END IF
              blk(ng)%name=trim(fcta(ng)%name)
              blk(ng)%files(1)=trim(fcta(ng)%name)
            END IF
!
!  Load FCTB information into the FWD structure so it can be used to
!  process the NLM background trajectory by the ADM and TLM kernels.
!
          CASE ('FCTB2FWD')
            fwd(ng)%IOtype=fctb(ng)%IOtype
            nfiles=fctb(ng)%Nfiles
            IF (nfiles.gt.1) THEN
              CALL close_file (ng, inlm, fctb(ng), fctb(ng)%name)
              CALL edit_file_struct (ng, nfiles, fwd)
              DO ifile=1,nfiles
                fwd(ng)%files(ifile)=trim(fctb(ng)%files(ifile))
              END DO
              fwd(ng)%name=trim(fwd(ng)%files(1))
            ELSE
              IF (fwd(ng)%IOtype.eq.io_nf90) THEN
                fwd(ng)%ncid=fctb(ng)%ncid
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (fwd(ng)%IOtype.eq.io_pio) THEN
                fwd(ng)%pioFile=fctb(ng)%pioFile
#endif
              END IF
              fwd(ng)%name=trim(fctb(ng)%name)
              fwd(ng)%files(1)=trim(fctb(ng)%name)
            END IF
!
!  Load FCTB information into the BLK structure so it can be used to
!  process the NLM background surface forcing to be read and processd
!  by the ADM and TLM kernels.
!
          CASE ('FCTB2BLK')
            blk(ng)%IOtype=fctb(ng)%IOtype
            nfiles=fctb(ng)%Nfiles
            IF (nfiles.gt.1) THEN
              CALL close_file (ng, inlm, fctb(ng), fctb(ng)%name)
              CALL edit_file_struct (ng, nfiles, blk)
              DO ifile=1,nfiles
                blk(ng)%files(ifile)=trim(fctb(ng)%files(ifile))
              END DO
              blk(ng)%name=trim(blk(ng)%files(1))
            ELSE
              IF (blk(ng)%IOtype.eq.io_nf90) THEN
                blk(ng)%ncid=-1
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (blk(ng)%IOtype.eq.io_pio) THEN
                blk(ng)%pioFile%fh=-1
#endif
              END IF
              blk(ng)%name=trim(fctb(ng)%name)
              blk(ng)%files(1)=trim(fctb(ng)%name)
            END IF
#endif
!
!  Load TLM information into the FWD structure so it can be used to
!  process the RPM background trajectory by the RPM, ADM and TLM
!  kernels.  Used in R4D-Var.
!
          CASE ('TLM2FWD')
            fwd(ng)%IOtype=tlm(ng)%IOtype
            IF (ndeftlm(ng).gt.0) THEN
              CALL close_file (ng, inlm, tlm(ng), tlm(ng)%name)
              nfiles=ntimes(ng)/ndeftlm(ng)
              IF (ntlm(ng).eq.ndeftlm(ng)) nfiles=nfiles+1
              CALL edit_file_struct (ng, nfiles, fwd)
              DO ifile=1,nfiles
                fwd(ng)%files(ifile)=trim(tlm(ng)%files(ifile))
              END DO
              fwd(ng)%name=trim(fwd(ng)%files(1))
            ELSE
              IF (fwd(ng)%IOtype.eq.io_nf90) THEN
                fwd(ng)%ncid=tlm(ng)%ncid
#if defined PIO_LIB && defined DISTRIBUTE
              ELSE IF (fwd(ng)%IOtype.eq.io_pio) THEN
                fwd(ng)%pioFile=tlm(ng)%pioFile
#endif
              END IF
              fwd(ng)%name=trim(tlm(ng)%name)
              fwd(ng)%files(1)=trim(tlm(ng)%name)
            END IF
!
        END SELECT
      END DO
 
      RETURN
      END SUBROUTINE edit_multifile
!
      SUBROUTINE edit_file_struct (ng, Nfiles, S)
!
!***********************************************************************
!                                                                      !
!  This function loads input values into requested 1D structure        !
!  containing information about I/O files.                             !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number (integer)                          !
!     Nfiles     Number of desired files (integer)                     !
!     S          Derived type 1D structure, TYPE(T_IO)                 !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     S          Updated erived type 1D structure, TYPE(T_IO)          !
!                                                                      !
!***********************************************************************
!
      USE mod_param
      USE mod_iounits
      USE mod_ncparam, ONLY : nv
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, Nfiles
 
      TYPE(t_io), intent(inout) :: S(Ngrids)
!
!  Local variable declarations.
!
      integer :: i, j, lstr
 
      character (len=  1), parameter :: blank = ' '
!
!-----------------------------------------------------------------------
!  If the number of multifiles in the structure is different, allocate
!  to the desired number of files.
!-----------------------------------------------------------------------
!
!  If the number of muti-files in structure is different than requested
!  values, deallocate and reallocate to the desired number of files.
!
      IF (s(ng)%Nfiles.ne.nfiles) THEN
        IF (associated(s(ng)%Nrec))     deallocate (s(ng)%Nrec)
        IF (associated(s(ng)%time_min)) deallocate (s(ng)%time_min)
        IF (associated(s(ng)%time_max)) deallocate (s(ng)%time_max)
        IF (associated(s(ng)%files))    deallocate (s(ng)%files)
!
        allocate ( s(ng)%Nrec(nfiles) )
        allocate ( s(ng)%time_min(nfiles) )
        allocate ( s(ng)%time_max(nfiles) )
        allocate ( s(ng)%files(nfiles) )
      END IF
!
!  Intialize strings to blank to facilitate processing.
!
      lstr=len(s(ng)%name)
      DO i=1,lstr
        s(ng)%name(i:i)=blank
      END DO
      DO j=1,nfiles
        DO i=1,lstr
          s(ng)%files(j)(i:i)=blank
        END DO
      END DO
!
!  Initialize and load fields into structure.  The base filename value
!  was already updated somewhere else.
!
      s(ng)%Nfiles=nfiles                      ! number of multi-files
      s(ng)%Fcount=1                           ! multi-file counter
      s(ng)%Rindex=0                           ! time index
      s(ng)%ncid=-1                            ! closed NetCDF state
      s(ng)%Vid=-1                             ! NetCDF variables IDs
      s(ng)%Tid=-1                             ! NetCDF tracers IDs
#if defined PIO_LIB && defined DISTRIBUTE
      s(ng)%pioFile%fh=-1                      ! closed file handler
      DO i=1,nv
        s(ng)%pioVar(i)%vd%varID=-1            ! variables IDs
        s(ng)%pioVar(i)%dkind=-1               ! variables data kind
        s(ng)%pioVar(i)%gtype=0                ! variables C-grid type
      END DO
      DO i=1,mt
        s(ng)%pioTrc(i)%vd%varID=-1            ! tracers IDs
        s(ng)%pioTrc(i)%dkind=-1               ! tracers data kind
        s(ng)%pioTrc(i)%gtype=0                ! tracers C-grid type
      END DO
#endif
      s(ng)%Nrec=0                             ! record counter
      s(ng)%time_min=0.0_dp                    ! starting time
      s(ng)%time_max=0.0_dp                    ! ending time
!
  10  FORMAT (a,'_',i4.4,'.nc')
!
      RETURN
      END SUBROUTINE edit_file_struct