#include "cppdefs.h" #if (defined TANGENT || defined TL_IOMS) && defined FOUR_DVAR SUBROUTINE rp_wrt_ini (ng, Tindex, OutRec) ! !svn $Id: rp_wrt_ini.F 889 2018-02-10 03:32:52Z arango $ !================================================== Hernan G. Arango === ! Copyright (c) 2002-2019 The ROMS/TOMS Group ! ! Licensed under a MIT/X style license ! ! See License_ROMS.txt ! !======================================================================= ! ! ! This routine writes representer model initial conditions into ! ! IRP(ng)%name initial conditions NetCDF file. ! ! ! ! On Input: ! ! ! ! ng Nested grid number. ! ! Tindex State variables time index to write. ! ! OutRec NetCDF file unlimited dimension record to write. ! ! ! ! Notice that only momentum is affected by the full time-averaged ! ! masks. If applicable, these mask contains information about ! ! river runoff and time-dependent wetting and drying variations. ! ! ! !======================================================================= ! USE mod_param USE mod_parallel # ifdef ADJUST_BOUNDARY USE mod_boundary # endif # if defined ADJUST_WSTRESS || defined ADJUST_STFLUX USE mod_forces # endif USE mod_fourdvar USE mod_grid USE mod_iounits USE mod_mixing USE mod_ncparam USE mod_netcdf USE mod_ocean USE mod_scalars # if defined SEDIMENT_NOT_YET || defined BBL_MODEL_NOT_YET USE mod_sediment # endif USE mod_stepping ! USE nf_fwrite2d_mod, ONLY : nf_fwrite2d # ifdef ADJUST_BOUNDARY USE nf_fwrite2d_bry_mod, ONLY : nf_fwrite2d_bry # endif # ifdef SOLVE3D USE nf_fwrite3d_mod, ONLY : nf_fwrite3d # ifdef ADJUST_BOUNDARY USE nf_fwrite3d_bry_mod, ONLY : nf_fwrite3d_bry # endif # endif USE strings_mod, ONLY : FoundError ! implicit none ! ! Imported variable declarations. ! integer, intent(in) :: ng, Tindex, OutRec ! ! Local variable declarations. ! integer :: LBi, UBi, LBj, UBj # ifdef ADJUST_BOUNDARY integer :: LBij, UBij # endif integer :: gfactor, gtype, i, itrc, status, varid real(r8) :: my_time, scale character (len=15) :: string ! LBi=LBOUND(GRID(ng)%h,DIM=1) UBi=UBOUND(GRID(ng)%h,DIM=1) LBj=LBOUND(GRID(ng)%h,DIM=2) UBj=UBOUND(GRID(ng)%h,DIM=2) # ifdef ADJUST_BOUNDARY LBij=BOUNDS(ng)%LBij UBij=BOUNDS(ng)%UBij # endif ! SourceFile=__FILE__ ! !----------------------------------------------------------------------- ! Write out tangent linear initial conditions. !----------------------------------------------------------------------- ! IF (FoundError(exit_flag, NoError, __LINE__, & & __FILE__)) RETURN ! ! Set grid type factor to write full (gfactor=1) fields or water ! points (gfactor=-1) fields only. ! # if defined WRITE_WATER && defined MASKING gfactor=-1 # else gfactor=1 # endif ! ! Write out model time (s). Use the "tdays" variable here because of ! the management of the "time" variable due to nesting. ! my_time=tdays(ng)*day2sec CALL netcdf_put_fvar (ng, iRPM, IRP(ng)%name, & & TRIM(Vname(1,idtime)), my_time, & & (/OutRec/), (/1/), & & ncid = IRP(ng)%ncid, & & varid = IRP(ng)%Vid(idtime)) IF (FoundError(exit_flag, NoError, __LINE__, & & __FILE__)) RETURN ! ! Write out free-surface (m) ! scale=1.0_r8 gtype=gfactor*r2dvar status=nf_fwrite2d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Vid(idFsur), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, scale, & # ifdef MASKING & GRID(ng) % rmask, & # endif # ifdef WET_DRY & OCEAN(ng) % tl_zeta(:,:,Tindex), & & SetFillVal = .FALSE.) # else & OCEAN(ng) % tl_zeta(:,:,Tindex)) # endif IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idFsur)), OutRec END IF exit_flag=3 ioerror=status RETURN END IF # ifdef ADJUST_BOUNDARY ! ! Write out free-surface open boundaries. ! IF (ANY(Lobc(:,isFsur,ng))) THEN scale=1.0_r8 status=nf_fwrite2d_bry (ng, iRPM, IRP(ng)%name, IRP(ng)%ncid, & & Vname(1,idSbry(isFsur)), & & IRP(ng)%Vid(idSbry(isFsur)), & & OutRec, r2dvar, & & LBij, UBij, Nbrec(ng), scale, & & BOUNDARY(ng) % tl_zeta_obc(LBij:,:,:, & & Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idSbry(isFsur))), OutRec END IF exit_flag=3 ioerror=status RETURN END IF END IF # endif ! ! Write out 2D U-momentum component (m/s). ! scale=1.0_r8 gtype=gfactor*u2dvar status=nf_fwrite2d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Vid(idUbar), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, scale, & # ifdef MASKING & GRID(ng) % umask_full, & # endif & OCEAN(ng) % tl_ubar(:,:,Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idUbar)), OutRec END IF exit_flag=3 ioerror=status RETURN END IF # ifdef ADJUST_BOUNDARY ! ! Write out 2D U-momentum component open boundaries. ! IF (ANY(Lobc(:,isUbar,ng))) THEN scale=1.0_r8 status=nf_fwrite2d_bry (ng, iRPM, IRP(ng)%name, IRP(ng)%ncid, & & Vname(1,idSbry(isUbar)), & & IRP(ng)%Vid(idSbry(isUbar)), & & OutRec, u2dvar, & & LBij, UBij, Nbrec(ng), scale, & & BOUNDARY(ng) % tl_ubar_obc(LBij:,:,:, & & Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idSbry(isUbar))), OutRec END IF exit_flag=3 ioerror=status RETURN END IF END IF # endif ! ! Write out 2D V-momentum component (m/s). ! scale=1.0_r8 gtype=gfactor*v2dvar status=nf_fwrite2d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Vid(idVbar), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, scale, & # ifdef MASKING & GRID(ng) % vmask_full, & # endif & OCEAN(ng) % tl_vbar(:,:,Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idVbar)), OutRec END IF exit_flag=3 ioerror=status RETURN END IF # ifdef ADJUST_BOUNDARY ! ! Write out 2D V-momentum component open boundaries. ! IF (ANY(Lobc(:,isVbar,ng))) THEN scale=1.0_r8 status=nf_fwrite2d_bry (ng, iRPM, IRP(ng)%name, IRP(ng)%ncid, & & Vname(1,idSbry(isVbar)), & & IRP(ng)%Vid(idSbry(isVbar)), & & OutRec, v2dvar, & & LBij, UBij, Nbrec(ng), scale, & & BOUNDARY(ng) % tl_vbar_obc(LBij:,:,:, & & Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idSbry(isVbar))), OutRec END IF exit_flag=3 ioerror=status RETURN END IF END IF # endif # ifdef ADJUST_WSTRESS ! ! Write out surface U-momentum stress. Notice that the stress has its ! own fixed time-dimension (of size Nfrec) to allow 4DVAR adjustments ! at other times in addition to initialization time. ! !! scale=rho0 scale=1.0_r8 gtype=gfactor*u3dvar status=nf_fwrite3d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Vid(idUsms), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, 1, Nfrec(ng), scale, & # ifdef MASKING & GRID(ng) % umask, & # endif & FORCES(ng) % tl_ustr(:,:,:,Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idUsms)), OutRec END IF exit_flag=3 ioerror=status RETURN END IF ! ! Write out surface V-momentum stress. ! !! scale=rho0 scale=1.0_r8 gtype=gfactor*v3dvar status=nf_fwrite3d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Vid(idVsms), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, 1, Nfrec(ng), scale, & # ifdef MASKING & GRID(ng) % vmask, & # endif & FORCES(ng) % tl_vstr(:,:,:,Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idVsms)), OutRec END IF exit_flag=3 ioerror=status RETURN END IF # endif # ifdef SOLVE3D ! ! Write out 3D U-momentum component (m/s). ! scale=1.0_r8 gtype=gfactor*u3dvar status=nf_fwrite3d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Vid(idUvel), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, 1, N(ng), scale, & # ifdef MASKING & GRID(ng) % umask_full, & # endif & OCEAN(ng) % tl_u(:,:,:,Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idUvel)), OutRec END IF exit_flag=3 ioerror=status RETURN END IF # ifdef ADJUST_BOUNDARY ! ! Write out 3D U-momentum component open boundaries. ! IF (ANY(Lobc(:,isUvel,ng))) THEN scale=1.0_r8 status=nf_fwrite3d_bry (ng, iRPM, IRP(ng)%name, IRP(ng)%ncid, & & Vname(1,idSbry(isUvel)), & & IRP(ng)%Vid(idSbry(isUvel)), & & OutRec, u3dvar, & & LBij, UBij, 1, N(ng), Nbrec(ng), scale, & & BOUNDARY(ng) % tl_u_obc(LBij:,:,:,:, & & Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idSbry(isUvel))), OutRec END IF exit_flag=3 ioerror=status RETURN END IF END IF # endif ! ! Write out 3D V-momentum component (m/s). ! scale=1.0_r8 gtype=gfactor*v3dvar status=nf_fwrite3d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Vid(idVvel), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, 1, N(ng), scale, & # ifdef MASKING & GRID(ng) % vmask_full, & # endif & OCEAN(ng) % tl_v(:,:,:,Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idVvel)), OutRec END IF exit_flag=3 ioerror=status RETURN END IF # ifdef ADJUST_BOUNDARY ! ! Write out 3D V-momentum component open boundaries. ! IF (ANY(Lobc(:,isVvel,ng))) THEN scale=1.0_r8 status=nf_fwrite3d_bry (ng, iRPM, IRP(ng)%name, IRP(ng)%ncid, & & Vname(1,idSbry(isVvel)), & & IRP(ng)%Vid(idSbry(isVvel)), & & OutRec, v3dvar, & & LBij, UBij, 1, N(ng), Nbrec(ng), scale, & & BOUNDARY(ng) % tl_v_obc(LBij:,:,:,:, & & Tindex)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idSbry(isVvel))), OutRec END IF exit_flag=3 ioerror=status RETURN END IF END IF # endif ! ! Write out tracer type variables. ! DO itrc=1,NT(ng) scale=1.0_r8 gtype=gfactor*r3dvar status=nf_fwrite3d(ng, iRPM, IRP(ng)%ncid, IRP(ng)%Tid(itrc), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, 1, N(ng), scale, & # ifdef MASKING & GRID(ng) % rmask, & # endif & OCEAN(ng) % tl_t(:,:,:,Tindex,itrc)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idTvar(itrc))), OutRec END IF exit_flag=3 ioerror=status RETURN END IF END DO # ifdef ADJUST_BOUNDARY ! ! Write out tracers open boundaries. ! DO itrc=1,NT(ng) IF (ANY(Lobc(:,isTvar(itrc),ng))) THEN scale=1.0_r8 status=nf_fwrite3d_bry (ng, iRPM, IRP(ng)%name, IRP(ng)%ncid, & & Vname(1,idSbry(isTvar(itrc))), & & IRP(ng)%Vid(idSbry(isTvar(itrc))), & & OutRec, r3dvar, & & LBij, UBij, 1, N(ng), Nbrec(ng), & & scale, & & BOUNDARY(ng) % tl_t_obc(LBij:,:,:,:, & & Tindex,itrc)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idSbry(isTvar(itrc)))), & & OutRec END IF exit_flag=3 ioerror=status RETURN END IF END IF END DO # endif # ifdef ADJUST_STFLUX ! ! Write out surface net tracers fluxes. Notice that fluxes have their ! own fixed time-dimension (of size Nfrec) to allow 4DVAR adjustments ! at other times in addition to initialization time. ! DO itrc=1,NT(ng) IF (Lstflux(itrc,ng)) THEN scale=1.0_r8 gtype=gfactor*r3dvar status=nf_fwrite3d(ng, iRPM, IRP(ng)%ncid, & & IRP(ng)%Vid(idTsur(itrc)), & & OutRec, gtype, & & LBi, UBi, LBj, UBj, 1, Nfrec(ng), scale, & # ifdef MASKING & GRID(ng) % rmask, & # endif & FORCES(ng) % tl_tflux(:,:,:,Tindex,itrc)) IF (FoundError(status, nf90_noerr, __LINE__, & & __FILE__)) THEN IF (Master) THEN WRITE (stdout,10) TRIM(Vname(1,idTsur(itrc))), & & OutRec END IF exit_flag=3 ioerror=status RETURN END IF END IF END DO # endif # endif ! !----------------------------------------------------------------------- ! Synchronize tangent linear initial NetCDF file to disk to allow other ! processes to access data immediately after it is written. !----------------------------------------------------------------------- ! CALL netcdf_sync (ng, iRPM, IRP(ng)%name, IRP(ng)%ncid) IF (FoundError(exit_flag, NoError, __LINE__, & & __FILE__)) RETURN IF (Master) THEN IF (OutRec.eq.2) THEN string='initial fields' END IF # ifdef SOLVE3D WRITE (stdout,20) string, Nrun, Tindex, Tindex, OutRec # else WRITE (stdout,20) string, Nrun, Tindex, OutRec # endif END IF ! 10 FORMAT (/,' RP_WRT_INI - error while writing variable: ',a,/,14x, & & 'into tangent initial NetCDF file for time record: ',i4) # ifdef SOLVE3D 20 FORMAT (3x,'RP_WRT_INI - wrote ',a,' (Iter=',i4.4,', Index=', & & i1,',',i1,', Rec=',i4.4,')') # else 20 FORMAT (3x,'RP_WRT_INI - wrote ',a,' (Iter=',i4.4,', Index=', & & i1,', Rec=',i4.4,')') # endif #else SUBROUTINE rp_wrt_ini #endif RETURN END SUBROUTINE rp_wrt_ini