diff --git a/ROMS/Drivers/nl_roms.h b/ROMS/Drivers/nl_roms.h index dadecf7d4..d1ddd0aba 100644 --- a/ROMS/Drivers/nl_roms.h +++ b/ROMS/Drivers/nl_roms.h @@ -29,7 +29,7 @@ USE mod_ncparam USE mod_scalars ! -#ifdef VERIFICATION +#if defined VERIFICATION && defined ARCHAIC_OBS USE def_mod_mod, ONLY : def_mod #endif USE close_io_mod, ONLY : close_inp, close_out @@ -43,7 +43,12 @@ # endif #endif #ifdef VERIFICATION +# ifdef MODERN_OBS + USE roms_hofx_mod, ONLY : hofx_finalize +# endif +# ifdef ARCHAIC_OBS USE stats_modobs_mod, ONLY : stats_modobs +# endif #endif USE stdout_mod, ONLY : Set_StdOutUnit, stdout_unit USE strings_mod, ONLY : FoundError @@ -215,6 +220,7 @@ Nrun=1 #ifdef VERIFICATION +# ifdef ARCHAIC_OBS ! ! Create NetCDF file for model solution at observation locations. ! @@ -227,6 +233,19 @@ IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN END DO END IF +# endif +# ifdef MODERN_OBS +! +! Set switches to compute and write model at observation locations. +! + IF (Nrun.eq.1) THEN + DO ng=1,Ngrids + LdefMOD(ng)=.TRUE. + wrtNLmod(ng)=.TRUE. + wrtObsScale(ng)=.TRUE. + END DO + END IF +# endif #endif #ifdef ENKF_RESTART ! @@ -350,18 +369,29 @@ END IF #endif #ifdef VERIFICATION +# ifdef ARCHAIC_OBS ! !----------------------------------------------------------------------- ! Compute and report model-observation comparison statistics. !----------------------------------------------------------------------- ! DO ng=1,Ngrids -# ifdef DISTRIBUTE +# ifdef DISTRIBUTE CALL stats_modobs (ng, MyRank) -# else +# else CALL stats_modobs (ng, -1) -# endif +# endif END DO +# endif +# ifdef MODERN_OBS +! +!----------------------------------------------------------------------- +! Finalize model at observation locations, H(x). Then, write ouput +! enhanced NetCDF-4 files. +!----------------------------------------------------------------------- +! + CALL hofx_finalize (iNLM) +# endif #endif ! !----------------------------------------------------------------------- diff --git a/ROMS/External/s4dvar.in b/ROMS/External/s4dvar.in index 8624d018b..fd7fa9d6b 100644 --- a/ROMS/External/s4dvar.in +++ b/ROMS/External/s4dvar.in @@ -434,7 +434,7 @@ Sigma_max(isTvar) == 0.33d0 0.056d0 ! 1:NT tracers maximum STD F F F F ! Input model, initial conditions, boundary conditions, and surface forcing -! standard deviation file names, [1:Ngrids]. +! standard deviation filenames, [1:Ngrids]. STDnameM == roms_std_m.nc STDnameI == roms_std_i.nc @@ -443,40 +443,42 @@ Sigma_max(isTvar) == 0.33d0 0.056d0 ! 1:NT tracers maximum STD ! If computing the standard deviation from the background (prior) state ! vector as an alternative to climatological values read from the -! input NetCDF file, enter output standard deviation file name, +! input NetCDF file, enter output standard deviation filename, ! [1:Ngrids]. STDnameC == roms_std_c.nc ! Input/output model, initial conditions, boundary conditions, and surface -! forcing error covariance normalization factors file name, [1:Ngrids]. +! forcing error covariance normalization factors filename, [1:Ngrids]. NRMnameM == roms_nrm_m.nc NRMnameI == roms_nrm_i.nc NRMnameB == roms_nrm_b.nc NRMnameF == roms_nrm_f.nc -! Input/output observation file name, [1:Ngrids]. +! Input observation filename(s), [1:Ngrids]. + + NOBSFILES = 1 OBSname == roms_obs.nc -! Input/output Hessian eigenvectors file name, [1:Ngrids]. +! Input/output Hessian eigenvectors filename, [1:Ngrids]. HSSname == roms_hss.nc -! Input/output Lanczos vectors file name, [1:Ngrids]. +! Input/output Lanczos vectors filename, [1:Ngrids]. LCZname == roms_lcz.nc -! Output time-evolved Lanczos vectors file name, [1:Ngrids]. +! Output time-evolved Lanczos vectors filename, [1:Ngrids]. LZEname == roms_lze.nc -! Output model data at observation locations file name, [1:Ngrids]. +! Output model data at observation locations filename, [1:Ngrids]. MODname == roms_mod.nc -! Output posterior error covariance matrix file name, [1:Ngrids]. +! Output posterior error covariance matrix filename, [1:Ngrids]. ERRname == roms_err.nc @@ -487,7 +489,7 @@ Sigma_max(isTvar) == 0.33d0 0.056d0 ! 1:NT tracers maximum STD OIFnameA == roms_oif_a.nc OIFnameB == roms_oif_b.nc -! Input coarser grid increment file name, [1:Ngrids]. It is used in +! Input coarser grid increment filename, [1:Ngrids]. It is used in ! mixed-resolution split 4D-Var for regridding (coarse-to-fine), where ! the inner loops are run at lower resolution to accelerate the computations. @@ -1028,50 +1030,60 @@ Sigma_max(isTvar) == 0.33d0 0.056d0 ! 1:NT tracers maximum STD ! Input/Output NetCDF files (a string with a maximum of 256 characters). !------------------------------------------------------------------------------ ! +! NOBSFILES Number of observation files, usually NOBSFILES=1. +! +! OBSname Input/Output observations data filename(s). +! +! Users can utilize the original native 4D-Var NetCDF file, +! which consolidates all observations into a single vector +! sorted in ascending order of time. As the observation +! operators and filters become increasingly complex, +! separating the observations into multiple files can be +! beneficial. Alternatively, IODA enhanced-NetCDF4 files +! with "Groups" are also acceptable. +! ! STDnameM Input model error covariance -! standard deviation file name. +! standard deviation filename. ! ! STDnameI Input initial conditions error covariance -! standard deviation file name. +! standard deviation filename. ! ! STDnameB Input open boundary conditions error covariance -! standard deviation file name. +! standard deviation filename. ! ! STDnameF Input surface forcing error covariance -! standard deviation file name. +! standard deviation filename. ! -! STDnameC Output standard deviation file name +! STDnameC Output standard deviation filename ! computed from background (prior) state ! ! NRMnameM Input/output model error covariance -! normalization factors file name. +! normalization factors filename. ! ! NRMnameI Input/output initial conditions error covariance -! normalization factors file name. +! normalization factors filename. ! ! NRMnameB Input/output open boundary conditions error covariance -! normalization factors file name. +! normalization factors filename. ! ! NRMnameF Input/output surface forcing error covariance -! normalization factors file name. -! -! OBSname Input/Output observations data file name. +! normalization factors filename. ! -! HSSname Input/Output Hessian eigenvectors file name. +! HSSname Input/Output Hessian eigenvectors filename. ! -! LCZname Input/output Lanczos vectors file name. +! LCZname Input/output Lanczos vectors filename. ! -! LZEname Output time-evolved Lanczos vectors file name. +! LZEname Output time-evolved Lanczos vectors filename. ! -! MODname Output model data at observations locations file name. +! MODname Output model data at observations locations filename. ! -! ERRname Output posterior error covariance matrix file name. +! ERRname Output posterior error covariance matrix filename. ! -! Input coarser grid increment file name, [1:Ngrids]. It is used in +! Input coarser grid increment filename, [1:Ngrids]. It is used in ! mixed-resolution split 4D-Var for regridding (coarse-to-fine), where ! the inner loops are run at lower resolution to accelerate the computations. ! -! INCname Coarse grid increment file name. +! INCname Coarse grid increment filename. ! ! Input forcing filenames at observation locations for computing observations ! impacts during the analysis-forecast cycle when RBL4DVAR_FCT_SENSITIVITY and diff --git a/ROMS/Modules/mod_iounits.F b/ROMS/Modules/mod_iounits.F index 034ffec80..415f4e561 100644 --- a/ROMS/Modules/mod_iounits.F +++ b/ROMS/Modules/mod_iounits.F @@ -234,7 +234,6 @@ MODULE mod_iounits TYPE(T_IO), allocatable :: LZE(:) ! evolved Lanczos vectors TYPE(T_IO), allocatable :: NRM(:,:) ! normalization TYPE(T_IO), allocatable :: NUD(:) ! nudging coefficients - TYPE(T_IO), allocatable :: OBS(:) ! observations #if defined RBL4DVAR_FCT_SENSITIVITY && defined OBS_SPACE TYPE(T_IO), allocatable :: OIFA(:) ! observation impacts, A TYPE(T_IO), allocatable :: OIFB(:) ! observation impacts, B @@ -285,6 +284,13 @@ MODULE mod_iounits #endif TYPE(T_IO), allocatable :: FRC(:,:) ! +! Input observations data. +! + integer, allocatable :: nOBSfiles(:) +! + TYPE(T_IO), allocatable :: OBS(:) + TYPE(T_IO), allocatable :: OBS2(:,:) +! ! Error messages. ! character (len=50), dimension(9) :: Rerror = & @@ -509,6 +515,9 @@ SUBROUTINE allocate_iounits (Ngrids) IF (.not.allocated(nFfiles)) THEN allocate ( nFfiles(Ngrids) ) END IF + IF (.not.allocated(nOBSfiles)) THEN + allocate ( nOBSfiles(Ngrids) ) + END IF ! !----------------------------------------------------------------------- ! Initialize I/O NetCDF files ID to close state. @@ -566,6 +575,7 @@ SUBROUTINE allocate_iounits (Ngrids) nBCfiles(ng)=-1 nCLMfiles(ng)=-1 nFfiles(ng)=-1 + nOBSfiles(ng)=-1 END DO ! !----------------------------------------------------------------------- diff --git a/ROMS/Modules/mod_netcdf.F b/ROMS/Modules/mod_netcdf.F index 315f90663..7605c0dd9 100644 --- a/ROMS/Modules/mod_netcdf.F +++ b/ROMS/Modules/mod_netcdf.F @@ -34,6 +34,11 @@ MODULE mod_netcdf ! ! Interfaces for same name routine overloading. They differ in the kind ! type parameter and data array rank. +! + INTERFACE netcdf_copy_var ! copy between files + MODULE PROCEDURE netcdf_copy_fvar_1d + MODULE PROCEDURE netcdf_copy_ivar_1d + END INTERFACE netcdf_copy_var ! INTERFACE netcdf_get_fatt ! reads attributes #ifdef SINGLE_PRECISION @@ -118,6 +123,7 @@ MODULE mod_netcdf PUBLIC :: netcdf_create ! creates file PUBLIC :: netcdf_enddef ! ends definition mode PUBLIC :: netcdf_get_dim ! reads dimension names/values + PUBLIC :: netcdf_get_grp ! gets group ids/names/variables PUBLIC :: netcdf_get_satt ! reads string attributes PUBLIC :: netcdf_inq_var ! inquires variables PUBLIC :: netcdf_inq_varid ! inquires variable ID @@ -141,6 +147,8 @@ MODULE mod_netcdf ! integer, parameter :: Matts = 50 ! maximum number of attributes integer, parameter :: Mdims = 50 ! maximum number of dimensions + integer, parameter :: Mgrps = 50 ! maximum number of groups + integer, parameter :: Mgvar = 20 ! maximun number of group vars integer, parameter :: Mvars = 900 ! maximum number of variables integer, parameter :: NvarD = 5 ! number of variable dimensions integer, parameter :: NvarA = 50 ! number of variable attributes @@ -149,6 +157,8 @@ MODULE mod_netcdf ! all variables. ! integer :: n_dim ! number of dimensions + integer :: n_grp ! number of groups + integer :: n_gvar(Mgrps) ! number of variables per group integer :: n_var ! number of variables integer :: n_gatt ! number of global attributes integer :: ncformat ! file format number (version) @@ -157,6 +167,14 @@ MODULE mod_netcdf integer :: att_kind(Matts) ! attribute data type integer :: dim_id(Mdims) ! dimensions ID integer :: dim_size(Mdims) ! dimensions value +! + integer :: grp_id(Mgrps) ! groups ID + integer :: grp_nvatt(Mgvar,Mgrps) ! number of group var attributes + integer :: grp_nvdim(Mgvar,Mgrps) ! number of group var dimensions + integer :: grp_vdim(5,Mgvar,Mgrps)! group variables dimensions ID + integer :: grp_vid(Mgvar,Mgrps) ! group variables ID + integer :: grp_vtype(Mgvar,Mgrps) ! group var external data type +! integer :: var_id(Mvars) ! variables ID integer :: var_natt(Mvars) ! variables number of attributes integer :: var_flag(Mvars) ! Variables water points flag @@ -164,9 +182,12 @@ MODULE mod_netcdf integer :: var_ndim(Mvars) ! variables number of dimensions integer :: var_dim(NvarD,Mvars) ! variables dimensions ID ! - character (len=100) :: att_name(Matts) ! attribute names - character (len=100) :: dim_name(Mdims) ! dimension names - character (len=100) :: var_name(Mvars) ! variable names + character (len=100) :: att_name(Matts) ! attribute names + character (len=100) :: dim_name(Mdims) ! dimension names + character (len=100) :: grp_name(Mgrps) ! group names + character (len=100) :: grp_aname(20,Mgvar,Mgrps)! group attributes + character (len=100) :: grp_vname(Mgvar,Mgrps) ! group variables + character (len=100) :: var_name(Mvars) ! variable names ! ! Generic information about requested current variable. ! @@ -383,7 +404,7 @@ SUBROUTINE netcdf_get_dim (ng, model, ncname, ncid, DimName, & integer :: myID, myValue #if !defined PARALLEL_IO && defined DISTRIBUTE - integer, dimension(5) :: ibuffer + integer, dimension(6) :: ibuffer #endif ! character (len=*), parameter :: MyFile = & @@ -421,18 +442,15 @@ SUBROUTINE netcdf_get_dim (ng, model, ncname, ncid, DimName, & ! Inquire file. ! IF (InpThread) THEN -#ifdef HDF5 status=nf90_inquire(my_ncid, n_dim, n_var, n_gatt, rec_id, & - & ncformat) -#else - status=nf90_inquire(my_ncid, n_dim, n_var, n_gatt, rec_id) -#endif + & formatNum = ncformat) IF ((status.eq.nf90_noerr).and.(n_dim.le.Mdims)) THEN #if !defined PARALLEL_IO && defined DISTRIBUTE ibuffer(1)=n_dim ibuffer(2)=n_var ibuffer(3)=n_gatt ibuffer(4)=rec_id + ibuffer(5)=ncformat #endif ! ! Inquire about dimensions: names, ID, and size. @@ -452,7 +470,7 @@ SUBROUTINE netcdf_get_dim (ng, model, ncname, ncid, DimName, & IF (dim_id(i).eq.rec_id) THEN rec_size=dim_size(i) #if !defined PARALLEL_IO && defined DISTRIBUTE - ibuffer(5)=rec_size + ibuffer(6)=rec_size #endif END IF END DO @@ -481,7 +499,8 @@ SUBROUTINE netcdf_get_dim (ng, model, ncname, ncid, DimName, & n_var=ibuffer(2) n_gatt=ibuffer(3) rec_id=ibuffer(4) - rec_size=ibuffer(5) + ncformat=ibuffer(5) + rec_size=ibuffer(6) CALL mp_bcasti (ng, model, dim_id) CALL mp_bcasti (ng, model, dim_size) CALL mp_bcasts (ng, model, dim_name) @@ -533,6 +552,277 @@ SUBROUTINE netcdf_get_dim (ng, model, ncname, ncid, DimName, & ! RETURN END SUBROUTINE netcdf_get_dim +! + SUBROUTINE netcdf_get_grp (ng, model, ncname, ncid, GrpName, & + & GrpID) +! +!======================================================================= +! ! +! This routine inquires a NetCDF file number of groups, ids, names, ! +! its variables, and its variables names. All the group information ! +! is stored in the module variables declared above. ! +! ! +! Groups are only available in enhanced NetCDF-4 files having a ! +! format=nf90_format_netcdf4 (currently, 3). A group is equivanlent ! +! to a sub-directory in a file. ! +! ! +! On Input: ! +! ! +! ng Nested grid number (integer) ! +! model Calling model identifier (integer) ! +! ncname NetCDF file name (string) ! +! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName Requested group name (string, OPTIONAL) ! +! ! +! On Ouput: ! +! ! +! GrpID ID of requested group (integer, OPTIONAL) ! +! ! +! Other information stored in this module: ! +! ! +! n_grp Number of groups ! +! n_gvar Number of group variables (1:n_grp) ! +! grp_aname Group variable attribute name ! +! (grp_nvatt, 1:n_gvar, 1:n_grp) ! +! grp_id Group ID (1:n_grp) ! +! grp_name Group name (1:n_grp) ! +! grp_nvatt Number of variable attributes in a group ! +! (1:n_gvar, 1:n_grp) ! +! grp_nvdim Number of variable dimensions in a group ! +! (1:n_gvar, 1:n_grp) ! +! grp_vdim Dimension IDs for a group variable ! +! (grp_nvdim, 1:n_gvar, 1:n_grp) ! +! grp_vid Group variable ID (1:n_gvar, 1:n_grp) ! +! grp_vname Group variable name (1:n_gvar, 1:n_grp) ! +! grp_vtype Group variable data type (1:n_gvar, 1:n_grp) ! +! ! +! WARNING: This is information is rewritten during each CALL. ! +! ! +!======================================================================= +! +! Imported variable declarations. +! + integer, intent(in) :: ng, model + integer, intent(in), optional :: ncid +! + character (len=*), intent(in) :: ncname + character (len=*), intent(in), optional :: GrpName +! + integer, intent(out), optional :: GrpID +! +! Local variable declarations. +! + logical :: foundit +! + integer :: my_ncid, i, j, k, status + integer :: myID +! + character (len=*), parameter :: MyFile = & + & __FILE__//", netcdf_get_grp" +! +!----------------------------------------------------------------------- +! Inquire about the NetCDF dimensions (names and values). +!----------------------------------------------------------------------- +! +! Initialize. +! + n_grp=0 + n_gvar=0 + ncformat=-1 + grp_id=0 + grp_nvatt=0 + grp_nvdim=0 + grp_vdim=0 + grp_vid=0 + DO i=1,Mgrps + DO j=1,LEN(grp_name(1)) + grp_name(i)(j:j)=' ' + END DO + END DO + DO i=1,Mgrps + DO j=1,Mgvar + DO k=1,LEN(grp_vname(1,1)) + grp_vname(j,i)(k:k)=' ' + END DO + END DO + END DO +! +! Open file for reading. +! + IF (.not.PRESENT(ncid)) THEN + CALL netcdf_open (ng, model, TRIM(ncname), 0, my_ncid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + ELSE + my_ncid=ncid + END IF +! +! Inquire file. +! + IF (InpThread) THEN + status=nf90_inquire(my_ncid, & + & formatNum = ncformat) + IF ((status.eq.nf90_noerr).and. & + & (ncformat.eq.nf90_format_netcdf4)) THEN + status=nf90_inq_grps(my_ncid, n_grp, grp_id) + IF ((status.eq.nf90_noerr).and.(n_grp.le.Mgrps)) THEN +! +! Inquire about group names, number of variables and their IDs, and +! group variable names. +! + DO i=1,n_grp + status=nf90_inq_grpname(grp_id(i), grp_name(i)) + IF (status.eq.nf90_noerr) THEN + status=nf90_inq_varids(grp_id(i), n_gvar(i), & + & grp_vid(:,i)) + IF ((status.eq.nf90_noerr).and. & + & (n_gvar(i).le.Mgvar)) THEN + DO j=1,n_gvar(i) + status=nf90_inquire_variable(grp_id(i), & + & grp_vid(j,i), & + & grp_vname(j,i), & + & grp_vtype(j,i), & + & grp_nvdim(j,i), & + & grp_vdim(:,j,i), & + & grp_nvatt(j,i)) + IF ((status.eq.nf90_noerr).and. & + & (n_gvar(i).le.Mgvar)) THEN + DO k=1,grp_nvatt(j,i) + status=nf90_inq_attname(grp_id(i), & + & grp_vid(j,i), k, & + & grp_Aname(k,j,i)) + IF (FoundError(status, nf90_noerr, & + & __LINE__, MyFile)) THEN + WRITE (stdout,10) TRIM(grp_name(i)), & + & TRIM(grp_vname(j,i)), & + & TRIM(ncname), & + & TRIM(SourceFile), & + & nf90_strerror(status) + exit_flag=2 + ioerror=status + RETURN + END IF + END DO + ELSE + WRITE (stdout,20) TRIM(grp_name(i)), & + & grp_vid(j,i), & + & TRIM(ncname), TRIM(SourceFile), & + & nf90_strerror(status) + exit_flag=2 + ioerror=status + RETURN + END IF + END DO + ELSE + WRITE (stdout,30) TRIM(grp_name(i)), TRIM(ncname), & + & TRIM(SourceFile), & + & nf90_strerror(status) + exit_flag=2 + ioerror=status + RETURN + END IF + ELSE + WRITE (stdout,40) grp_id(i), TRIM(ncname), & + & TRIM(SourceFile), & + & nf90_strerror(status) + exit_flag=2 + ioerror=status + RETURN + END IF + END DO + ELSE + IF (n_grp.gt.Mgrps) THEN + WRITE (stdout,50) ' Mgrps = ', Mgrps, n_grp + exit_flag=2 + ioerror=0 + END IF + IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN + WRITE (stdout,60) TRIM(ncname), TRIM(SourceFile) + exit_flag=2 + ioerror=status + END IF + END IF + ELSE + WRITE (stdout,70) ncformat, nf90_format_netcdf4, & + & TRIM(ncname), TRIM(SourceFile) + exit_flag=2 + ioerror=status + END IF + END IF + +#if !defined PARALLEL_IO && defined DISTRIBUTE +! +! Broadcast dimension to all processors in the group. +! + CALL mp_bcasti (ng, model, exit_flag) + IF (exit_flag.eq.NoError) THEN + CALL mp_bcasti (ng, model, n_grp) + CALL mp_bcasti (ng, model, n_gvar) + CALL mp_bcasti (ng, model, grp_id) + CALL mp_bcasti (ng, model, grp_nvatt) + CALL mp_bcasti (ng, model, grp_nvdim) + CALL mp_bcasti (ng, model, grp_vdim) + CALL mp_bcasti (ng, model, grp_vid) + CALL mp_bcasti (ng, model, grp_vtype) + CALL mp_bcasts (ng, model, grp_Aname) + CALL mp_bcasts (ng, model, grp_name) + CALL mp_bcasts (ng, model, grp_vname) + END IF +#endif +! +! Load requested information. +! + IF (exit_flag.eq.NoError) THEN + foundit=.FALSE. + IF (PRESENT(GrpName)) THEN + DO i=1,n_grp + IF (TRIM(grp_name(i)).eq.TRIM(GrpName)) THEN + foundit=.TRUE. + CYCLE + END IF + END DO + IF (foundit) THEN + IF (PRESENT(GrpID)) THEN + GrpID=myID + END IF + ELSE + WRITE (stdout,80) TRIM(GrpName), TRIM(ncname), & + & TRIM(SourceFile) + exit_flag=2 + ioerror=status + END IF + END IF + END IF +! +! Close input NetCDF file. +! + IF (.not.PRESENT(ncid)) THEN + CALL netcdf_close (ng, model, my_ncid, ncname, .FALSE.) + END IF +! + 10 FORMAT (/,' NETCDF_GET_GRP - error while inquiring variables', & + & ' attributes, Group:',2x,a,2x,', Variable:',2x,a, & + & /,18x,'in input file:',2x,a,/,18x,'call from:',2x,a) + 20 FORMAT (/,' NETCDF_GET_GRP - error while inquiring variables', & + & ' names, Group:',2x,a,/,18x,'in input file:',2x,a, & + & /,18x,'call from:',2x,a) + 30 FORMAT (/,' NETCDF_GET_GRP - error while inquiring variable IDs', & + & ', Group:',2x,a,/,18x,'in input file:',2x,a, & + & /,18x,'call from:',2x,a) + 40 FORMAT (/,' NETCDF_GET_GRP - error while inquiring group name', & + & ', Group ID =',2x,i0,/,18x,'in input file:',2x,a, & + & /,18x,'call from:',2x,a) + 50 FORMAT (/,' NETCDF_GET_GRP - too small dimension parameter,',a, & + & 2i5,/,18x,'change file mod_netcdf.F and recompile') + 60 FORMAT (/,' NETCDF_GET_GRP - unable to inquire about Groups', & + & ' of input NetCDF file:',2x,a,/,18x,'call from:',2x,a) + 70 FORMAT (/,' NETCDF_GET_GRP - Cannot inquire about Groups ', & + & ' because of file format = ',i0,2x,'instead of ',i0, & + & /,18x,'in input file:',2x,a,/,18x,'call from:',2x,a) + 80 FORMAT (/,' NETCDF_GET_GRP - requested group: ',a,/18x, & + & 'not found in input file:',2x,a,/,18x,'call from:',2x,a) +! + RETURN + END SUBROUTINE netcdf_get_grp ! SUBROUTINE netcdf_check_dim (ng, model, ncname, ncid) ! @@ -1365,9 +1655,320 @@ SUBROUTINE netcdf_check_var (ng, model, ncname, ncid) ! RETURN END SUBROUTINE netcdf_check_var +! + SUBROUTINE netcdf_copy_fvar_1d (ng, model, ncinpName, ncoutName, & + & myVarName, A, & + & GrpName, varid, ncid) +! +!======================================================================= +! ! +! This routine copies a 1D-array variable from input to output ! +! NetCDF files. It always opens and closes the file to read the ! +! variable data. If the output NetCDF ID is not provided, it opens ! +! that file, writes the data, and then closes such file. ! +! ! +! On Input: ! +! ! +! ng Nested grid number (integer) ! +! model Calling model identifier (integer) ! +! ncinpName Input NetCDF file name (string) ! +! ncoutName Output NetCDF file name (string) ! +! myVarName Variable name (string) ! +! A Temporaty 1D variable (integer) ! +! ncid Output NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! +! varid NetCDF variable ID (integer, OPTIONAL) ! +! ! +! On Ouput: ! +! ! +! exit_flag Error flag (integer) stored in MOD_SCALARS ! +! ioerror NetCDF return code (integer) stored in MOD_IOUNITS ! +! ! +! Notice: This routine must be used to write only nontiled variables. ! +! ! +!======================================================================= +! +! Imported variable declarations. +! + integer, intent(in) :: ng, model + + real (r8), intent(inout) :: A(:) + + integer, intent(in), optional :: ncid, varid +! + character (len=*), intent(in) :: ncinpName, ncoutName + character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName +! +! Local variable declarations. +! + integer :: my_inpncid, my_inpgrpid, my_inpvarid, nfrid + integer :: my_outncid, my_outgrpid, my_outvarid, nfwid + integer :: status + +#if !defined PARALLEL_IO && defined DISTRIBUTE + integer, dimension(2) :: ibuffer +#endif +! + character (len=*), parameter :: MyFile = & + & __FILE__//", netcdf_copy_fvar_1d" +! +!----------------------------------------------------------------------- +! Copy 1D integer array from input to output NetCDF files. +!----------------------------------------------------------------------- +! +! Open input NetCDF file. +! + CALL netcdf_open (ng, model, TRIM(ncinpName), 0, my_inpncid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Read in variable from input NetCDF file. +! + IF (InpThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_inpncid, TRIM(GrpName), my_inpgrpid) + nfrid=my_inpgrpid + ELSE + nfrid=my_inpncid + END IF + status=nf90_inq_varid(nfrid, TRIM(myVarName), my_inpvarid) + IF (status.eq.nf90_noerr) THEN + status=nf90_get_var(nfrid, my_inpvarid, A) + IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN + WRITE (stdout,10) TRIM(myVarName), TRIM(ncinpName), & + & TRIM(SourceFile), nf90_strerror(status) + exit_flag=2 + ioerror=status + END IF + END IF + END IF +! +! Write out variable into output NetCDF file. +! + IF (InpThread) THEN + IF (.not.PRESENT(ncid)) THEN + CALL netcdf_open (ng, model, TRIM(ncoutname), 1, my_outncid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + ELSE + my_outncid=ncid + END IF +! + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_outncid, TRIM(GrpName), my_outgrpid) + nfwid=my_outgrpid + ELSE + nfwid=my_outncid + END IF +! + IF (.not.PRESENT(varid)) THEN + status=nf90_inq_varid(nfwid, TRIM(myVarName), my_outvarid) + IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN + WRITE (stdout,10) TRIM(myVarName), TRIM(ncoutname), & + & TRIM(SourceFile), nf90_strerror(status) + exit_flag=3 + ioerror=status + END IF + ELSE + my_outvarid=varid + END IF +! + IF (exit_flag.eq.NoError) THEN + status=nf90_put_var(nfwid, my_outvarid, A) + IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN + WRITE (stdout,20) TRIM(myVarName), TRIM(ncoutname), & + & TRIM(SourceFile), nf90_strerror(status) + exit_flag=3 + ioerror=status + END IF + END IF + END IF + +#if !defined PARALLEL_IO && defined DISTRIBUTE +! +! Broadcast error flags to all processors in the group. +! + ibuffer(1)=exit_flag + ibuffer(2)=ioerror + CALL mp_bcasti (ng, model, ibuffer) + exit_flag=ibuffer(1) + ioerror=ibuffer(2) +#endif +! +! Close files. +! + CALL netcdf_close (ng, model, my_inpncid, ncinpName, .FALSE.) + IF (.not.PRESENT(ncid)) THEN + CALL netcdf_close (ng, model, my_outncid, ncoutname, .FALSE.) + END IF +! + 10 FORMAT (/,' NETCDF_COPY_FVAR_1D - error while inquiring ID for ', & + & 'variable:',2x,a,/,23x,'in input file:',2x,a,/,22x, & + & 'call from:',2x,a,/,23x,a) + 20 FORMAT (/,' NETCDF_COPY_FVAR_1D - error while writing variable:', & + & 2x,a,/,22x,'in input file:',2x,a,/,23x,'call from:',2x,a, & + & /,23x,a) +! + RETURN + END SUBROUTINE netcdf_copy_fvar_1d +! + SUBROUTINE netcdf_copy_ivar_1d (ng, model, ncinpName, ncoutName, & + & myVarName, A, & + & GrpName, varid, ncid) +! +!======================================================================= +! ! +! This routine copies a 1D-array variable from input to output ! +! NetCDF files. It always opens and closes the file to read the ! +! variable data. If the output NetCDF ID is not provided, it opens ! +! that file, writes the data, and then closes such file. ! +! ! +! On Input: ! +! ! +! ng Nested grid number (integer) ! +! model Calling model identifier (integer) ! +! ncinpName Input NetCDF file name (string) ! +! ncoutName Output NetCDF file name (string) ! +! myVarName Variable name (string) ! +! A Temporaty 1D variable (integer) ! +! ncid Output NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! +! varid NetCDF variable ID (integer, OPTIONAL) ! +! ! +! On Ouput: ! +! ! +! exit_flag Error flag (integer) stored in MOD_SCALARS ! +! ioerror NetCDF return code (integer) stored in MOD_IOUNITS ! +! ! +! Notice: This routine must be used to write only nontiled variables. ! +! ! +!======================================================================= +! +! Imported variable declarations. +! + integer, intent(in) :: ng, model + + integer, intent(inout) :: A(:) + + integer, intent(in), optional :: ncid, varid +! + character (len=*), intent(in) :: ncinpName, ncoutName + character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName +! +! Local variable declarations. +! + integer :: my_inpncid, my_inpgrpid, my_inpvarid, nfrid + integer :: my_outncid, my_outgrpid, my_outvarid, nfwid + integer :: status + +#if !defined PARALLEL_IO && defined DISTRIBUTE + integer, dimension(2) :: ibuffer +#endif +! + character (len=*), parameter :: MyFile = & + & __FILE__//", netcdf_copy_ivar_1d" +! +!----------------------------------------------------------------------- +! Copy 1D integer array from input to output NetCDF files. +!----------------------------------------------------------------------- +! +! Open input NetCDF file. +! + CALL netcdf_open (ng, model, TRIM(ncinpName), 0, my_inpncid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Read in variable from input NetCDF file. +! + IF (InpThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_inpncid, TRIM(GrpName), my_inpgrpid) + nfrid=my_inpgrpid + ELSE + nfrid=my_inpncid + END IF + status=nf90_inq_varid(nfrid, TRIM(myVarName), my_inpvarid) + IF (status.eq.nf90_noerr) THEN + status=nf90_get_var(nfrid, my_inpvarid, A) + IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN + WRITE (stdout,10) TRIM(myVarName), TRIM(ncinpName), & + & TRIM(SourceFile), nf90_strerror(status) + exit_flag=2 + ioerror=status + END IF + END IF + END IF +! +! Write out variable into output NetCDF file. +! + IF (InpThread) THEN + IF (.not.PRESENT(ncid)) THEN + CALL netcdf_open (ng, model, TRIM(ncoutname), 1, my_outncid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + ELSE + my_outncid=ncid + END IF +! + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_outncid, TRIM(GrpName), my_outgrpid) + nfwid=my_outgrpid + ELSE + nfwid=my_outncid + END IF +! + IF (.not.PRESENT(varid)) THEN + status=nf90_inq_varid(nfwid, TRIM(myVarName), my_outvarid) + IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN + WRITE (stdout,10) TRIM(myVarName), TRIM(ncoutname), & + & TRIM(SourceFile), nf90_strerror(status) + exit_flag=3 + ioerror=status + END IF + ELSE + my_outvarid=varid + END IF +! + IF (exit_flag.eq.NoError) THEN + status=nf90_put_var(nfwid, my_outvarid, A) + IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN + WRITE (stdout,20) TRIM(myVarName), TRIM(ncoutname), & + & TRIM(SourceFile), nf90_strerror(status) + exit_flag=3 + ioerror=status + END IF + END IF + END IF + +#if !defined PARALLEL_IO && defined DISTRIBUTE +! +! Broadcast error flags to all processors in the group. +! + ibuffer(1)=exit_flag + ibuffer(2)=ioerror + CALL mp_bcasti (ng, model, ibuffer) + exit_flag=ibuffer(1) + ioerror=ibuffer(2) +#endif +! +! Close files. +! + CALL netcdf_close (ng, model, my_inpncid, ncinpName, .FALSE.) + IF (.not.PRESENT(ncid)) THEN + CALL netcdf_close (ng, model, my_outncid, ncoutname, .FALSE.) + END IF +! + 10 FORMAT (/,' NETCDF_COPY_IVAR_1D - error while inquiring ID for ', & + & 'variable:',2x,a,/,23x,'in input file:',2x,a,/,22x, & + & 'call from:',2x,a,/,23x,a) + 20 FORMAT (/,' NETCDF_COPY_IVAR_1D - error while writing variable:', & + & 2x,a,/,22x,'in input file:',2x,a,/,23x,'call from:',2x,a, & + & /,23x,a) +! + RETURN + END SUBROUTINE netcdf_copy_ivar_1d ! SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & - & SearchVar, VarID, nVarDim, nVarAtt) + & GrpName, SearchVar, VarID, nVarDim, & + & nVarAtt) ! !======================================================================= ! ! @@ -1384,6 +1985,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & ! ncname NetCDF file name (string) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! myVarName Requested variable name (string, OPTIONAL) ! +! GrpName Group name (string, OPTIONAL) ! ! SearchVar Switch used when searching a variable over ! ! multiple NetCDF files (logical, OPTIONAL) ! ! ! @@ -1431,6 +2033,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in), optional :: myVarName + character (len=*), intent(in), optional :: GrpName ! logical, intent(out), optional :: SearchVar ! @@ -1445,7 +2048,8 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & logical :: foundit, WriteError ! integer :: i, j, status - integer :: att_id, my_Alen, my_Atype, my_id, my_ncid + integer :: att_id, my_Alen, my_Atype, my_id + integer :: my_ncid, my_grpid, nfid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(5) :: ibuffer @@ -1508,7 +2112,13 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & ! Inquire NetCDF file. ! IF (InpThread) THEN - status=nf90_inquire(my_ncid, n_dim, n_var, n_gatt, rec_id) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inquire(nfid, n_dim, n_var, n_gatt, rec_id) IF ((status.eq.nf90_noerr).and.(n_var.le.Mvars)) THEN #if !defined PARALLEL_IO && defined DISTRIBUTE ibuffer(1)=n_dim @@ -1518,6 +2128,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & #endif ! ! Inquire about global dimensions: names, ID, and size. +! It is skiped when inquiring a Group variables since n_dim=0. ! rec_size=-1 DO i=1,n_dim @@ -1540,6 +2151,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & END DO ! ! Inquire global attribute names and their external data type. +! It is skiped when inquiring a group variables since n_gatt=0. ! DO i=1,MIN(Matts,n_gatt) att_id=i @@ -1573,13 +2185,13 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & DO i=1,n_var var_id(i)=i var_flag(i)=1 - status=nf90_inquire_variable(my_ncid, var_id(i), & + status=nf90_inquire_variable(nfid, var_id(i), & & var_name(i), var_type(i), & & var_ndim(i), var_dim(:,i), & & var_natt(i)) IF (status.eq.nf90_noerr) THEN DO j=1,MIN(NvarA,var_natt(i)) - status=nf90_inq_attname(my_ncid, var_id(i), j, & + status=nf90_inq_attname(nfid, var_id(i), j, & & var_Aname(j)) IF (status.eq.nf90_noerr) THEN IF (TRIM(var_Aname(j)).eq.'water_points'.and. & @@ -1697,7 +2309,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & ! IF (foundit.and.InpThread) THEN DO i=1,n_vdim - status=nf90_inquire_dimension(my_ncid, var_Dids(i), & + status=nf90_inquire_dimension(nfid, var_Dids(i), & & var_Dname(i), var_Dsize(i)) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,50) i, TRIM(myVarName), TRIM(ncname), & @@ -1710,16 +2322,16 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & END DO IF (status.eq.nf90_noerr) THEN DO i=1,MIN(NvarA, n_vatt) - status=nf90_inq_attname(my_ncid, my_id, i, var_Aname(i)) + status=nf90_inq_attname(nfid, my_id, i, var_Aname(i)) IF (status.eq.nf90_noerr) THEN - status=nf90_inquire_attribute(my_ncid, my_id, & + status=nf90_inquire_attribute(nfid, my_id, & & TRIM(var_Aname(i)), & & xtype = my_Atype, & & len = my_Alen) IF (status.eq.nf90_noerr) THEN IF ((my_Alen.eq.1).and. & & (my_Atype.eq.NF90_INT)) THEN - status=nf90_get_att(my_ncid, my_id, & + status=nf90_get_att(nfid, my_id, & & TRIM(var_Aname(i)), & & var_Aint(i)) IF (FoundError(status, nf90_noerr, & @@ -1736,7 +2348,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & END IF ELSE IF ((my_Alen.eq.1).and. & & (my_Atype.eq.NF90_FLOAT)) THEN - status=nf90_get_att(my_ncid, my_id, & + status=nf90_get_att(nfid, my_id, & & TRIM(var_Aname(i)), & & my_Afloat) IF (FoundError(status, nf90_noerr, & @@ -1758,7 +2370,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & #endif ELSE IF ((my_Alen.eq.1).and. & & (my_Atype.eq.NF90_DOUBLE)) THEN - status=nf90_get_att(my_ncid, my_id, & + status=nf90_get_att(nfid, my_id, & & TRIM(var_Aname(i)), & & my_Adouble) IF (FoundError(status, nf90_noerr, & @@ -1779,7 +2391,7 @@ SUBROUTINE netcdf_inq_var (ng, model, ncname, ncid, myVarName, & var_Afloat(i)=my_Adouble #endif ELSE IF (my_Atype.eq.NF90_CHAR) THEN - status=nf90_get_att(my_ncid, my_id, & + status=nf90_get_att(nfid, my_id, & & TRIM(var_Aname(i)), & & text(1:my_Alen)) IF (FoundError(status, nf90_noerr, & @@ -2519,8 +3131,8 @@ END SUBROUTINE netcdf_get_satt #ifdef SINGLE_PRECISION ! SUBROUTINE netcdf_get_fvar_0dp (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -2533,6 +3145,7 @@ SUBROUTINE netcdf_get_fvar_0dp (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -2569,6 +3182,7 @@ SUBROUTINE netcdf_get_fvar_0dp (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(dp), intent(out), optional :: min_val real(dp), intent(out), optional :: max_val @@ -2582,7 +3196,7 @@ SUBROUTINE netcdf_get_fvar_0dp (ng, model, ncname, myVarName, A, & ! # endif - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid # if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -2621,13 +3235,19 @@ SUBROUTINE netcdf_get_fvar_0dp (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, my_A, start, total) + status=nf90_get_var(nfid, varid, my_A, start, total) A=my_A(1) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -2685,8 +3305,8 @@ SUBROUTINE netcdf_get_fvar_0dp (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_0dp ! SUBROUTINE netcdf_get_fvar_1dp (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -2699,6 +3319,7 @@ SUBROUTINE netcdf_get_fvar_1dp (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -2736,6 +3357,7 @@ SUBROUTINE netcdf_get_fvar_1dp (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(dp), intent(out), optional :: min_val real(dp), intent(out), optional :: max_val @@ -2749,7 +3371,7 @@ SUBROUTINE netcdf_get_fvar_1dp (ng, model, ncname, myVarName, A, & # endif logical, dimension(3) :: foundit ! - integer :: i, my_ncid, status, varid + integer :: i, my_ncid, my_grpid, nfid, status, varid integer, dimension(1) :: Asize # if !defined PARALLEL_IO && defined DISTRIBUTE @@ -2804,12 +3426,18 @@ SUBROUTINE netcdf_get_fvar_1dp (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -2858,7 +3486,7 @@ SUBROUTINE netcdf_get_fvar_1dp (ng, model, ncname, myVarName, A, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -2925,8 +3553,8 @@ SUBROUTINE netcdf_get_fvar_1dp (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_1dp ! SUBROUTINE netcdf_get_fvar_2dp (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -2939,6 +3567,7 @@ SUBROUTINE netcdf_get_fvar_2dp (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -2977,6 +3606,7 @@ SUBROUTINE netcdf_get_fvar_2dp (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(dp), intent(out), optional :: min_val real(dp), intent(out), optional :: max_val @@ -2990,7 +3620,7 @@ SUBROUTINE netcdf_get_fvar_2dp (ng, model, ncname, myVarName, A, & # endif logical, dimension(3) :: foundit ! - integer :: i, j, my_ncid, status, varid + integer :: i, j, my_ncid, my_grpid, nfid, status, varid integer, dimension(2) :: Asize @@ -3045,12 +3675,18 @@ SUBROUTINE netcdf_get_fvar_2dp (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -3100,7 +3736,7 @@ SUBROUTINE netcdf_get_fvar_2dp (ng, model, ncname, myVarName, A, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -3173,8 +3809,8 @@ SUBROUTINE netcdf_get_fvar_2dp (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_2dp ! SUBROUTINE netcdf_get_fvar_3dp (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -3187,6 +3823,7 @@ SUBROUTINE netcdf_get_fvar_3dp (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -3222,6 +3859,7 @@ SUBROUTINE netcdf_get_fvar_3dp (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(dp), intent(out), optional :: min_val real(dp), intent(out), optional :: max_val @@ -3235,7 +3873,7 @@ SUBROUTINE netcdf_get_fvar_3dp (ng, model, ncname, myVarName, A, & # endif logical, dimension(3) :: foundit ! - integer :: i, j, k, my_ncid, status, varid + integer :: i, j, k, my_ncid, my_grpid, nfid, status, varid integer, dimension(3) :: Asize @@ -3292,12 +3930,18 @@ SUBROUTINE netcdf_get_fvar_3dp (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -3346,7 +3990,7 @@ SUBROUTINE netcdf_get_fvar_3dp (ng, model, ncname, myVarName, A, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -3428,8 +4072,8 @@ END SUBROUTINE netcdf_get_fvar_3dp #endif ! SUBROUTINE netcdf_get_fvar_0d (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -3442,6 +4086,7 @@ SUBROUTINE netcdf_get_fvar_0d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -3478,6 +4123,7 @@ SUBROUTINE netcdf_get_fvar_0d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(r8), intent(out), optional :: min_val real(r8), intent(out), optional :: max_val @@ -3490,8 +4136,7 @@ SUBROUTINE netcdf_get_fvar_0d (ng, model, ncname, myVarName, A, & logical :: DoBroadcast ! #endif - - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -3530,13 +4175,19 @@ SUBROUTINE netcdf_get_fvar_0d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, my_A, start, total) + status=nf90_get_var(nfid, varid, my_A, start, total) A=my_A(1) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -3594,8 +4245,8 @@ SUBROUTINE netcdf_get_fvar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_0d ! SUBROUTINE netcdf_get_fvar_1d (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -3608,6 +4259,7 @@ SUBROUTINE netcdf_get_fvar_1d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -3645,6 +4297,7 @@ SUBROUTINE netcdf_get_fvar_1d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(r8), intent(out), optional :: min_val real(r8), intent(out), optional :: max_val @@ -3658,7 +4311,7 @@ SUBROUTINE netcdf_get_fvar_1d (ng, model, ncname, myVarName, A, & #endif logical, dimension(3) :: foundit ! - integer :: i, my_ncid, status, varid + integer :: i, my_ncid, my_grpid, nfid, status, varid integer, dimension(1) :: Asize #if !defined PARALLEL_IO && defined DISTRIBUTE @@ -3713,12 +4366,18 @@ SUBROUTINE netcdf_get_fvar_1d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -3767,7 +4426,7 @@ SUBROUTINE netcdf_get_fvar_1d (ng, model, ncname, myVarName, A, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -3834,8 +4493,8 @@ SUBROUTINE netcdf_get_fvar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_1d ! SUBROUTINE netcdf_get_fvar_2d (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -3848,6 +4507,7 @@ SUBROUTINE netcdf_get_fvar_2d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -3886,6 +4546,7 @@ SUBROUTINE netcdf_get_fvar_2d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(r8), intent(out), optional :: min_val real(r8), intent(out), optional :: max_val @@ -3899,7 +4560,7 @@ SUBROUTINE netcdf_get_fvar_2d (ng, model, ncname, myVarName, A, & #endif logical, dimension(3) :: foundit ! - integer :: i, j, my_ncid, status, varid + integer :: i, j, my_ncid, my_grpid, nfid, status, varid integer, dimension(2) :: Asize @@ -3954,12 +4615,18 @@ SUBROUTINE netcdf_get_fvar_2d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -4009,7 +4676,7 @@ SUBROUTINE netcdf_get_fvar_2d (ng, model, ncname, myVarName, A, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -4082,8 +4749,8 @@ SUBROUTINE netcdf_get_fvar_2d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_2d ! SUBROUTINE netcdf_get_fvar_3d (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -4096,6 +4763,7 @@ SUBROUTINE netcdf_get_fvar_3d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -4131,6 +4799,7 @@ SUBROUTINE netcdf_get_fvar_3d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(r8), intent(out), optional :: min_val real(r8), intent(out), optional :: max_val @@ -4144,7 +4813,7 @@ SUBROUTINE netcdf_get_fvar_3d (ng, model, ncname, myVarName, A, & #endif logical, dimension(3) :: foundit ! - integer :: i, j, k, my_ncid, status, varid + integer :: i, j, k, my_ncid, my_grpid, nfid, status, varid integer, dimension(3) :: Asize @@ -4201,12 +4870,18 @@ SUBROUTINE netcdf_get_fvar_3d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -4255,7 +4930,7 @@ SUBROUTINE netcdf_get_fvar_3d (ng, model, ncname, myVarName, A, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -4336,8 +5011,8 @@ SUBROUTINE netcdf_get_fvar_3d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_3d ! SUBROUTINE netcdf_get_fvar_4d (ng, model, ncname, myVarName, A, & - & ncid, start, total, broadcast, & - & min_val, max_val) + & ncid, start, total, GrpName, & + & broadcast, min_val, max_val) ! !======================================================================= ! ! @@ -4350,6 +5025,7 @@ SUBROUTINE netcdf_get_fvar_4d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -4385,6 +5061,7 @@ SUBROUTINE netcdf_get_fvar_4d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(r8), intent(out), optional :: min_val real(r8), intent(out), optional :: max_val @@ -4398,7 +5075,7 @@ SUBROUTINE netcdf_get_fvar_4d (ng, model, ncname, myVarName, A, & #endif logical, dimension(3) :: foundit ! - integer :: i, j, k, l, my_ncid, status, varid + integer :: i, j, k, l, my_ncid, my_grpid, nfid, status, varid integer, dimension(4) :: Asize @@ -4457,12 +5134,18 @@ SUBROUTINE netcdf_get_fvar_4d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -4511,7 +5194,7 @@ SUBROUTINE netcdf_get_fvar_4d (ng, model, ncname, myVarName, A, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -4598,7 +5281,7 @@ SUBROUTINE netcdf_get_fvar_4d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_fvar_4d ! SUBROUTINE netcdf_get_lvar_0d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -4613,6 +5296,7 @@ SUBROUTINE netcdf_get_lvar_0d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -4641,12 +5325,13 @@ SUBROUTINE netcdf_get_lvar_0d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! logical, intent(out) :: A ! ! Local variable declarations. ! - integer :: my_ncid, my_type, status, varid + integer :: my_ncid, my_type, my_grpid, nfid, status, varid integer :: AI integer, dimension(1) :: my_AI @@ -4676,17 +5361,23 @@ SUBROUTINE netcdf_get_lvar_0d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN - status=nf90_inquire_variable(my_ncid, varid, & + status=nf90_inquire_variable(nfid, varid, & & xtype = my_type) IF (status.eq.nf90_noerr) THEN IF (my_type.eq.nf90_int) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, my_AI, start, total) + status=nf90_get_var(nfid, varid, my_AI, start, total) AI=my_AI(1) ELSE - status=nf90_get_var(my_ncid, varid, AI) + status=nf90_get_var(nfid, varid, AI) END IF IF (status.eq.nf90_noerr) THEN IF (AI.eq.0) THEN @@ -4697,9 +5388,9 @@ SUBROUTINE netcdf_get_lvar_0d (ng, model, ncname, myVarName, A, & END IF ELSE IF (my_type.eq.nf90_char) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, Achar, start, total) + status=nf90_get_var(nfid, varid, Achar, start, total) ELSE - status=nf90_get_var(my_ncid, varid, Achar) + status=nf90_get_var(nfid, varid, Achar) END IF IF (status.eq.nf90_noerr) THEN A=.FALSE. @@ -4762,7 +5453,7 @@ SUBROUTINE netcdf_get_lvar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_lvar_0d ! SUBROUTINE netcdf_get_lvar_1d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -4777,6 +5468,7 @@ SUBROUTINE netcdf_get_lvar_1d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -4806,12 +5498,13 @@ SUBROUTINE netcdf_get_lvar_1d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! logical, intent(out) :: A(:) ! ! Local variable declarations. ! - integer :: i, my_ncid, my_type, status, varid + integer :: i, my_ncid, my_type, my_grpid, nfid, status, varid integer, dimension(SIZE(A,1)) :: AI @@ -4840,16 +5533,22 @@ SUBROUTINE netcdf_get_lvar_1d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN - status=nf90_inquire_variable(my_ncid, varid, & + status=nf90_inquire_variable(nfid, varid, & & xtype = my_type) IF (status.eq.nf90_noerr) THEN IF (my_type.eq.nf90_int) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, AI, start, total) + status=nf90_get_var(nfid, varid, AI, start, total) ELSE - status=nf90_get_var(my_ncid, varid, AI) + status=nf90_get_var(nfid, varid, AI) END IF IF (status.eq.nf90_noerr) THEN DO i=1,SIZE(A,1) @@ -4862,9 +5561,9 @@ SUBROUTINE netcdf_get_lvar_1d (ng, model, ncname, myVarName, A, & END IF ELSE IF (my_type.eq.nf90_char) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, Achar, start, total) + status=nf90_get_var(nfid, varid, Achar, start, total) ELSE - status=nf90_get_var(my_ncid, varid, Achar) + status=nf90_get_var(nfid, varid, Achar) END IF IF (status.eq.nf90_noerr) THEN DO i=1,SIZE(A,1) @@ -4929,7 +5628,7 @@ SUBROUTINE netcdf_get_lvar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_lvar_1d ! SUBROUTINE netcdf_get_ivar_0d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -4942,6 +5641,7 @@ SUBROUTINE netcdf_get_ivar_0d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -4970,12 +5670,13 @@ SUBROUTINE netcdf_get_ivar_0d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! integer, intent(out) :: A ! ! Local variable declarations. ! - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid integer, dimension(1) :: my_A @@ -5002,13 +5703,19 @@ SUBROUTINE netcdf_get_ivar_0d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, my_A, start, total) + status=nf90_get_var(nfid, varid, my_A, start, total) A=my_A(1) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5055,7 +5762,7 @@ SUBROUTINE netcdf_get_ivar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_ivar_0d ! SUBROUTINE netcdf_get_ivar_1d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -5068,6 +5775,7 @@ SUBROUTINE netcdf_get_ivar_1d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -5097,12 +5805,13 @@ SUBROUTINE netcdf_get_ivar_1d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! integer, intent(out) :: A(:) ! ! Local variable declarations. ! - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -5127,12 +5836,18 @@ SUBROUTINE netcdf_get_ivar_1d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5179,7 +5894,7 @@ SUBROUTINE netcdf_get_ivar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_ivar_1d ! SUBROUTINE netcdf_get_ivar_2d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -5192,6 +5907,7 @@ SUBROUTINE netcdf_get_ivar_2d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -5222,12 +5938,13 @@ SUBROUTINE netcdf_get_ivar_2d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! integer, intent(out) :: A(:,:) ! ! Local variable declarations. ! - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -5252,12 +5969,18 @@ SUBROUTINE netcdf_get_ivar_2d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5304,7 +6027,7 @@ SUBROUTINE netcdf_get_ivar_2d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_ivar_2d ! SUBROUTINE netcdf_get_svar_0d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -5327,6 +6050,7 @@ SUBROUTINE netcdf_get_svar_0d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -5355,12 +6079,13 @@ SUBROUTINE netcdf_get_svar_0d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName character (len=*), intent(out) :: A ! ! Local variable declarations. ! - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -5387,13 +6112,19 @@ SUBROUTINE netcdf_get_svar_0d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, my_A, start, total) + status=nf90_get_var(nfid, varid, my_A, start, total) A=my_A(1) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5440,7 +6171,7 @@ SUBROUTINE netcdf_get_svar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_svar_0d ! SUBROUTINE netcdf_get_svar_1d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -5464,6 +6195,7 @@ SUBROUTINE netcdf_get_svar_1d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -5487,12 +6219,13 @@ SUBROUTINE netcdf_get_svar_1d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName character (len=*), intent(out) :: A(:) ! ! Local variable declarations. ! - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -5517,12 +6250,18 @@ SUBROUTINE netcdf_get_svar_1d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5569,7 +6308,7 @@ SUBROUTINE netcdf_get_svar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_svar_1d ! SUBROUTINE netcdf_get_svar_2d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -5593,6 +6332,7 @@ SUBROUTINE netcdf_get_svar_2d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (3D vector integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -5616,12 +6356,13 @@ SUBROUTINE netcdf_get_svar_2d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName character (len=*), intent(out) :: A(:,:) ! ! Local variable declarations. ! - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -5646,12 +6387,18 @@ SUBROUTINE netcdf_get_svar_2d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5698,7 +6445,7 @@ SUBROUTINE netcdf_get_svar_2d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_get_svar_2d ! SUBROUTINE netcdf_get_svar_3d (ng, model, ncname, myVarName, A, & - & ncid, start, total) + & ncid, start, total, GrpName) ! !======================================================================= ! ! @@ -5722,6 +6469,7 @@ SUBROUTINE netcdf_get_svar_3d (ng, model, ncname, myVarName, A, & ! model Calling model identifier (integer) ! ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (4D vector ! @@ -5745,12 +6493,13 @@ SUBROUTINE netcdf_get_svar_3d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName character (len=*), intent(out) :: A(:,:,:) ! ! Local variable declarations. ! - integer :: my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid, status, varid #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -5775,12 +6524,18 @@ SUBROUTINE netcdf_get_svar_3d (ng, model, ncname, myVarName, A, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5828,7 +6583,7 @@ END SUBROUTINE netcdf_get_svar_3d ! SUBROUTINE netcdf_get_time_0d (ng, model, ncname, myVarName, & & Rdate, A, & - & ncid, start, total, & + & GrpName, ncid, start, total, & & min_val, max_val) ! !======================================================================= @@ -5848,6 +6603,7 @@ SUBROUTINE netcdf_get_time_0d (ng, model, ncname, myVarName, & ! ncname NetCDF file name (string) ! ! myVarName Variable name (string) ! ! Rdate Reference date (real; [1] seconds, [2] days) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -5881,6 +6637,7 @@ SUBROUTINE netcdf_get_time_0d (ng, model, ncname, myVarName, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(dp), intent(in) :: Rdate(2) @@ -5897,7 +6654,8 @@ SUBROUTINE netcdf_get_time_0d (ng, model, ncname, myVarName, & logical, dimension(1) :: got_units logical, dimension(2) :: foundit ! - integer :: ind, lstr, my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid + integer :: ind, lstr, status, varid integer :: year, month, day, hour, minutes #if !defined PARALLEL_IO && defined DISTRIBUTE @@ -5933,13 +6691,19 @@ SUBROUTINE netcdf_get_time_0d (ng, model, ncname, myVarName, & ! Read in variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, my_A, start, total) + status=nf90_get_var(nfid, varid, my_A, start, total) A=my_A(1) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -5987,7 +6751,7 @@ SUBROUTINE netcdf_get_time_0d (ng, model, ncname, myVarName, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -6020,7 +6784,7 @@ SUBROUTINE netcdf_get_time_0d (ng, model, ncname, myVarName, & CALL netcdf_get_satt (ng, model, ncname, varid, UnitsAtt, & & UnitsValue, got_units, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (got_units(1)) THEN @@ -6127,7 +6891,7 @@ END SUBROUTINE netcdf_get_time_0d ! SUBROUTINE netcdf_get_time_1d (ng, model, ncname, myVarName, & & Rdate, A, & - & ncid, start, total, & + & GrpName, ncid, start, total, & & min_val, max_val) ! !======================================================================= @@ -6147,6 +6911,7 @@ SUBROUTINE netcdf_get_time_1d (ng, model, ncname, myVarName, & ! ncname NetCDF file name (string) ! ! myVarName time variable name (string) ! ! Rdate Reference date (real; [1] seconds, [2] days) ! +! GrpName Group name (string, OPTIONAL) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! ! start Starting index where the first of the data values ! ! will be read along each dimension (integer, ! @@ -6181,6 +6946,7 @@ SUBROUTINE netcdf_get_time_1d (ng, model, ncname, myVarName, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! real(dp), intent(in) :: Rdate(2) @@ -6197,7 +6963,8 @@ SUBROUTINE netcdf_get_time_1d (ng, model, ncname, myVarName, & logical, dimension(1) :: got_units logical, dimension(2) :: foundit ! - integer :: i, ind, lstr, my_ncid, status, varid + integer :: my_ncid, my_grpid, nfid + integer :: i, ind, lstr, status, varid integer :: year, month, day, hour, minutes integer, dimension(1) :: Asize @@ -6243,12 +7010,18 @@ SUBROUTINE netcdf_get_time_1d (ng, model, ncname, myVarName, & ! Read in time variable. ! IF (InpThread) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), varid) + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF + status=nf90_inq_varid(nfid, TRIM(myVarName), varid) IF (status.eq.nf90_noerr) THEN IF (PRESENT(start).and.PRESENT(total)) THEN - status=nf90_get_var(my_ncid, varid, A, start, total) + status=nf90_get_var(nfid, varid, A, start, total) ELSE - status=nf90_get_var(my_ncid, varid, A) + status=nf90_get_var(nfid, varid, A) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & @@ -6296,7 +7069,7 @@ SUBROUTINE netcdf_get_time_1d (ng, model, ncname, myVarName, & CALL netcdf_get_fatt (ng, model, ncname, varid, AttName, & & AttValue, foundit, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (.not.foundit(1)) THEN @@ -6332,7 +7105,7 @@ SUBROUTINE netcdf_get_time_1d (ng, model, ncname, myVarName, & CALL netcdf_get_satt (ng, model, ncname, varid, UnitsAtt, & & UnitsValue, got_units, & - & ncid = my_ncid) + & ncid = nfid) IF (exit_flag.eq.NoError) THEN IF (got_units(1)) THEN @@ -6450,7 +7223,8 @@ END SUBROUTINE netcdf_get_time_1d #ifdef SINGLE_PRECISION ! SUBROUTINE netcdf_put_fvar_0dp (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -6470,6 +7244,7 @@ SUBROUTINE netcdf_put_fvar_0dp (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -6493,10 +7268,11 @@ SUBROUTINE netcdf_put_fvar_0dp (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status # if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -6523,8 +7299,14 @@ SUBROUTINE netcdf_put_fvar_0dp (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -6539,10 +7321,10 @@ SUBROUTINE netcdf_put_fvar_0dp (ng, model, ncname, myVarName, A, & ! IF (exit_flag.eq.NoError) THEN IF ((start(1).eq.0).and.(total(1).eq.0)) THEN - status=nf90_put_var(my_ncid, my_varid, A) + status=nf90_put_var(nfid, my_varid, A) ELSE my_A(1)=A - status=nf90_put_var(my_ncid, my_varid, my_A, start, total) + status=nf90_put_var(nfid, my_varid, my_A, start, total) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & @@ -6581,7 +7363,8 @@ SUBROUTINE netcdf_put_fvar_0dp (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_0dp ! SUBROUTINE netcdf_put_fvar_1dp (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -6601,6 +7384,7 @@ SUBROUTINE netcdf_put_fvar_1dp (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -6624,10 +7408,11 @@ SUBROUTINE netcdf_put_fvar_1dp (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status # if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -6652,8 +7437,14 @@ SUBROUTINE netcdf_put_fvar_1dp (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -6667,7 +7458,7 @@ SUBROUTINE netcdf_put_fvar_1dp (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -6705,7 +7496,8 @@ SUBROUTINE netcdf_put_fvar_1dp (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_1dp ! SUBROUTINE netcdf_put_fvar_2dp (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -6725,6 +7517,7 @@ SUBROUTINE netcdf_put_fvar_2dp (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -6748,10 +7541,11 @@ SUBROUTINE netcdf_put_fvar_2dp (ng, model, ncname, myVarName, A, & character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status # if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -6776,8 +7570,14 @@ SUBROUTINE netcdf_put_fvar_2dp (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -6791,7 +7591,7 @@ SUBROUTINE netcdf_put_fvar_2dp (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -6829,7 +7629,8 @@ SUBROUTINE netcdf_put_fvar_2dp (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_2dp ! SUBROUTINE netcdf_put_fvar_3dp (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, GrpName, ncid, & + & varid) ! !======================================================================= ! ! @@ -6849,6 +7650,7 @@ SUBROUTINE netcdf_put_fvar_3dp (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -6872,10 +7674,11 @@ SUBROUTINE netcdf_put_fvar_3dp (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status # if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -6900,8 +7703,14 @@ SUBROUTINE netcdf_put_fvar_3dp (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -6915,7 +7724,7 @@ SUBROUTINE netcdf_put_fvar_3dp (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -6954,7 +7763,8 @@ END SUBROUTINE netcdf_put_fvar_3dp #endif ! SUBROUTINE netcdf_put_fvar_0d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -6974,6 +7784,7 @@ SUBROUTINE netcdf_put_fvar_0d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -6997,10 +7808,11 @@ SUBROUTINE netcdf_put_fvar_0d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -7027,8 +7839,14 @@ SUBROUTINE netcdf_put_fvar_0d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7043,10 +7861,10 @@ SUBROUTINE netcdf_put_fvar_0d (ng, model, ncname, myVarName, A, & ! IF (exit_flag.eq.NoError) THEN IF ((start(1).eq.0).and.(total(1).eq.0)) THEN - status=nf90_put_var(my_ncid, my_varid, A) + status=nf90_put_var(nfid, my_varid, A) ELSE my_A(1)=A - status=nf90_put_var(my_ncid, my_varid, my_A, start, total) + status=nf90_put_var(nfid, my_varid, my_A, start, total) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & @@ -7085,7 +7903,8 @@ SUBROUTINE netcdf_put_fvar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_0d ! SUBROUTINE netcdf_put_fvar_1d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7105,6 +7924,7 @@ SUBROUTINE netcdf_put_fvar_1d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -7128,10 +7948,11 @@ SUBROUTINE netcdf_put_fvar_1d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -7156,8 +7977,14 @@ SUBROUTINE netcdf_put_fvar_1d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7171,7 +7998,7 @@ SUBROUTINE netcdf_put_fvar_1d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7209,7 +8036,8 @@ SUBROUTINE netcdf_put_fvar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_1d ! SUBROUTINE netcdf_put_fvar_2d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7229,6 +8057,7 @@ SUBROUTINE netcdf_put_fvar_2d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -7252,10 +8081,11 @@ SUBROUTINE netcdf_put_fvar_2d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -7280,8 +8110,14 @@ SUBROUTINE netcdf_put_fvar_2d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7295,7 +8131,7 @@ SUBROUTINE netcdf_put_fvar_2d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7333,7 +8169,8 @@ SUBROUTINE netcdf_put_fvar_2d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_2d ! SUBROUTINE netcdf_put_fvar_3d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7353,6 +8190,7 @@ SUBROUTINE netcdf_put_fvar_3d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -7376,10 +8214,11 @@ SUBROUTINE netcdf_put_fvar_3d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -7404,8 +8243,14 @@ SUBROUTINE netcdf_put_fvar_3d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7419,7 +8264,7 @@ SUBROUTINE netcdf_put_fvar_3d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7457,7 +8302,8 @@ SUBROUTINE netcdf_put_fvar_3d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_3d ! SUBROUTINE netcdf_put_fvar_4d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7477,6 +8323,7 @@ SUBROUTINE netcdf_put_fvar_4d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -7500,10 +8347,11 @@ SUBROUTINE netcdf_put_fvar_4d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -7528,8 +8376,14 @@ SUBROUTINE netcdf_put_fvar_4d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7543,7 +8397,7 @@ SUBROUTINE netcdf_put_fvar_4d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7581,7 +8435,8 @@ SUBROUTINE netcdf_put_fvar_4d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_fvar_4d ! SUBROUTINE netcdf_put_ivar_0d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7601,6 +8456,7 @@ SUBROUTINE netcdf_put_ivar_0d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -7624,10 +8480,11 @@ SUBROUTINE netcdf_put_ivar_0d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status integer, dimension(1) :: my_A @@ -7654,8 +8511,14 @@ SUBROUTINE netcdf_put_ivar_0d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7670,10 +8533,10 @@ SUBROUTINE netcdf_put_ivar_0d (ng, model, ncname, myVarName, A, & ! IF (exit_flag.eq.NoError) THEN IF ((start(1).eq.0).and.(total(1).eq.0)) THEN - status=nf90_put_var(my_ncid, my_varid, A) + status=nf90_put_var(nfid, my_varid, A) ELSE my_A(1)=A - status=nf90_put_var(my_ncid, my_varid, my_A, start, total) + status=nf90_put_var(nfid, my_varid, my_A, start, total) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & @@ -7712,7 +8575,8 @@ SUBROUTINE netcdf_put_ivar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_ivar_0d ! SUBROUTINE netcdf_put_ivar_1d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7732,6 +8596,7 @@ SUBROUTINE netcdf_put_ivar_1d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -7755,10 +8620,11 @@ SUBROUTINE netcdf_put_ivar_1d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -7783,8 +8649,14 @@ SUBROUTINE netcdf_put_ivar_1d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7798,7 +8670,7 @@ SUBROUTINE netcdf_put_ivar_1d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7836,7 +8708,8 @@ SUBROUTINE netcdf_put_ivar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_ivar_1d ! SUBROUTINE netcdf_put_ivar_2d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7856,6 +8729,7 @@ SUBROUTINE netcdf_put_ivar_2d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -7879,10 +8753,11 @@ SUBROUTINE netcdf_put_ivar_2d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -7907,8 +8782,14 @@ SUBROUTINE netcdf_put_ivar_2d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7922,7 +8803,7 @@ SUBROUTINE netcdf_put_ivar_2d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -7960,7 +8841,8 @@ SUBROUTINE netcdf_put_ivar_2d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_ivar_2d ! SUBROUTINE netcdf_put_lvar_0d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -7983,6 +8865,7 @@ SUBROUTINE netcdf_put_lvar_0d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -8006,10 +8889,11 @@ SUBROUTINE netcdf_put_lvar_0d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status integer :: AI integer, dimension(1) :: my_AI @@ -8037,8 +8921,14 @@ SUBROUTINE netcdf_put_lvar_0d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8062,10 +8952,10 @@ SUBROUTINE netcdf_put_lvar_0d (ng, model, ncname, myVarName, A, & ! IF (exit_flag.eq.NoError) THEN IF ((start(1).eq.0).and.(total(1).eq.0)) THEN - status=nf90_put_var(my_ncid, my_varid, AI) + status=nf90_put_var(nfid, my_varid, AI) ELSE my_AI(1)=AI - status=nf90_put_var(my_ncid, my_varid, my_AI, start, total) + status=nf90_put_var(nfid, my_varid, my_AI, start, total) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & @@ -8104,7 +8994,8 @@ SUBROUTINE netcdf_put_lvar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_lvar_0d ! SUBROUTINE netcdf_put_lvar_1d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -8127,6 +9018,7 @@ SUBROUTINE netcdf_put_lvar_1d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -8150,10 +9042,11 @@ SUBROUTINE netcdf_put_lvar_1d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: i, my_ncid, my_varid, status + integer :: i, my_ncid, my_varid, my_grpid, nfid, status integer, dimension(SIZE(A,1)) :: AI @@ -8180,8 +9073,14 @@ SUBROUTINE netcdf_put_lvar_1d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8206,7 +9105,7 @@ SUBROUTINE netcdf_put_lvar_1d (ng, model, ncname, myVarName, A, & ! Write out logical data as integers. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, AI, start, total) + status=nf90_put_var(nfid, my_varid, AI, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8244,7 +9143,8 @@ SUBROUTINE netcdf_put_lvar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_lvar_1d ! SUBROUTINE netcdf_put_lvar_2d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -8267,6 +9167,7 @@ SUBROUTINE netcdf_put_lvar_2d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -8290,10 +9191,11 @@ SUBROUTINE netcdf_put_lvar_2d (ng, model, ncname, myVarName, A, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: i, j, my_ncid, my_varid, status + integer :: i, j, my_ncid, my_varid, my_grpid, nfid, status integer, dimension(SIZE(A,1),SIZE(A,2)) :: AI @@ -8320,8 +9222,14 @@ SUBROUTINE netcdf_put_lvar_2d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8348,7 +9256,7 @@ SUBROUTINE netcdf_put_lvar_2d (ng, model, ncname, myVarName, A, & ! Write out logical data as integers. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, AI, start, total) + status=nf90_put_var(nfid, my_varid, AI, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8386,7 +9294,8 @@ SUBROUTINE netcdf_put_lvar_2d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_lvar_2d ! SUBROUTINE netcdf_put_svar_0d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -8417,6 +9326,7 @@ SUBROUTINE netcdf_put_svar_0d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (1D vector integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -8437,10 +9347,11 @@ SUBROUTINE netcdf_put_svar_0d (ng, model, ncname, myVarName, A, & character (len=*), intent(in) :: A character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -8467,8 +9378,14 @@ SUBROUTINE netcdf_put_svar_0d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8483,10 +9400,10 @@ SUBROUTINE netcdf_put_svar_0d (ng, model, ncname, myVarName, A, & ! IF (exit_flag.eq.NoError) THEN IF ((start(1).eq.1).and.(total(1).eq.1)) THEN - status=nf90_put_var(my_ncid, my_varid, A) + status=nf90_put_var(nfid, my_varid, A) ELSE my_A(1)=A - status=nf90_put_var(my_ncid, my_varid, my_A, start, total) + status=nf90_put_var(nfid, my_varid, my_A, start, total) END IF IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & @@ -8525,7 +9442,8 @@ SUBROUTINE netcdf_put_svar_0d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_svar_0d ! SUBROUTINE netcdf_put_svar_1d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -8557,6 +9475,7 @@ SUBROUTINE netcdf_put_svar_1d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (2D vector integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -8578,10 +9497,11 @@ SUBROUTINE netcdf_put_svar_1d (ng, model, ncname, myVarName, A, & character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -8606,8 +9526,14 @@ SUBROUTINE netcdf_put_svar_1d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8621,7 +9547,7 @@ SUBROUTINE netcdf_put_svar_1d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8659,7 +9585,8 @@ SUBROUTINE netcdf_put_svar_1d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_svar_1d ! SUBROUTINE netcdf_put_svar_2d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -8691,6 +9618,7 @@ SUBROUTINE netcdf_put_svar_2d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (3D vector integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -8712,10 +9640,11 @@ SUBROUTINE netcdf_put_svar_2d (ng, model, ncname, myVarName, A, & character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -8740,8 +9669,14 @@ SUBROUTINE netcdf_put_svar_2d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8755,7 +9690,7 @@ SUBROUTINE netcdf_put_svar_2d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8793,7 +9728,8 @@ SUBROUTINE netcdf_put_svar_2d (ng, model, ncname, myVarName, A, & END SUBROUTINE netcdf_put_svar_2d ! SUBROUTINE netcdf_put_svar_3d (ng, model, ncname, myVarName, A, & - & start, total, ncid, varid) + & start, total, ncid, GrpName, & + & varid) ! !======================================================================= ! ! @@ -8825,6 +9761,7 @@ SUBROUTINE netcdf_put_svar_3d (ng, model, ncname, myVarName, A, & ! total Number of data values to be written along each ! ! dimension (4D vector integer) ! ! ncid NetCDF file ID (integer, OPTIONAL) ! +! GrpName NetCDF4 group name (string, OPTIONAL) ! ! varid NetCDF variable ID (integer, OPTIONAL) ! ! ! ! On Ouput: ! @@ -8846,10 +9783,11 @@ SUBROUTINE netcdf_put_svar_3d (ng, model, ncname, myVarName, A, & character (len=*), intent(in) :: ncname character (len=*), intent(in) :: myVarName + character (len=*), intent(in), optional :: GrpName ! ! Local variable declarations. ! - integer :: my_ncid, my_varid, status + integer :: my_ncid, my_varid, my_grpid, nfid, status #if !defined PARALLEL_IO && defined DISTRIBUTE integer, dimension(2) :: ibuffer @@ -8874,8 +9812,14 @@ SUBROUTINE netcdf_put_svar_3d (ng, model, ncname, myVarName, A, & ! If variable ID is not provided, inquire its value. ! IF (OutThread) THEN + IF (PRESENT(GrpName)) THEN + status=nf90_inq_ncid(my_ncid, TRIM(GrpName), my_grpid) + nfid=my_grpid + ELSE + nfid=my_ncid + END IF IF (.not.PRESENT(varid)) THEN - status=nf90_inq_varid(my_ncid, TRIM(myVarName), my_varid) + status=nf90_inq_varid(nfid, TRIM(myVarName), my_varid) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,10) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -8889,7 +9833,7 @@ SUBROUTINE netcdf_put_svar_3d (ng, model, ncname, myVarName, A, & ! Write out data. ! IF (exit_flag.eq.NoError) THEN - status=nf90_put_var(my_ncid, my_varid, A, start, total) + status=nf90_put_var(nfid, my_varid, A, start, total) IF (FoundError(status, nf90_noerr, __LINE__, MyFile)) THEN WRITE (stdout,20) TRIM(myVarName), TRIM(ncname), & & TRIM(SourceFile), nf90_strerror(status) @@ -9085,7 +10029,7 @@ SUBROUTINE netcdf_close (ng, model, ncid, ncname, Lupdate) RETURN END SUBROUTINE netcdf_close ! - SUBROUTINE netcdf_create (ng, model, ncname, ncid) + SUBROUTINE netcdf_create (ng, model, ncname, ncid, ncmode) ! !======================================================================= ! ! @@ -9098,6 +10042,7 @@ SUBROUTINE netcdf_create (ng, model, ncname, ncid) ! ng Nested grid number (integer) ! ! model Calling model identifier (integer) ! ! ncname Name of the new NetCDF file (string) ! +! ncmode Creation mode flag (integer, OPTIONAL) ! ! ! ! On Output: ! ! ! @@ -9108,7 +10053,8 @@ SUBROUTINE netcdf_create (ng, model, ncname, ncid) ! Imported variable declarations. ! integer, intent(in) :: ng, model - + integer, optional, intent(in) :: ncmode +! integer, intent(out) :: ncid ! character (len=*), intent(in) :: ncname @@ -9128,6 +10074,14 @@ SUBROUTINE netcdf_create (ng, model, ncname, ncid) ! Create requested NetCDF file. !----------------------------------------------------------------------- ! +! Set file creation mode. +! + IF (PRESENT(ncmode)) THEN + my_cmode=ncmode + ELSE + my_cmode=CMODE + END IF + #if defined PARALLEL_IO && defined DISTRIBUTE ! Create a netCDF-4/HDF5 format file. Since nf90_clobber=0, then @@ -9135,7 +10089,7 @@ SUBROUTINE netcdf_create (ng, model, ncname, ncid) ! is to overwrite an existing file on disk with the same file name. ! This is what we usually do anyway. ! - my_cmode=IOR(CMODE, nf90_mpiio) + my_cmode=IOR(my_cmode, nf90_mpiio) my_cmode=IOR(my_cmode, nf90_clobber) status=nf90_create(path = TRIM(ncname), & & cmode = my_cmode, & @@ -9161,7 +10115,7 @@ SUBROUTINE netcdf_create (ng, model, ncname, ncid) END IF END IF #else - my_cmode=IOR(nf90_clobber, CMODE) + my_cmode=IOR(nf90_clobber, my_cmode) # if defined DISTRIBUTE && !defined HDF5 && \ (defined CONCURRENT_KERNEL || defined DISJOINTED) my_cmode=IOR(my_cmode, nf90_share) diff --git a/ROMS/Modules/mod_pio_netcdf.F b/ROMS/Modules/mod_pio_netcdf.F index 5b30b0fda..291f54414 100644 --- a/ROMS/Modules/mod_pio_netcdf.F +++ b/ROMS/Modules/mod_pio_netcdf.F @@ -1930,8 +1930,8 @@ SUBROUTINE pio_netcdf_check_var (ng, model, ncname, pioFile) END SUBROUTINE pio_netcdf_check_var ! SUBROUTINE pio_netcdf_inq_var (ng, model, ncname, pioFile, & - & myVarName, SearchVar, pioVar, & - & nVarDim, nVarAtt) + & myVarName, GrpName, SearchVar, & + & pioVar, nVarDim, nVarAtt) ! !======================================================================= ! ! @@ -1950,6 +1950,7 @@ SUBROUTINE pio_netcdf_inq_var (ng, model, ncname, pioFile, & ! pioFile%fh file handler ! ! pioFile%iosystem IO system descriptor (struct) ! ! myVarName Requested variable name (string, OPTIONAL) ! +! GrpName Group name (string, OPTIONAL) ! ! SearchVar Switch used when searching a variable over ! ! multiple NetCDF files (logical, OPTIONAL) ! ! ! @@ -2003,6 +2004,7 @@ SUBROUTINE pio_netcdf_inq_var (ng, model, ncname, pioFile, & ! character (len=*), intent(in) :: ncname character (len=*), intent(in), optional :: myVarName + character (len=*), intent(in), optional :: GrpName ! TYPE (File_desc_t), intent(in), optional :: pioFile TYPE (Var_desc_t), intent(out), optional :: pioVar diff --git a/ROMS/Nonlinear/initial.F b/ROMS/Nonlinear/initial.F index de507b55d..fcf0fc8a8 100644 --- a/ROMS/Nonlinear/initial.F +++ b/ROMS/Nonlinear/initial.F @@ -63,7 +63,14 @@ SUBROUTINE initial USE set_massflux_mod, ONLY : set_massflux #endif #if defined OBSERVATIONS && !defined RBL4DVAR_FCT_SENSITIVITY +# ifdef ARCHAIC_OBS USE obs_initial_mod, ONLY : obs_initial +# endif +# ifdef MODERN_OBS + USE roms_hofx_mod, ONLY : hofx_initialize + USE roms_obs_mod, ONLY : obs_initialize + USE roms_vchange_mod, ONLY : vchange_initialize +# endif #endif #ifdef MASKING USE set_masks_mod, ONLY : set_masks @@ -486,6 +493,7 @@ SUBROUTINE initial #endif #if defined OBSERVATIONS && !defined RBL4DVAR_FCT_SENSITIVITY +# ifdef ARCHAIC_OBS ! !----------------------------------------------------------------------- ! Open observations NetCDF file and initialize various variables @@ -502,6 +510,30 @@ SUBROUTINE initial IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN END DO !$OMP BARRIER +# endif +# ifdef MODERN_OBS +! +!----------------------------------------------------------------------- +! Open IODA-type observation enhanced NetCDF-4 files with first-level +! "Groups" (MetaData, ObsError, ObsValue, PreQC). Multiple files can +! separate control vector variables, observation types, complex +! operators, and area-averaged and/or time-averaged filters. All the +! observations are read and stored in the "obs_pool" object to +! facilitate processing by the "obs_hofx" operators +!----------------------------------------------------------------------- +! +! Allocate and populate observation pool object. +! + DO ng=1,Ngrids + CALL obs_initialize (ng, iNLM, nOBSfiles(ng)) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END DO +! +! Allocate and initialize H(x) and variable change objects. +! + CALL hofx_initialize (iNLM) + CALL vchange_initialize (iNLM) +# endif #endif #if (defined ADJUST_BOUNDARY || \ diff --git a/ROMS/Nonlinear/output.F b/ROMS/Nonlinear/output.F index f3e5d5d62..13d2791bc 100644 --- a/ROMS/Nonlinear/output.F +++ b/ROMS/Nonlinear/output.F @@ -21,7 +21,7 @@ SUBROUTINE output (ng) # ifdef FLOATS USE mod_floats # endif -# if defined FOUR_DVAR || defined VERIFICATION +# if (defined FOUR_DVAR || defined VERIFICATION) && defined ARCHAIC_OBS USE mod_fourdvar # endif USE mod_iounits @@ -50,9 +50,12 @@ SUBROUTINE output (ng) # ifdef DISTRIBUTE USE distribute_mod, ONLY : mp_bcasts # endif -# ifdef OBSERVATIONS +# if defined OBSERVATIONS && defined ARCHAIC_OBS USE obs_read_mod, ONLY : obs_read USE obs_write_mod, ONLY : obs_write +# endif +# if defined OBSERVATIONS && defined MODERN_OBS + USE roms_hofx_mod, ONLY : hofx_run, iSTD # endif USE strings_mod, ONLY : FoundError # ifdef AVERAGES @@ -708,7 +711,7 @@ SUBROUTINE output (ng) # if (defined FOUR_DVAR || \ defined VERIFICATION) && \ !defined I4DVAR_ANA_SENSITIVITY -# ifdef OBSERVATIONS +# if defined OBSERVATIONS && ARCHAIC_OBS ! !----------------------------------------------------------------------- ! If appropriate, process and write model state at observation @@ -734,6 +737,20 @@ SUBROUTINE output (ng) ProcessObs=.FALSE. END IF # endif + +# ifdef MODERN_OBS +! +!----------------------------------------------------------------------- +! Execute the H(x) operator: If applicable, extract nonlinear model +! control variables at the observation locations. +# ifdef BGQC +! Extract background error at the observation location to accept or +! reject observation in terms of background error quality control. +# endif +!----------------------------------------------------------------------- +! + CALL hofx_run (ng, tile, iNLM) +# endif # endif # ifdef PROFILE ! diff --git a/ROMS/Utility/CMakeLists.txt b/ROMS/Utility/CMakeLists.txt index 0b55b894e..fc6dcc1d8 100644 --- a/ROMS/Utility/CMakeLists.txt +++ b/ROMS/Utility/CMakeLists.txt @@ -135,7 +135,10 @@ list( APPEND _files ROMS/Utility/read_vegpar.F ROMS/Utility/regrid.F ROMS/Utility/rep_matrix.F + ROMS/Utility/roms_hofx.F ROMS/Utility/roms_interp.F + ROMS/Utility/roms_obs.F + ROMS/Utility/roms_vchange.F ROMS/Utility/round.F ROMS/Utility/rpcg_lanczos.F ROMS/Utility/set_2dfld.F @@ -176,6 +179,8 @@ list( APPEND _files ROMS/Utility/tile_indices.F ROMS/Utility/time_corr.F ROMS/Utility/timers.F + ROMS/Utility/tracer_index.F + ROMS/Utility/unique.F ROMS/Utility/uv_rotate.F ROMS/Utility/uv_var_change.F ROMS/Utility/vorticity.F diff --git a/ROMS/Utility/def_mod.F b/ROMS/Utility/def_mod.F index 3d8073dfb..686535b25 100644 --- a/ROMS/Utility/def_mod.F +++ b/ROMS/Utility/def_mod.F @@ -1,6 +1,6 @@ #include "cppdefs.h" MODULE def_mod_mod -#if defined FOUR_DVAR || defined VERIFICATION +#if defined FOUR_DVAR || (defined VERIFICATION && defined ARCHAIC_OBS) ! !git $Id$ !================================================== Hernan G. Arango === diff --git a/ROMS/Utility/distribute.F b/ROMS/Utility/distribute.F index fbf727d49..c69a85b91 100644 --- a/ROMS/Utility/distribute.F +++ b/ROMS/Utility/distribute.F @@ -103,6 +103,7 @@ MODULE distribute_mod MODULE PROCEDURE mp_bcasti_0d MODULE PROCEDURE mp_bcasti_1d MODULE PROCEDURE mp_bcasti_2d + MODULE PROCEDURE mp_bcasti_3d END INTERFACE mp_bcasti ! INTERFACE mp_bcasts @@ -1294,6 +1295,99 @@ SUBROUTINE mp_bcasti_2d (ng, model, A, InpComm) ! RETURN END SUBROUTINE mp_bcasti_2d +! + SUBROUTINE mp_bcasti_3d (ng, model, A, InpComm) +! +!*********************************************************************** +! ! +! This routine broadcasts a 3D non-tiled, integer array to all ! +! processors in the communicator. It is called by all the ! +! members in the group. ! +! ! +! On Input: ! +! ! +! ng Nested grid number. ! +! model Calling model identifier. ! +! A 3D array to broadcast (integer). ! +! InpComm Communicator handle (integer, OPTIONAL). ! +! ! +! On Output: ! +! ! +! A Broadcasted 3D array. ! +! ! +!*********************************************************************** +! +! Imported variable declarations. +! + integer, intent(in) :: ng, model + + integer, intent(in), optional :: InpComm + + integer, intent(inout) :: A(:,:,:) +! +! Local variable declarations +! + integer :: Lstr, MyCOMM, MyError, Npts, Serror + integer :: Asize(3) +! + character (len=MPI_MAX_ERROR_STRING) :: string + + character (len=*), parameter :: MyFile = & + & __FILE__//", mp_bcasti_3d" + +# ifdef PROFILE +! +!----------------------------------------------------------------------- +! Turn on time clocks. +!----------------------------------------------------------------------- +! + CALL wclock_on (ng, model, 64, __LINE__, MyFile) +# endif +# ifdef MPI +! +!----------------------------------------------------------------------- +! Set distributed-memory communicator handle (context ID). +!----------------------------------------------------------------------- +! + IF (PRESENT(InpComm)) THEN + MyCOMM=InpComm + ELSE + MyCOMM=OCN_COMM_WORLD + END IF +# endif +! +!----------------------------------------------------------------------- +! Broadcast requested variable. +!----------------------------------------------------------------------- +! + Asize(1)=UBOUND(A, DIM=1) + Asize(2)=UBOUND(A, DIM=2) + Asize(3)=UBOUND(A, DIM=3) + Npts=Asize(1)*Asize(2)*Asize(3) + +# ifdef MPI + CALL mpi_bcast (A, Npts, MPI_INTEGER, MyMaster, MyCOMM, MyError) + IF (MyError.ne.MPI_SUCCESS) THEN + CALL mpi_error_string (MyError, string, Lstr, Serror) + Lstr=LEN_TRIM(string) + WRITE (stdout,10) 'MPI_BCAST', MyRank, MyError, string(1:Lstr) + 10 FORMAT (/,' MP_BCASTI_3D - error during ',a,' call, Task = ', & + & i3.3,' Error = ',i3,/,13x,a) + exit_flag=2 + RETURN + END IF +# endif +# ifdef PROFILE +! +!----------------------------------------------------------------------- +! Turn off time clocks. +!----------------------------------------------------------------------- +! + CALL wclock_off (ng, model, 64, __LINE__, MyFile) +# endif +! + RETURN + END SUBROUTINE mp_bcasti_3d ! SUBROUTINE mp_bcastl_0d (ng, model, A, InpComm) ! diff --git a/ROMS/Utility/obs_cost.F b/ROMS/Utility/obs_cost.F index 7125e32a1..de9984b5b 100644 --- a/ROMS/Utility/obs_cost.F +++ b/ROMS/Utility/obs_cost.F @@ -9,19 +9,12 @@ SUBROUTINE obs_cost (ng, model) ! See License_ROMS.md ! !======================================================================= -# ifdef WEAK_CONSTRAINT -# if defined R4DVAR || defined R4DVAR_ANA_SENSITIVITY || \ - defined TL_R4DVAR +# if defined R4DVAR || defined R4DVAR_ANA_SENSITIVITY || \ + defined TL_R4DVAR ! ! ! This routine computes the data penalty function directly in during ! ! runs of the representer model: ! ! ! -# else -! ! -! This routine computes the data penalty function directly in during ! -! runs of the nonlinear model: ! -! ! -# endif ! Jdata = transpose(H X - Xo) * O^(-1) * (H X - Xo) ! ! ! ! H : observation operator (linearized if incremental) ! diff --git a/ROMS/Utility/obs_read.F b/ROMS/Utility/obs_read.F index c8e571a95..c3141f0e2 100644 --- a/ROMS/Utility/obs_read.F +++ b/ROMS/Utility/obs_read.F @@ -1,6 +1,7 @@ #include "cppdefs.h" MODULE obs_read_mod -#if (defined FOUR_DVAR || defined VERIFICATION) && defined OBSERVATIONS +#if (defined FOUR_DVAR || defined VERIFICATION) && \ + defined OBSERVATIONS && defined ARCHAIC_OBS ! !git $Id$ !================================================== Hernan G. Arango === diff --git a/ROMS/Utility/obs_write.F b/ROMS/Utility/obs_write.F index d6d2c4b62..9c4013e7c 100644 --- a/ROMS/Utility/obs_write.F +++ b/ROMS/Utility/obs_write.F @@ -1,6 +1,7 @@ #include "cppdefs.h" MODULE obs_write_mod -#if (defined FOUR_DVAR || defined VERIFICATION) && defined OBSERVATIONS +#if (defined FOUR_DVAR || defined VERIFICATION) && \ + defined OBSERVATIONS && defined ARCHAIC ! !git $Id$ !================================================== Hernan G. Arango === diff --git a/ROMS/Utility/read_asspar.F b/ROMS/Utility/read_asspar.F index b2b14fd07..df0f01545 100644 --- a/ROMS/Utility/read_asspar.F +++ b/ROMS/Utility/read_asspar.F @@ -43,10 +43,12 @@ SUBROUTINE read_AssPar (model, inp, out, Lwrite) integer :: Mval, Npts, Nval integer :: i, ib, igrid, itrc, k, ng, status integer :: Cdim, Clen, Rdim - integer :: obs_lib + integer :: iobsfile, obs_lib integer :: Ivalue(1) integer :: Nfiles(Ngrids) + integer, allocatable :: NOBScount(:,:) + # if defined FOUR_DVAR || defined VERIFICATION || \ (defined HESSIAN_SV && defined BNORM) logical, dimension(MT) :: Ltracer @@ -82,7 +84,8 @@ SUBROUTINE read_AssPar (model, inp, out, Lwrite) ! Initialize. !----------------------------------------------------------------------- ! - igrid=1 + igrid=1 ! nested grid counter + iobsfile=1 ! multiple OBS file counter Nfiles(1:Ngrids)=0 DO i=1,LEN(label) label(i:i)=blank @@ -699,6 +702,35 @@ SUBROUTINE read_AssPar (model, inp, out, Lwrite) label='OBS - data assimilation observations' Npts=load_s1d(Nval, Cval, Cdim, line, label, igrid, & & Ngrids, Nfiles, obs_lib, OBS) + CASE ('NOBSFILES') + Npts=load_i(Nval, Rval, Ngrids, nOBSfiles) + DO ng=1,Ngrids + IF (nOBSfiles(ng).le.0) THEN + IF (Master) WRITE (out,250) 'NOBSFILES', & + & nOBSfiles(ng), & + & 'Must be equal or greater than one.' + exit_flag=4 + RETURN + END IF + END DO + allocate ( OBS2(MAXVAL(nOBSfiles),Ngrids) ) + allocate ( NOBScount(MAXVAL(nOBSfiles),Ngrids) ) + NOBScount=0 + CASE ('OBS2name') + label='OBS2 - data assimilation observations' + DO ng=1,Ngrids + IF (nOBSfiles(ng).lt.0) THEN + IF (Master) WRITE (out,260) 'nOBSfiles = ', & + & nOBSfiles, & + & 'KeyWord ''NOBSFILES'' unread or misssing from '// & + & 'input script ''s4dvar.in''.' + exit_flag=4 + RETURN + END IF + END DO + Npts=load_s2d(Nval, Cval, Cdim, line, label, iobsfile, & + & igrid, Ngrids, nOBSfiles, NOBScount, & + & nOBSfiles(1), inp_lib, OBS2) CASE ('HSSname') label='HSS - Hessian eigenvectors' Npts=load_s1d(Nval, Cval, Cdim, line, label, igrid, & @@ -1682,6 +1714,11 @@ SUBROUTINE read_AssPar (model, inp, out, Lwrite) & /,15x,a,/,15x,a) 240 FORMAT (/,' READ_ASSPAR - Illegal parameter, ', a, ' = ', 1x, i2, & & /,15x,a) + 250 FORMAT (/,' READ_PHYPAR - Invalid input parameter, ',a,i0, & + & /,15x,a) + 260 FORMAT (/,' READ_PHYPAR - Invalid dimension parameter, ',a,i0, & + & /,15x,a) + # endif RETURN diff --git a/ROMS/Utility/roms_hofx.F b/ROMS/Utility/roms_hofx.F new file mode 100644 index 000000000..7e95ea163 --- /dev/null +++ b/ROMS/Utility/roms_hofx.F @@ -0,0 +1,3714 @@ +#include "cppdefs.h" + MODULE roms_hofx_mod + +#if (defined FOUR_DVAR || defined VERIFICATION) && defined OBSERVATIONS +! +!git $Id$ +!================================================== Hernan G. Arango === +! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore ! +! Licensed under a MIT/X style license ! +! See License_ROMS.md ! +!======================================================================= +! ! +! It contains several routines to compute the H(x) operator that ! +! interpolates the observartion to the nonlinear (NLM) and linear ! +! (TLM, RPM, ADM) model locations. ! +! ! +!======================================================================= +! + USE mod_param + USE mod_parallel + USE mod_fourdvar + USE mod_grid + USE mod_iounits + USE mod_netcdf + USE mod_ocean + USE mod_scalars + USE mod_stepping +! + USE roms_obs_mod + USE roms_vchange_mod +! +# ifdef DISTRIBUTE + USE distribute_mod, ONLY : mp_aggregate2d, & + & mp_collect, & + & mp_reduce +# endif +# if defined ADJOINT && defined DISTRIBUTE + USE mp_exchange_mod, ONLY : ad_mp_exchange2d +# ifdef SOLVE3D + USE mp_exchange_mod, ONLY : ad_mp_exchange3d +# endif +# endif + USE strings_mod, ONLY : FoundError +! + implicit none +! +!----------------------------------------------------------------------- +! Observation Filter Operator Object: CLASS(obs_filter). +!----------------------------------------------------------------------- +! + TYPE, PUBLIC :: obs_filter +! +! Kernel variables lower and upper bound array dimensions, and parallel +! tile partition indices. +! + integer :: tile ! domain partition + integer :: LBi, UBi, LBj, UBj ! array bounds + integer :: Imin, Imax, Jmin, Jmax ! global bounds +! +! Application global fields required for spatial averaging operators. +! + real (r8), pointer :: area(:,:) => NULL() ! grid area + real (r8), pointer :: dx(:,:) => NULL() ! X-grid spacing + real (r8), pointer :: dy(:,:) => NULL() ! Y-grid spacing +# ifdef MASKING + real (r8), pointer :: mask(:,:) => NULL() ! land-sea mask +# endif +! +! Generic global state variables to facilitate area averaging. The +! area averaging is only supported for 2D fields (ADT/SSH, SSS, SST, +! UV_codar). +! + real (r8), allocatable :: global2d(:,:) ! 2D state variable +! + CONTAINS +! + PROCEDURE :: create => obs_filter_create + PROCEDURE :: destroy => obs_filter_destroy + + END TYPE obs_filter +! +!----------------------------------------------------------------------- +! Observation Operator H(x) Object: CLASS(obs_hofx). +!----------------------------------------------------------------------- +! + TYPE, PUBLIC :: obs_hofx +! +! Total number of aggregated observations. +! + integer :: ndatum +! +! Kernel variables lower and upper bound array dimensions, and parallel +! tile partition indices. +! + integer :: tile ! domain partition + integer :: LBi, UBi, LBj, UBj ! array bounds + integer :: IstrR, IendR, JstrR, JendR ! partition bounds +! +! Tally of processed observations. +! + integer :: ObsCount ! approved + integer :: ObsReject ! rejected +! +! H(x) operator name. +! + character (len=:), allocatable :: name +! +! Contol vector to store state variables at the aggregated observation +! locations. +! + real (r8), allocatable :: state(:) ! state vector + integer, allocatable :: ObsVetting(:) ! reject/accept flag +! +! Cost Function values per observations in the pool depot. +! + TYPE (obs_cost), allocatable :: ObsCost(:) +! +! Pointers for geometry variables. +! + real (r8), pointer :: angle(:,:) => NULL() ! curvilinear angle + real (r8), pointer :: mask(:,:) => NULL() ! land-sea mask +# ifdef SOLVE3D + real (r8), pointer :: depth(:,:,:) => NULL() ! depths (m) +# endif +! + CONTAINS +! +! Constructors and destructors. +! + PROCEDURE :: create => obs_hofx_create + PROCEDURE :: destroy => obs_hofx_destroy + +# ifdef FOUR_DVAR +! +! Data assimilation cost functtion or data penalty functional. +! + PROCEDURE :: cost_function => obs_hofx_cost_function +# endif +! +! H(x) Operators: Extract model at observation locations drivers. +! + PROCEDURE :: extract => obs_hofx_extract + PROCEDURE :: extract2d => obs_hofx_extract2d +# ifdef SOLVE3D + PROCEDURE :: extract3d => obs_hofx_extract3d +# endif +! +! H(x) operators: Interpolation without filters. +! + PROCEDURE :: interp2d => obs_hofx_interp2d +# ifdef ADJOINT + PROCEDURE :: interp2d_ad => obs_hofx_interp2d_ad +# endif +# ifdef SOLVE3D + PROCEDURE :: interp3d => obs_hofx_interp3d +# ifdef ADJOINT + PROCEDURE :: interp3d_ad => obs_hofx_interp3d_ad +# endif +# endif +! +! H(x) Operators: Spatial and/or temporal H(X) average filters. +! + PROCEDURE :: area_avg2d => obs_hofx_area_avg2d +# ifdef ADJOINT + PROCEDURE :: area_avg2d_ad => obs_hofx_area_avg2d_ad +# endif + PROCEDURE :: area_time_avg2d => obs_hofx_area_time_avg2d +# ifdef ADJOINT + PROCEDURE :: area_time_avg2d_ad => obs_hofx_area_time_avg2d_ad +# endif +! + PROCEDURE :: time_avg2d => obs_hofx_time_avg2d +# ifdef ADJOINT + PROCEDURE :: time_avg2d_ad => obs_hofx_time_avg2d_ad +# endif +# ifdef SOLVE3D + PROCEDURE :: time_avg3d => obs_hofx_time_avg3d +# ifdef ADJOINT + PROCEDURE :: time_avg3d_ad => obs_hofx_time_avg3d_ad +# endif +# endif +! +! H(x) Utility: Operations, exchanges, and writing. +! + PROCEDURE :: add => obs_hofx_add +# ifdef BGQC + PROCEDURE :: background_QC => obs_hofx_background_QC +# endif + PROCEDURE :: increment => obs_hofx_increment + PROCEDURE :: innovation => obs_hofx_innovation + PROCEDURE :: nc_write => obs_hofx_nc_write + PROCEDURE :: residual => obs_hofx_residual + PROCEDURE :: rms => obs_hofx_rms + PROCEDURE :: stats => obs_hofx_stats + PROCEDURE :: update => obs_hofx_update + PROCEDURE :: zeros => obs_hofx_zeros + + END TYPE obs_hofx +! +!----------------------------------------------------------------------- +! Module variables. +!----------------------------------------------------------------------- +! +! Background error (standard deviation) identifier. +! + integer, parameter :: iSTD = 10 +! +! H(x) operators per nested grid, [1:Ngrids]. +! + TYPE (obs_hofx), allocatable :: nlm_hofx(:) ! nonlinear +# ifdef ADJOINT + TYPE (obs_hofx), allocatable :: adm_hofx(:) ! adjoint +# endif +# ifndef VERIFICATION + TYPE (obs_hofx), allocatable :: berr_hofx(:) ! background error +# endif +# if defined TANGENT || defined TL_IOMS + TYPE (obs_hofx), allocatable :: tlm_hofx(:) ! tangent linear +# endif +! +! Geometry for area-averaged observations. +! + TYPE (obs_filter), allocatable :: geom_hofx(:) +! +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +! + PUBLIC :: hofx_initialize + PUBLIC :: hofx_run + PUBLIC :: hofx_finalize +! +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +! + CONTAINS +! +! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> +! +! It allocates and initializes the H(x) objects. +! + SUBROUTINE hofx_initialize (model) +! + integer, intent(in ) :: model ! kernel identifier +! + logical :: IsAreaAveraged + integer :: i, ng, ntotal, tile +! +! Get total observations count and area-averaged switch. +! + ntotal=obs_store%ndatum + IsAreaAveraged=.FALSE. + DO i=1,SIZE(obs_store%pool) + IF (obs_store%pool(i)%IsAreaAveraged) THEN + IsAreaAveraged=.TRUE. + EXIT + END IF + END DO +! +! If applicable, allocate and initialize global grid geometry needed +! for area-averaged Hofx operators. +! + IF (.not.allocated(geom_hofx)) THEN + allocate ( geom_hofx(Ngrids) ) + END IF +! + IF (IsAreaAveraged) THEN + DO ng=1,Ngrids + DO tile=first_tile(ng),last_tile(ng),+1 + CALL geom_hofx(ng)% create (ng, tile, model) + END DO + END DO + END IF +! +! Allocate and create nonlinear H(x) object. +! + IF (model.eq.iNLM) THEN + IF (.not.allocated(nlm_hofx)) THEN + allocate ( nlm_hofx(Ngrids) ) + END IF +# ifndef VERIFICATION + IF (.not.allocated(berr_hofx)) THEN + allocate ( berr_hofx(Ngrids) ) + END IF +# endif +! + DO ng=1,Ngrids + DO tile=first_tile(ng),last_tile(ng),+1 + CALL nlm_hofx(ng)%create (ng, tile, model, ntotal) +# ifndef VERIFICATION + CALL berr_hofx(ng)%create (ng, tile, model, ntotal) +# endif + END DO + END DO + END IF + +# if defined FOUR_DVAR && defined TLM_OBS +! +! Allocate and create tangent linear H(x) object. +! + IF ((model.eq.iTLM).or.(model.eq.iRPM)) THEN + IF (.not.allocated(nlm_hofx)) THEN + allocate ( tlm_hofx(Ngrids) ) + END IF +! + DO ng=1,Ngrids + DO tile=first_tile(ng),last_tile(ng),+1 + CALL tlm_hofx(ng)%create (ng, tile, model, ntotal) + END DO + END DO + END IF +# endif + +# if defined FOUR_DVAR && defined ADJOINT +! +! Allocate and create adjoint H^(x) object. +! + IF (model.eq.iADM) THEN + IF (.not.allocated(nlm_hofx)) THEN + allocate ( adm_hofx(Ngrids) ) + END IF +! + DO ng=1,Ngrids + DO tile=first_tile(ng),last_tile(ng),+1 + CALL adm_hofx(ng)%create (ng, tile, model, ntotal) + END DO + END DO + END IF +# endif +! + RETURN + END SUBROUTINE hofx_initialize +! +!----------------------------------------------------------------------- +! It computes the H(x) for the specified model kernel. +! + SUBROUTINE hofx_run (ng, tile, model) +! + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier +! + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_initialize" +! + SourceFile=MyFile +! +! Compute model at the observation locations. +! + SELECT CASE (model) + CASE (iNLM) ! nonlinear + CALL nlm_hofx(ng)%extract (obs_store, VarCha(ng), & + & geom_hofx(ng), ng, model) + +# ifndef VERIFICATION + CASE (iSTD) ! background error + CALL berr_hofx(ng)%extract (obs_store, VarCha(ng), & + & geom_hofx(ng), ng, model) +# endif +# if defined FOUR_DVAR && defined TLM_OBS + CASE (iTLM, iRPM) ! tangent linear + CALL tlm_hofx(ng)%extract (obs_store, VarCha(ng), & + & geom_hofx(ng), ng, model) +# endif +# if defined FOUR_DVAR && defined ADJOINT + CASE (iADM) ! adjoint + CALL adm_hofx(ng)%extract (obs_store, VarCha(ng), & + & geom_hofx(ng), ng, model) +# endif + CASE DEFAULT + IF (Master) WRITE (stdout,10) model + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END SELECT + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + + 10 FORMAT (/,' ROMS_HOFX::HOFX_RUN: illegal identifier, model = ',i0) +! + RETURN + END SUBROUTINE hofx_run +! +!----------------------------------------------------------------------- +! It finalizes the H(x) computation. +! + SUBROUTINE hofx_finalize (model) +! + integer, intent(in ) :: model ! kernel identifier +! + integer :: ng + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_finalize" +! + SourceFile=MyFile +! +! If appropiate, collect H(x) data from all tasks. Then, write out to +! output NetCDF files. +! + IF (Master) WRITE (stdout,10) KernelString(model) +! + SELECT CASE (model) + CASE (iNLM) ! nonlinear + DO ng=1,Ngrids +# ifdef DISTRIBUTE + CALL nlm_hofx(ng)%update (ng, model) +# endif + IF (wrtNLmod(ng)) THEN + IF (Nrun.eq.1) THEN + CALL nlm_hofx(ng)%nc_write (obs_store, ng, model, & +# ifdef VERIFICATION + & 'hofx') +# else + & 'hofxInitial') +# endif + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN +! + CALL nlm_hofx(ng)%nc_write (obs_store, ng, model, & + & 'ObsVetting') + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN +# ifdef FOUR_DVAR +! + CALL nlm_hofx(ng)%innovation (obs_store, ng, model) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN +# endif + END IF +# ifdef FOUR_DVAR +! + IF (outer.eq.Nouter) THEN + CALL nlm_hofx(ng)%nc_write (obs_store, ng, model, & + & 'hofxFinal') + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN +! + CALL nlm_hofx(ng)%increment (obs_store, ng, model) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN +! + CALL nlm_hofx(ng)%residual (obs_store, ng, model) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN + END IF +# endif + END IF + END DO + +# ifndef VERIFICATION + CASE (iSTD) ! background error + DO ng=1,Ngrids +# ifdef DISTRIBUTE + CALL berr_hofx(ng)%update (ng, model) +# endif + END DO +# endif + CASE DEFAULT + IF (Master) WRITE (stdout,20) model + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END SELECT + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Report observation-model statistics. +! + IF (model.eq.iNLM) THEN + DO ng=1,Ngrids + CALL nlm_hofx(ng)%stats (obs_store, ng, model) + END DO + END IF +! + 10 FORMAT (/,2x,'ROMS_HOFX - ',a,': ', & + & 'Finalizing and writing H(x)') + 20 FORMAT (/,' ROMS_HOFX::HOFX_FINALIZE: illegal identifier, ' & + & 'model = ',i0) +! + RETURN + END SUBROUTINE hofx_finalize +! +! <><><><><><><><><><><><><><><><><><><><><><><> CLASS OBS_FILTER <><><> +! +! It allocates observation filter object. +! + SUBROUTINE obs_filter_create (self, ng, tile, model) +! + CLASS (obs_filter), intent(inout) :: self ! H(x) object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier +! + real (r8) :: size2d +! +! Set tiled and global array bounds. +! + self%tile=tile +! + self%LBi=BOUNDS(ng)%LBi(tile) + self%UBi=BOUNDS(ng)%UBi(tile) + self%LBj=BOUNDS(ng)%LBj(tile) + self%UBj=BOUNDS(ng)%UBj(tile) +! + self%Imin=0 + self%Imax=Lm(ng)+1 + self%Jmin=0 + self%Jmax=Mm(ng)+1 + size2d=REAL((Lm(ng)+2)*(Mm(ng)+2),r8) +! +! Set global area, grid spacing mask required in the spatial averaging +! filter. +! +# ifdef DISTRIBUTE + IF (.not.associated(self%area)) THEN + allocate ( self%area(self%Imin:self%Imax, self%Jmin:self%Jmax) ) + self%area = 0.0_r8 + Dmem(ng)=Dmem(ng)+size2d + END IF + IF (.not.associated(self%dx)) THEN + allocate ( self%dx(self%Imin:self%Imax, self%Jmin:self%Jmax) ) + self%dx = 0.0_r8 + Dmem(ng)=Dmem(ng)+size2d + END IF + IF (.not.associated(self%dy)) THEN + allocate ( self%dy(self%Imin:self%Imax, self%Jmin:self%Jmax) ) + self%dy = 0.0_r8 + Dmem(ng)=Dmem(ng)+size2d + END IF +# ifdef MASKING + IF (.not.associated(self%mask)) THEN + allocate ( self%mask(self%Imin:self%Imax, self%Jmin:self%Jmax) ) + self%mask = 0.0_r8 + Dmem(ng)=Dmem(ng)+size2d + END IF +# endif +! + CALL mp_aggregate2d (ng, model, r2dvar, & + & self%LBi, self%UBi, self%LBj, self%UBj, & + & self%Imin, self%Imax, self%Jmin, self%Jmax, & + & GRID(ng)%omn, self%area) + CALL mp_aggregate2d (ng, model, r2dvar, & + & self%LBi, self%UBi, self%LBj, self%UBj, & + & self%Imin, self%Imax, self%Jmin, self%Jmax, & + & GRID(ng)%om_r, self%dx) + CALL mp_aggregate2d (ng, model, r2dvar, & + & self%LBi, self%UBi, self%LBj, self%UBj, & + & self%Imin, self%Imax, self%Jmin, self%Jmax, & + & GRID(ng)%on_r, self%dy) +# ifdef MASKING + CALL mp_aggregate2d (ng, model, r2dvar, & + & self%LBi, self%UBi, self%LBj, self%UBj, & + & self%Imin, self%Imax, self%Jmin, self%Jmax, & + & GRID(ng)%rmask, self%mask) +# endif +# else + self%area => GRID(ng)%omn + self%dx => GRID(ng)%om_r + self%dy => GRID(ng)%on_r +# ifdef MASKING + self%mask => GRID(ng)%rmask +# endif +# endif +! +! Allocate generic global variables. +! + IF (.not.allocated(self%global2d)) THEN + allocate ( self%global2d(self%Imin:self%Imax, & + & self%Jmin:self%Jmax) ) + self%global2d = 0.0_r8 + Dmem(ng)=Dmem(ng)+size2d + END IF +! + RETURN + END SUBROUTINE obs_filter_create +! +!----------------------------------------------------------------------- +! It destroys observation filter object. +! + SUBROUTINE obs_filter_destroy (self) +! + CLASS (obs_filter), intent(inout) :: self ! H(x) object +! +! It nullifies observation filter object arrays. +! + IF (associated(self%area)) nullify (self%area) + IF (associated(self%dx)) nullify (self%dx) + IF (associated(self%dy)) nullify (self%dy) +# ifdef MASKING + IF (associated(self%mask)) nullify (self%mask) +# endif +! + IF (allocated(self%global2d)) deallocate (self%global2d) +! + RETURN + END SUBROUTINE obs_filter_destroy +! +! <><><><><><><><><><><><><><><><><><><><><><><><> CLASS OBS_HOFX <><><> +! +! It allocates H(x) object. +! + SUBROUTINE obs_hofx_create (self, ng, tile, model, ntotal) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ntotal ! total observations +! + integer :: i, mvars, npool +! +! Initialize scalar variables. +! + self%ndatum=ntotal + self%tile=tile +! + self%LBi=BOUNDS(ng)%LBi(tile) + self%UBi=BOUNDS(ng)%UBi(tile) + self%LBj=BOUNDS(ng)%LBj(tile) + self%UBj=BOUNDS(ng)%UBj(tile) +! + self%IstrR=BOUNDS(ng)%IstrR(tile) + self%IendR=BOUNDS(ng)%IendR(tile) + self%JstrR=BOUNDS(ng)%JstrR(tile) + self%JendR=BOUNDS(ng)%JendR(tile) +! +! Allocate contol state vector. +! + IF (.not.allocated(self%state)) THEN + allocate ( self%state(ntotal) ) + Dmem(ng)=Dmem(ng)+REAL(ntotal,r8) + END IF +! +! Allocate processing flag to reject (zero) or accept (unity) +! observations. +! + IF (.not.allocated(self%ObsVetting)) THEN + allocate ( self%ObsVetting(ntotal) ) + Dmem(ng)=Dmem(ng)+REAL(ntotal,r8) + END IF +! +! Allocate cost function object. +! + npool=SIZE(obs_store%pool) + IF (.not.allocated(self%ObsCost)) THEN + allocate ( self%ObsCost(npool) ) + END IF + DO i=1,npool + mvars=obs_store%pool(i)%nvars + IF (.not.allocated(self%ObsCost(i)%value)) THEN + allocate ( self%ObsCost(i)%value(mvars) ) + self%ObsCost(i)%value=0.0_r8 + END IF + END DO +! +! Set geometry arrays pointers. +! + self%angle => GRID(ng)%angler + self%mask => GRID(ng)%rmask +# ifdef SOLVE3D + self%depth => GRID(ng)%z_r +# endif +! +! +! Initialize H(x) vector to zero to facilitate collective operatations +! in distributed-memory. +! + CALL self%zeros () +! + RETURN + END SUBROUTINE obs_hofx_create +! +!----------------------------------------------------------------------- +! It destroys H(x) operator object. +! + SUBROUTINE obs_hofx_destroy (self) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object +! +! Deallocate H(x) object variables. +! + IF (allocated(self%state)) deallocate (self%state) + IF (allocated(self%ObsVetting)) deallocate (self%ObsVetting) +! +! Nullify pointers. +! + IF (associated(self%angle)) nullify (self%angle) + IF (associated(self%mask)) nullify (self%mask) +# ifdef SOLVE3D + IF (associated(self%depth)) nullify (self%depth) +# endif +! + RETURN + END SUBROUTINE obs_hofx_destroy + +# ifndef VERIFICATION +! +! <><><><><><><><><><><><><><><><><><><><><><><><> COST FUNCTIONS <><><> +! +! It computes the data assimilation cost function according to the +! selected 4D-Var formulation methodology in ROMS: Indirect Representer +! Approach (R4D-Var), Restricted B-preconditioning Lanczos (RBL4D-Var), +! Saddle-Point (SP4D-Var), or Incremental Approach (I4D-Var). +! +! Currently, we use the dual formulation RBL4D-Var because of its +! advanced capabilities. The R4D-Var and I4D-Var algorithms are now +! deprecated and no futher developed, but are keep for historical +! purposes. + +# if defined R4DVAR || defined R4DVAR_ANA_SENSITIVITY || \ + defined TL_R4DVAR +! +! Data penalty functional: +! +! Jdata = transpose[H(X) - y] * O^(-1) * [H(X) - y] +! +! y : observations vector +! H(X) : representer model at observation locations +! O : observations error covariance +! +# elif defined RBL4DVAR || defined RBL4DVAR_ANA_SENSITIVITY || \ + defined SP4DVAR || defined TL_RBL4DVAR +! +! Observation cost function (Jo) as the misfit (square difference) +! between model and observations: +! +! Jo = 1/2 transpose[H(X) - y] * O^(-1) * [H(X) - y] +! +! y : observations vector +! H(X) : nolinear model at observation locations +! O : observations error covariance +! +# else +! +! Incremental, strong constraint observation cost function (Jo): +! +! Jo = 1/2 transpose[H(dX) - d] * O^(-1) * [H(dX) - d] +! +! d : innovation vector, [y - H(Xb)] +! H(Xb) : background at observation locations +! y : observations vector +! H(dX) : increment at observation locations +! O : observations error covariance +! +# endif + + SUBROUTINE obs_hofx_cost_function (self, obs, ng, model) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_pool), intent(inout) :: obs ! observation object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer :: nlocs, npool, mvars + integer :: iloc, iobs, ipool, ivar + real (r8) :: ObsError, ObsCost, misfit +# ifdef DATALESS_LOOPS + real (r8) :: nlmObsCost +# endif + +# if defined R4DVAR || defined R4DVAR_ANA_SENSITIVITY || \ + defined TL_R4DVAR +! +! Compute data penalty functional, Jdata. +! + IF (model.eq.iRPM) THEN + npool=SIZE(obs%pool) + DO ipool=1,npool + mvars=obs%pool(ipool)%nvars + nlocs=obs%pool(ipool)%nlocs + ObsCost=0.0_r8 + DO ivar=1,mvars + DO iloc=1,nlocs + iobs=obs%pool(ipool)%pack_mapping(iloc,ivar) + ObsError=obs%pool(ipool)%error(iloc,ivar) + IF ((self%ObsVetting(iobs).gt.0).and. & + & (ObsError.ne.0.0_r8)) THEN + misfit=self%state(iobs)- & + & obs%pool(ipool)%value(iloc,ivar) + ObsCost=ObsCost+ & + & misfit*misfit/(ObsError*ObsError) +# ifdef DATALESS_LOOPS + misfit=nlm_hofx(ng)%state(iobs)- & + nlmObsCost=nlmObsCost+ & + & misfit*misfit/(ObsError*ObsError) +# endif + END IF + END DO + self%ObsCost(ipool)%value(ivar)=ObsCost +# ifdef DATALESS_LOOPS + nlm_hofx(ng)%ObsCost(ipool)%value(ivar)=nlmObsCost +# endif + END DO + END DO + END IF + +# elif defined RBL4DVAR || defined RBL4DVAR_ANA_SENSITIVITY || \ + defined SP4DVAR || defined TL_RBL4DVAR +! +! Compute observation cost function, Jo. +! + IF (model.eq.iNLM) THEN + npool=SIZE(obs%pool) + DO ipool=1,npool + mvars=obs%pool(ipool)%nvars + nlocs=obs%pool(ipool)%nlocs + ObsCost=0.0_r8 + DO ivar=1,mvars + DO iloc=1,nlocs + iobs=obs%pool(ipool)%pack_mapping(iloc,ivar) + ObsError=obs%pool(ipool)%error(iloc,ivar) + IF ((self%ObsVetting(iobs).gt.0).and. & + & (ObsError.ne.0.0_r8)) THEN + misfit=self%state(iobs)- & + & obs%pool(ipool)%value(iloc,ivar) + ObsCost=ObsCost+ & + & misfit*misfit/(ObsError*ObsError) + END IF + END DO + self%ObsCost(ipool)%value(ivar)=ObsCost + END DO + END DO + END IF +# else +! +! Incremental, strong constraint observation cost function, Jo. +! + IF (model.eq.iNLM) THEN + npool=SIZE(obs%pool) + DO ipool=1,npool + mvars=obs%pool(ipool)%nvars + nlocs=obs%pool(ipool)%nlocs + ObsCost=0.0_r8 + DO ivar=1,mvars + DO iloc=1,nlocs + iobs=obs%pool(ipool)%pack_mapping(iloc,ivar) + ObsError=obs%pool(ipool)%error(iloc,ivar) + IF ((self%ObsVetting(iobs).gt.0).and. & + & (ObsError.ne.0.0_r8)) THEN + misfit=self%state(iobs)- & + & obs%pool(ipool)%value(iloc,ivar) + ObsCost=ObsCost+ & + & misfit*misfit/(ObsError*ObsError) + END IF + END DO + self%ObsCost(ipool)%value(ivar)=ObsCost + END DO + END DO + ELSE IF (model.eq.iTLM) THEN + npool=SIZE(obs%pool) + DO ipool=1,npool + mvars=obs%pool(ipool)%nvars + nlocs=obs%pool(ipool)%nlocs + ObsCost=0.0_r8 + DO ivar=1,mvars + DO iloc=1,nlocs + iobs=obs%pool(ipool)%pack_mapping(iloc,ivar) + ObsError=obs%pool(ipool)%error(iloc,ivar) + IF ((self%ObsVetting(iobs).gt.0).and. & + & (ObsError.ne.0.0_r8)) THEN + misfit=nlm_hofx(ng)%state(iobs)+self%state(iobs)- & + & obs%pool(ipool)%value(iloc,ivar) + ObsCost=ObsCost+ & + misfit*misfit/(ObsError*ObsError) + END IF + END DO + self%ObsCost(ipool)%value(ivar)=ObsCost + END DO + END DO + END IF +# endif +! + RETURN + END SUBROUTINE obs_hofx_cost_function +# endif + +! +! <><><><><><><><><><><><><><><><><><><><><><><><> HOFX OPERATORS <><><> +! +! It computes the H(x) operator, which interpolates model variables to +! observation locations in space and time. If adjoint model kernel, it +! computes its transpose, H^(x). Area-averaged and/or time-averaged +! operators are available. +! + SUBROUTINE obs_hofx_extract (self, obs, vchange, geom, ng, model) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_pool), intent(inout) :: obs ! observation object + CLASS (obs_VarCha), intent(inout) :: vchange ! variable change + TYPE (obs_filter), intent(inout) :: geom ! geometry object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + TYPE (obs_data), pointer :: depot + integer, allocatable :: tally(:) + integer :: i, iobs, mvars, nvars + integer :: is, ie, mc, ObsSum, ObsReject + + character (len=3), allocatable :: op_handle(:) + character (len=40) :: varname + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_extract" +! + SourceFile=MyFile +! +! If observations are available for the (time-0.5*dt) to (time+0.5*dt) +! interval or time-averaged window, it extracts model control variables +! to the observation locations. +! + IF (obs%has(ng, model)) THEN + mvars=MAXVAL(obs%pool(:)%nvars) + IF (.not.allocated(tally)) THEN + allocate ( tally(2*mvars) ) + END IF + IF (.not.allocated(op_handle)) THEN + allocate ( op_handle(2*mvars) ) + DO i=1,2*mvars + op_handle(i)='SUM' + END DO + END IF + ObsSum=0 + ObsReject=0 +! + IF (Master) WRITE(stdout,10) tdays(ng), time_code(ng) +! + DO iobs=1,SIZE(obs%pool) + IF ((obs%pool(iobs)%NstrObs.gt.0).and. & + & (obs%pool(iobs)%NendObs.gt.0)) THEN + nvars=obs%pool(iobs)%nvars + tally=0 +! + SELECT CASE (obs%pool(iobs)%name) + CASE ('ADT', 'SSH') + CALL obs_pool_get (obs, obs%pool(iobs)%name, depot) + CALL self%extract2d (depot, vchange, geom, ng, model, & + & tally, obs%pool(iobs)%name) +# ifdef SOLVE3D + CASE ('SSS', 'SST', 'uv_codar') + CALL obs_pool_get (obs, obs%pool(iobs)%name, depot) + CALL self%extract2d (depot, vchange, geom, ng, model, & + & tally, obs%pool(iobs)%name) + CASE ('salt', 'temp') + CALL obs_pool_get (obs, obs%pool(iobs)%name, depot) + CALL self%extract3d (depot, vchange, ng, model, & + & tally, obs%pool(iobs)%name) +# endif + CASE DEFAULT + IF (Master) WRITE (stdout,20) obs%pool(iobs)%name, iobs + exit_flag=5 + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN + END SELECT +! +! Store processing: tally(1,nvars)=Count and tally(2,nvars)=Reject. +! To facilitate procesing the tally is a remapped vector. +! If time-averaged observations, add all the observations at the +! beggining into the self%ObsCount to avoid repetitive time sum. +! +# ifdef DISTRIBUTE + CALL mp_reduce (ng, model, 2*mvars, tally, op_handle) +# endif + is=obs%pool(iobs)%NstrObs + ie=obs%pool(iobs)%NendObs + DO i=1,nvars + mc=1+(i-1)*2 + IF (obs%pool(iobs)%IsTimeAveraged) THEN + IF (iic(ng).eq.ntstart(ng)) THEN + self%ObsCount=self%ObsCount+(ie-is+1) + ObsSum=ObsSum+(ie-is+1) + END IF + ELSE + self%ObsCount=self%ObsCount+tally(mc) + END IF + self%ObsReject=self%ObsReject+tally(mc+1) + END DO +! +! Report. +! + IF (Master) THEN + DO i=1,nvars + mc=1+(i-1)*2 + IF (obs%pool(iobs)%IsAreaAveraged.and. & + & obs%pool(iobs)%IsTimeAveraged) THEN + varname=TRIM(obs%pool(iobs)%vname(i)) // & + & ' (AreaTimeAvg)' + ELSE IF (obs%pool(iobs)%IsAreaAveraged) THEN + varname=TRIM(obs%pool(iobs)%vname(i)) // & + & ' (AreaAvg)' + ELSE IF (obs%pool(iobs)%IsTimeAveraged) THEN + varname=TRIM(obs%pool(iobs)%vname(i)) // & + & ' (TimeAvg)' + ELSE + varname=TRIM(obs%pool(iobs)%vname(i)) + END IF + WRITE (stdout,30) TRIM(varname), & + & is, ie, tally(mc), tally(mc+1) + IF (.not.obs%pool(iobs)%IsTimeAveraged) THEN + ObsSum=ObsSum+tally(mc) + ObsReject=ObsReject+tally(mc+1) + END IF + END DO + END IF + END IF + END DO + IF (Master) WRITE (stdout,40) ObsSum, ObsReject, & + & self%ObsCount, self%ObsReject +! +! Deallocate local arrays. +! + IF (allocated(tally)) deallocate (tally) + IF (allocated(op_handle)) deallocate (op_handle) + END IF +! + 10 FORMAT (/,' Number of State Observations Processed:',2x, & + & 'ObsTime = ',f12.4,',',t68,a,/,/, & + & 3x,'Variable',15x,'IstrObs',4x,'IendObs',6x,'Count', & + & 3x,'Rejected',/) + 20 FORMAT (/,' ROMS_HOFX::extract: Cannot find name = ',a,2x, & + & 'in obs%pool(',i0,').') + 30 FORMAT (3x,a,t23,4(1x,i10)) + 40 FORMAT (/,3x,'Total',t45,2(1x,i10), & + & /,3x,'Obs Tally',t45,2(1x,i10),/) +! + RETURN + END SUBROUTINE obs_hofx_extract +! +!----------------------------------------------------------------------- +! It computes 2D control variables H(x) operator. If adjoint kernel, +! model=iADM, it computes the transport operator, H^(x). Area-averaged +! and/or time-averaged operators are available. +! + SUBROUTINE obs_hofx_extract2d (self, obs, vchange, geom, & + & ng, model, tally, name) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(inout) :: obs ! observation depot + CLASS (obs_VarCha), intent(inout) :: vchange ! variable change + TYPE (obs_filter), intent(inout) :: geom ! geometry object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(inout) :: tally(:) ! obs count/reject + character (len=*), intent(in ) :: name ! obs pool name +! + logical :: IsAreaTimeAveraged + logical :: IsAreaAveraged + logical :: IsTimeAveraged + integer :: LBi, UBi, LBj, UBj + integer :: ivar, tile +# ifdef SOLVE3D + integer :: itrc +# endif +! + real (r8), pointer :: field(:,:) => NULL() + + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_extract2d" +! + SourceFile=MyFile +! +! Initialize. +! + tile=self%tile + LBi=self%LBi + UBi=self%UBi + LBj=self%LBj + UBj=self%UBj +! +! Compute 2D H(x) operator. +! + VAR_LOOP : DO ivar=1,obs%nvars +! +! Get pointer (vchange%field2d) of the state variable associated with +! the observations. If necessary apply the required variable changes. +! + CALL vchange%apply2d (ng, tile, model, obs%vname(ivar)) +! +! Set switch for filters. +! + IsAreaTimeAveraged = obs%IsAreaAveraged.and. & + & obs%IsTimeAveraged + IsAreaAveraged = .not.obs%IsTimeAveraged.and. & + & obs%IsAreaAveraged + IsTimeAveraged = .not.obs%IsAreaAveraged.and. & + & obs%IsTimeAveraged +! +! Compute 2D control variable H(x) operator. +! + IF (model.ne.iADM) THEN + IF (IsAreaTimeAveraged) THEN + CALL self%area_time_avg2d (obs, geom, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + ELSE IF (IsAreaAveraged) THEN + CALL self%area_avg2d (obs, geom, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + ELSE IF (IsTimeAveraged) THEN + CALL self%time_avg2d (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + ELSE + CALL self%interp2d (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + END IF +# ifdef ADJOINT + ELSE IF (model.eq.iADM) THEN ! transpose, H^(x) + IF (IsAreaTimeAveraged) THEN + CALL self%area_time_avg2d_ad (obs, geom, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + + ELSE IF (IsAreaAveraged) THEN + CALL self%area_avg2d_ad (obs, geom, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + ELSE IF (IsTimeAveraged) THEN + CALL self%time_avg2d_ad (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + ELSE + CALL self%interp2d_ad (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field2d) + END IF +! +! Adjoint of variables changes, if any. +! + CALL vchange%apply2d_ad (ng, tile, model, obs%vname(ivar)) +# endif + END IF + END DO VAR_LOOP +! + RETURN + END SUBROUTINE obs_hofx_extract2d + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! It computes 3D control variables H(x) operator. If adjoint kernel, +! model=iADM, it computes the transport operator, H^(x). Area-averaged +! and/or time-averaged operators are available. +! + SUBROUTINE obs_hofx_extract3d (self, obs, vchange, & + & ng, model, tally, name) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(inout) :: obs ! observation depot + CLASS (obs_VarCha), intent(inout) :: vchange ! variable change + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(inout) :: tally(:) ! obs count/reject + character (len=*), intent(in ) :: name ! obs pool name +! + logical :: IsTimeAveraged + integer :: LBi, UBi, LBj, UBj, tile + integer :: iTstr, iTend + integer :: itrc, ivar +! + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_extract3d" +! + SourceFile=MyFile +! +! Initialize. +! + tile=self%tile + LBi=self%LBi + UBi=self%UBi + LBj=self%LBj + UBj=self%UBj +! +! Compute the 3D H(x) operator. +! + VAR_LOOP : DO ivar=1,obs%nvars +! +! Get pointer (vchange%field3d) of the state variable associated with +! the observations. If necessary apply the required variable changes. +! + CALL vchange%apply3d (ng, tile, model, obs%vname(ivar)) +! +! Set switch for filters. +! + IsTimeAveraged = .not.obs%IsAreaAveraged.and. & + & obs%IsTimeAveraged +! +! Compute 3D control variable H(x) operator. +! + IF (model.ne.iADM) THEN + IF (IsTimeAveraged) THEN + CALL self%time_avg3d (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field3d) + ELSE + CALL self%interp3d (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field3d) + + END IF +# ifdef ADJOINT + ELSE IF (model.eq.iADM) THEN ! transpose, H^(x) + IF (IsTimeAveraged) THEN + CALL self%time_avg3d_ad (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field3d) + + ELSE + CALL self%interp3d_ad (obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, & + & vchange%field3d) + + END IF +! +! Adjoint of variables changes, if any. +! + CALL vchange%apply3d_ad (ng, tile, model, obs%vname(ivar)) +# endif + END IF + END DO VAR_LOOP +! + RETURN + END SUBROUTINE obs_hofx_extract3d +# endif +! +!----------------------------------------------------------------------- +! It interpolates 2D state variables at the observation locations. +! Observations are assumed to be at RHO-points (A-grid). The staggering +! of state variables is solely done for numerical accuracy and to +! suppress spurious modes. +! +! The interpolation weights matrix, Hmat(1:4), is as follows: +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_interp2d (self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, field) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(in ) :: field(LBi:,LBj:) +! + integer :: i, ic, iobs, mc + integer :: i1, i2, j1, j2 + real (r8) :: p1, p2, q1, q2, wsum + real (r8), dimension(4) :: Hmat +! +! Interpolate 2D model state variable at the observation locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + Hmat(1)=p1*q1 + Hmat(2)=p2*q1 + Hmat(3)=p2*q2 + Hmat(4)=p1*q2 +# ifdef MASKING + Hmat(1)=Hmat(1)*self%mask(i1,j1) + Hmat(2)=Hmat(2)*self%mask(i2,j1) + Hmat(3)=Hmat(3)*self%mask(i2,j2) + Hmat(4)=Hmat(4)*self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,4 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,4 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif + self%state(iobs)=Hmat(1)*field(i1,j1)+ & + & Hmat(2)*field(i2,j1)+ & + & Hmat(3)*field(i2,j2)+ & + & Hmat(4)*field(i1,j2) +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + self%obsVetting(iobs)=1 + ELSE + self%obsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + self%ObsVetting(iobs)=1 +# endif + END IF + END DO +! + RETURN + END SUBROUTINE obs_hofx_interp2d + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! It interpolates 3D state variables at the observation locations. +! Observations are assumed to be at RHO-points (A-grid). The staggering +! of state variables is solely done for numerical accuracy and to +! suppress spurious modes. +! +! The interpolation weights matrix, Hmat(1:8), is as follows: +! +! 8______________7 +! /. /| (i2,j2,k2) +! / . / | +! 5/_____________/6 | +! | . | | +! | . *(p,q,r) | | Grid Cell +! | 4...........|..|3 +! | . | / +! |. | / +! (i1,j1,k1) |_____________|/ +! 1 2 +! + SUBROUTINE obs_hofx_interp3d (self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, field) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(inout) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(in ) :: field(LBi:,LBj:,:) +! + integer :: i, ic, iobs, k, mc + integer :: i1, i2, j1, j2, k1, k2 + real (r8) :: p1, p2, q1, q2, r1, r2 + real (r8) :: w11, w12, w21, w22, wsum + real (r8) :: Zbot, Ztop, dz + real (r8), dimension(8) :: Hmat +! +! Interpolate 3D model state variable at the observation locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + w11=p1*q1 + w21=p2*q1 + w22=p2*q2 + w12=p1*q2 + IF (obs%Zgrid(i).gt.0.0_r8) THEN + k1=MAX(1,INT(obs%Zgrid(i))) ! Positions in fractional + k2=MIN(INT(obs%Zgrid(i))+1,N(ng)) ! levels + r2=REAL(k2-k1,r8)*(obs%Zgrid(i)-REAL(k1,r8)) + r1=1.0_r8-r2 + ELSE + Ztop=self%depth(i1,j1,N(ng)) + Zbot=self%depth(i1,j1,1 ) + IF (obs%Zgrid(i).ge.Ztop) THEN + k1=N(ng) ! If shallower, assign to + k2=N(ng) ! top grid cell. The + r1=1.0_r8 ! observation is located + r2=0.0_r8 ! on the upper cell half + obs%Zgrid(i)=REAL(N(ng),r8) ! above its middle depth. + ELSE IF (Zbot.ge.obs%Zgrid(i)) THEN + r1=0.0_r8 ! If deeper, ignore. + r2=0.0_r8 + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + ELSE + DO k=N(ng),2,-1 ! Otherwise, interpolate + Ztop=self%depth(i1,j1,k ) ! to fractional level + Zbot=self%depth(i1,j1,k-1) + IF ((Ztop.gt.obs%Zgrid(i)).and. & + & (obs%Zgrid(i).ge.Zbot)) THEN + k1=k-1 + k2=k + END IF + END DO + dz=self%depth(i1,j1,k2)-self%depth(i1,j1,k1) + r2=(obs%Zgrid(i)-self%depth(i1,j1,k1))/dz + r1=1.0_r8-r2 + obs%Zgrid(i)=REAL(k1,r8)+r2 ! overwrite + END IF + END IF + IF ((r1+r2).gt.0.0_r8) THEN + Hmat(1)=w11*r1 + Hmat(2)=w21*r1 + Hmat(3)=w22*r1 + Hmat(4)=w12*r1 + Hmat(5)=w11*r2 + Hmat(6)=w21*r2 + Hmat(7)=w22*r2 + Hmat(8)=w12*r2 +# ifdef MASKING + Hmat(1)=Hmat(1)*self%mask(i1,j1) + Hmat(2)=Hmat(2)*self%mask(i2,j1) + Hmat(3)=Hmat(3)*self%mask(i2,j2) + Hmat(4)=Hmat(4)*self%mask(i1,j2) + Hmat(5)=Hmat(5)*self%mask(i1,j1) + Hmat(6)=Hmat(6)*self%mask(i2,j1) + Hmat(7)=Hmat(7)*self%mask(i2,j2) + Hmat(8)=Hmat(8)*self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,8 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,8 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif + self%state(iobs)=Hmat(1)*field(i1,j1,k1)+ & + & Hmat(2)*field(i2,j1,k1)+ & + & Hmat(3)*field(i2,j2,k1)+ & + & Hmat(4)*field(i1,j2,k1)+ & + & Hmat(5)*field(i1,j1,k2)+ & + & Hmat(6)*field(i2,j1,k2)+ & + & Hmat(7)*field(i2,j2,k2)+ & + & Hmat(8)*field(i1,j2,k2) +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + self%ObsVetting(iobs)=1 + ELSE + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + self%ObsVetting(iobs)=1 +# endif +# ifndef ALLOW_BOTTOM_OBS +! +! Reject observations that lie in the lower bottom grid cell (k=1) to +! avoid clustering due shallowing of bathymetry during smoothing and +! coarse level half-thickness (-h < Zobs < self%depth(:,:,1)) in deep +! water. +! + IF ((obs%Zgrid(i).gt.0.0_r8).and. & + & (obs%Zgrid(i).le.1.0_r8)) THEN + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# endif + END IF + END IF + END DO +! + RETURN + END SUBROUTINE obs_hofx_interp3d +# endif + +# ifdef ADJOINT +! +!----------------------------------------------------------------------- +! Adjoint of interpolating 2D state variables at the observation +! locations. Observations are assumed to be at RHO-points (A-grid). +! The staggering of state variables is solely done for numerical +! accuracy and to suppress spurious modes. +! +! The interpolation weights matrix, Hmat(1:4), is as follows: +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_interp2d_ad (ad_self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, ad_field) +! + CLASS (obs_hofx), intent(inout) :: ad_self ! H^(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(inout) :: ad_field(LBi:,LBj:) +! + integer :: i, ic, iobs, mc + integer :: i1, i2, j1, j2 + real (r8) :: p1, p2, q1, q2, wsum + real (r8), dimension(4) :: Hmat +! +! Interpolate 2D model state variable at the observation locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + Hmat(1)=p1*q1 + Hmat(2)=p2*q1 + Hmat(3)=p2*q2 + Hmat(4)=p1*q2 +# ifdef MASKING + Hmat(1)=Hmat(1)*ad_self%mask(i1,j1) + Hmat(2)=Hmat(2)*ad_self%mask(i2,j1) + Hmat(3)=Hmat(3)*ad_self%mask(i2,j2) + Hmat(4)=Hmat(4)*ad_self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,4 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,4 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif +!^ self%state(iobs)=Hmat(1)*field(i1,j1)+ & +!^ & Hmat(2)*field(i2,j1)+ & +!^ & Hmat(3)*field(i2,j2)+ & +!^ & Hmat(4)*field(i1,j2) +!^ + ad_field(i1,j1)=ad_field(i1,j1)+ & + & Hmat(1)*ad_self%state(iobs) + ad_field(i2,j1)=ad_field(i2,j1)+ & + & Hmat(2)*ad_self%state(iobs) + ad_field(i2,j2)=ad_field(i2,j2)+ & + & Hmat(3)*ad_self%state(iobs) + ad_field(i1,j2)=ad_field(i1,j2)+ & + & Hmat(4)*ad_self%state(iobs) + ad_self%state(iobs)=0.0_r8 +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + ad_self%ObsVetting(iobs)=1 + ELSE + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + ad_self%ObsVetting(iobs)=1 +# endif + END IF + END DO + +# ifdef DISTRIBUTE +! +! Exchange tile data. +! + CALL ad_mp_exchange2d (ng, ad_self%tile, model, 1, & + & ad_self%LBi, ad_self%UBi, & + & ad_self%LBj, ad_self%UBj, & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & ad_field) +# endif +! + 10 FORMAT (/,' ROMS_HOFX::interp2d_ad: Cannot find name = ',a,2x, & + & 'in obs%data observation depot object.') +! + RETURN + END SUBROUTINE obs_hofx_interp2d_ad + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! It interpolates 3D state variables at the observation locations. +! Observations are assumed to be at RHO-points (A-grid). The staggering +! of state variables is solely done for numerical accuracy and to +! suppress spurious modes. +! +! The interpolation weights matrix, Hmat(1:8), is as follows: +! +! 8______________7 +! /. /| (i2,j2,k2) +! / . / | +! 5/_____________/6 | +! | . | | +! | . *(p,q,r) | | Grid Cell +! | 4...........|..|3 +! | . | / +! |. | / +! (i1,j1,k1) |_____________|/ +! 1 2 +! + SUBROUTINE obs_hofx_interp3d_ad (ad_self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, ad_field) +! + CLASS (obs_hofx), intent(inout) :: ad_self ! H^(x) object + CLASS (obs_data), intent(inout) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(inout) :: ad_field(LBi:,LBj:,:) +! + integer :: i, ic, iobs, k, mc + integer :: i1, i2, j1, j2, k1, k2 + real (r8) :: p1, p2, q1, q2, r1, r2 + real (r8) :: w11, w12, w21, w22, wsum + real (r8) :: Zbot, Ztop, dz + real (r8), dimension(8) :: Hmat +! +! Interpolate 2D model state variable at the observation locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + w11=p1*q1 + w21=p2*q1 + w22=p2*q2 + w12=p1*q2 + IF (obs%Zgrid(i).gt.0.0_r8) THEN + k1=MAX(1,INT(obs%Zgrid(i))) ! Positions in fractional + k2=MIN(k1+1,N(ng)) ! levels + r2=REAL(k2-k1,r8)*(obs%Zgrid(i)-REAL(k1,r8)) + r1=1.0_r8-r2 + ELSE + Ztop=ad_self%depth(i1,j1,N(ng)) + Zbot=ad_self%depth(i1,j1,1 ) + IF (obs%Zgrid(i).ge.Ztop) THEN + k1=N(ng) ! If shallower, assign to + k2=N(ng) ! top grid cell. The + r1=1.0_r8 ! observation is located + r2=0.0_r8 ! on the upper cell half + obs%Zgrid(i)=REAL(N(ng),r8) ! above its middle depth. + ELSE IF (Zbot.ge.obs%Zgrid(iobs)) THEN + r1=0.0_r8 ! If deeper, ignore. + r2=0.0_r8 + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + ELSE + DO k=N(ng),2,-1 ! Otherwise, interpolate + Ztop=ad_self%depth(i1,j1,k ) ! to fractional level + Zbot=ad_self%depth(i1,j1,k-1) + IF ((Ztop.gt.obs%Zgrid(i)).and. & + & (obs%Zgrid(i).ge.Zbot)) THEN + k1=k-1 + k2=k + END IF + END DO + dz=ad_self%depth(i1,j1,k2)-ad_self%depth(i1,j1,k1) + r2=(obs%Zgrid(i)-ad_self%depth(i1,j1,k1))/dz + r1=1.0_r8-r2 + obs%Zgrid(i)=REAL(k1,r8)+r2 ! overwrite + END IF + END IF + IF ((r1+r2).gt.0.0_r8) THEN + Hmat(1)=w11*r1 + Hmat(2)=w21*r1 + Hmat(3)=w22*r1 + Hmat(4)=w12*r1 + Hmat(5)=w11*r2 + Hmat(6)=w21*r2 + Hmat(7)=w22*r2 + Hmat(8)=w12*r2 +# ifdef MASKING + Hmat(1)=Hmat(1)*ad_self%mask(i1,j1) + Hmat(2)=Hmat(2)*ad_self%mask(i2,j1) + Hmat(3)=Hmat(3)*ad_self%mask(i2,j2) + Hmat(4)=Hmat(4)*ad_self%mask(i1,j2) + Hmat(5)=Hmat(5)*ad_self%mask(i1,j1) + Hmat(6)=Hmat(6)*ad_self%mask(i2,j1) + Hmat(7)=Hmat(7)*ad_self%mask(i2,j2) + Hmat(8)=Hmat(8)*ad_self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,8 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,8 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif +!^ self%state(iobs)=Hmat(1)*field(i1,j1,k1)+ & +!^ & Hmat(2)*field(i2,j1,k1)+ & +!^ & Hmat(3)*field(i2,j2,k1)+ & +!^ & Hmat(4)*field(i1,j2,k1)+ & +!^ & Hmat(5)*field(i1,j1,k2)+ & +!^ & Hmat(6)*field(i2,j1,k2)+ & +!^ & Hmat(7)*field(i2,j2,k2)+ & +!^ & Hmat(8)*field(i1,j2,k2) +!^ + ad_field(i1,j1,k1)=ad_field(i1,j1,k1)+ & + & Hmat(1)*ad_self%state(iobs) + ad_field(i2,j1,k1)=ad_field(i2,j1,k1)+ & + & Hmat(2)*ad_self%state(iobs) + ad_field(i2,j2,k1)=ad_field(i2,j2,k1)+ & + & Hmat(3)*ad_self%state(iobs) + ad_field(i1,j2,k1)=ad_field(i1,j2,k1)+ & + & Hmat(4)*ad_self%state(iobs) + ad_field(i1,j1,k2)=ad_field(i1,j1,k2)+ & + & Hmat(5)*ad_self%state(iobs) + ad_field(i2,j1,k2)=ad_field(i2,j1,k2)+ & + & Hmat(6)*ad_self%state(iobs) + ad_field(i2,j2,k2)=ad_field(i2,j2,k2)+ & + & Hmat(7)*ad_self%state(iobs) + ad_field(i1,j2,k2)=ad_field(i1,j2,k2)+ & + & Hmat(8)*ad_self%state(iobs) + ad_self%state(iobs)=0.0_r8 +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + ad_self%ObsVetting(iobs)=1 + ELSE + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + ad_self%ObsVetting(iobs)=1 +# endif + END IF + END IF + END DO + +# ifdef DISTRIBUTE +! +! Exchange tile data. +! + CALL ad_mp_exchange3d (ng, ad_self%tile, model, 1, & + & ad_self%LBi, ad_self%UBi, & + & ad_self%LBj, ad_self%UBj, & + & 1, N(ng), NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & ad_field) +# endif +! + RETURN + END SUBROUTINE obs_hofx_interp3d_ad +# endif +# endif +! +!<><><><><><><><><><><><><><><><><><><><><><><> HOFX WITH FILTERS <><><> +! +! It computes 2D state variables at the area-averaged observation +! locations. The 2D state variable is area-averaged according to the +! "spatialAverage" half-length scale, LS, specified in the IODA-type +! observation file. Area-averaged observations are assumed to be at +! RHO-points (A-grid). +! +! The state variable area-average computed below is over a square +! region of 2*LS by 2*LS. +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_area_avg2d (self, obs, geom, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, field) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + TYPE (obs_filter), intent(inout) :: geom ! geometry + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(in ) :: field(LBi:,LBj:) +! + integer :: iobs, i1, j1, m, mc, nscope + integer :: i, is, ie, j, js, je + real (r8) :: dfr, dfx, dfy, dlen + real (r8) :: area_sum, resol + real (r8) :: my_field +! + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_area_avg2d" +! + SourceFile=MyFile + +# ifdef DISTRIBUTE +! +! Gather state variable from all the tasks in the group to build a +! global array. +! + CALL mp_aggregate2d (ng, model, r2dvar, & + & geom%LBi, geom%UBi, geom%LBj, geom%UBj, & + & geom%Imin, geom%Imax, geom%Jmin, geom%Jmax, & + & field, geom%global2d) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +# endif +! +! Compute area-averaged 2D model state variable at the area_averaged +! observation locations. +! + DO m=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(m)).and. & + (obs%Xgrid(m).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(m)).and. & + & (obs%Ygrid(m).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(m,ivar) ! index mapping + i1=INT(obs%Xgrid(m)) + j1=INT(obs%Ygrid(m)) +! +! Set the area of influence in grid units using the local average grid +! resolution. +! + resol=0.5_r8*(geom%dx(i1,j1)+geom%dy(i1,j1)) + nscope=INT(obs%spatialAverage(ivar)/resol) + is=MAX(geom%Imin, i1-nscope) + ie=MIN(i1+nscope, geom%Imax) + js=MAX(geom%Jmin, j1-nscope) + je=MIN(j1+nscope, geom%Jmax) +! +! Average state variable over the area of influence. If model standard +! deviations, square their values to obtain variances. Afterwards, take +! the square root to convert back to standard deviations. +! + area_sum=0.0_r8 + self%state(iobs)=0.0_r8 + DO j=js,je + dfy=REAL(j-j1, r8) + DO i=is,ie +# ifdef MASKING + IF (geom%mask(i,j).lt.1.0_r8) CYCLE +# endif + dfx=REAL(i-i1, r8) + dfr=REAL(nscope, r8) + dlen=SQRT(dfx*dfx+dfy*dfy) + IF (dlen.le.dfr) THEN + area_sum=area_sum+geom%area(i,j) + IF (model.eq.iSTD) THEN ! sum over the square values +# ifdef DISTRIBUTE + my_field=geom%global2d(i,j)*geom%global2d(i,j) +# else + my_field=field(i,j)*field(i,j) +# endif + ELSE +# ifdef DISTRIBUTE + my_field=geom%global2d(i,j) +# else + my_field=field(i,j) +# endif + END IF + self%state(iobs)=self%state(iobs)+ & + & geom%area(i,j)*my_field + END IF + END DO + END DO +! +! Compute area-weighted average. +! + IF (area_sum.gt.0.0_r8) THEN + self%state(iobs)=self%state(iobs)/area_sum + IF (model.eq.iSTD) THEN ! take the square root + self%state(iobs)=SQRT(self%state(iobs)) + END IF + self%ObsVetting(iobs)=1 + ELSE + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF + END IF + END DO +! + 10 FORMAT (/,' ROMS_HOFX::AREA_AVG2d: Cannot find name = ',a,2x, & + & 'in obs%data observation depot object.') +! + RETURN + END SUBROUTINE obs_hofx_area_avg2d +! +!----------------------------------------------------------------------- +! It computes 2D state variables at the area-averaged and time-averaged +! observation locations. The 2D state variable is area-averaged using +! the "spatialAverage" half-length scale, LS, and then time-averaged +! over the specified period, as defined in the IODA observation file. +! Area- and time-averaged observations are assumed to be at RHO points +! (A-grid). +! +! The state variable area-average computed below is over a square +! region of 2*LS by 2*LS. +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_area_time_avg2d (self, obs, geom, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, field) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + TYPE (obs_filter), intent(inout) :: geom ! geometry object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(in ) :: field(LBi:,LBj:) +! + integer :: iobs, i1, j1, m, mc, nscope + integer :: i, is, ie, j, js, je + integer :: iTstr, iTend + real (r8) :: dfr, dfx, dfy, dlen + real (r8) :: Tsteps, area_sum, resol + real (r8) :: my_field +! + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_area_time_avg2d" +! + SourceFile=MyFile + +# ifdef DISTRIBUTE +! +! Gather state variable from all the tasks in the group to build a +! global array. +! + CALL mp_aggregate2d (ng, model, r2dvar, & + & geom%LBi, geom%UBi, geom%LBj, geom%UBj, & + & geom%Imin, geom%Imax, geom%Jmin, geom%Jmax, & + & field, geom%global2d) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +# endif +! +! Compute area-averaged 2D model state variable at the area_averaged +! observation locations. +! + DO m=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(m)).and. & + (obs%Xgrid(m).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(m)).and. & + & (obs%Ygrid(m).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(m,ivar) ! index mapping +! + i1=INT(obs%Xgrid(m)) + j1=INT(obs%Ygrid(m)) +! +! Set the area of influence in grid units using the local average grid +! resolution. +! + resol=0.5_r8*(geom%dx(i1,j1)+geom%dy(i1,j1)) + nscope=INT(obs%spatialAverage(ivar)/resol) + is=MAX(geom%Imin, i1-nscope) + ie=MIN(i1+nscope, geom%Imax) + js=MAX(geom%Jmin, j1-nscope) + je=MIN(j1+nscope, geom%Jmax) +! + iTstr=MAX(ntstart(ng), & + & INT((obs%TimeStr(m)-dstart*day2sec)/dt(ng))+1) + iTend=MIN(ntend(ng), & + & INT((obs%TimeEnd(m)-dstart*day2sec)/dt(ng))) + Tsteps=REAL(iTend-iTstr, r8) +! +! Average state variable over the area of influence and time window. +! If model standard deviations, square their values to obtain +! variances. Afterwards, take the square root to convert back to +! standard deviations. +! + IF ((iTstr.le.iic(ng)).and.(iic(ng).le.iTend)) THEN + area_sum=0.0_r8 + DO j=js,je + dfy=REAL(j-j1, r8) + DO i=is,ie +# ifdef MASKING + IF (geom%mask(i,j).lt.1.0_r8) CYCLE +# endif + dfx=REAL(i-i1, r8) + dfr=REAL(nscope, r8) + dlen=SQRT(dfx*dfx+dfy*dfy) + IF (dlen.le.dfr) THEN + area_sum=area_sum+geom%area(i,j) + IF (model.eq.iSTD) THEN ! sum over the square values +# ifdef DISTRIBUTE + my_field=geom%global2d(i,j)*geom%global2d(i,j) +# else + my_field=field(i,j)*field(i,j) +# endif + ELSE +# ifdef DISTRIBUTE + my_field=geom%global2d(i,j) +# else + my_field=field(i,j) +# endif + END IF + self%state(iobs)=self%state(iobs)+ & + & geom%area(i,j)*my_field + END IF + END DO + END DO +! +! Compute area-weighted average. +! + IF ((area_sum.gt.0.0_r8).and.(iic(ng).eq.iTend)) THEN + self%state(iobs)=self%state(iobs)/(area_sum*Tsteps) + IF (model.eq.iSTD) THEN ! take the square root + self%state(iobs)=SQRT(self%state(iobs)) + END IF + END IF + self%ObsVetting(iobs)=1 + END IF + END IF + END DO +! +! Clear/reset global array. +! + geom%global2d=0.0_r8 +! + 10 FORMAT (/,' ROMS_HOFX::AREA_TIME_AVG2D: Cannot find name = ',a, & + & 2x,'in obs%data observation depot object.') +! + RETURN + END SUBROUTINE obs_hofx_area_time_avg2d + +# ifdef ADJOINT +! +!----------------------------------------------------------------------- +! Adjoint of computing 2D state variables at the area-averaged +! observation locations. The 2D state variable is area-averaged +! according to the "spatialAverage" half-length scale, LS, specified +! in the IODA-type observation file. Area-averaged observations are +! assumed to be at RHO-points (A-grid). +! +! The state variable area-average computed below is over a square +! region of 2*LS by 2*LS. +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_area_avg2d_ad (ad_self, obs, geom, ng, & + & model, ivar, tally, & + & LBi, UBi, LBj, UBj, ad_field) +! + CLASS (obs_hofx), intent(inout) :: ad_self ! H'(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + TYPE (obs_filter), intent(inout) :: geom ! geometry object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(inout) :: ad_field(LBi:,LBj:) +! + integer :: iobs, i1, j1, m, mc, nscope + integer :: i, is, ie, j, js, je + real (r8) :: dfr, dfx, dfy, dlen + real (r8) :: area_sum, resol +! +! Clear work global 2D array to hold the adjoint of the area of +! influence data. +! + geom%global2d=0.0_r8 +! +! Compute area-averaged 2D model state variable at the area_averaged +! observation locations. +! + DO m=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(m)).and. & + (obs%Xgrid(m).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(m)).and. & + & (obs%Ygrid(m).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(m,ivar) ! index mapping +! + i1=INT(obs%Xgrid(m)) + j1=INT(obs%Ygrid(m)) +! +! Set the area of influence in grid units using the local average grid +! resolution. +! + resol=0.5_r8*(geom%dx(i1,j1)+geom%dy(i1,j1)) + nscope=INT(obs%spatialAverage(ivar)/resol) + is=MAX(geom%Imin, i1-nscope) + ie=MIN(i1+nscope, geom%Imax) + js=MAX(geom%Jmin, j1-nscope) + je=MIN(j1+nscope, geom%Jmax) +! +! Adjoint of average state variable over the area of influence. +! + area_sum=0.0_r8 ! compute area weights + DO j=js,je + dfy=REAL(j-j1, r8) + DO i=is,ie +# ifdef MASKING + IF (geom%mask(i,j).lt.1.0_r8) CYCLE +# endif + dfx=REAL(i-i1, r8) + dfr=REAL(nscope, r8) + dlen=SQRT(dfx*dfx+dfy*dfy) + IF (dlen.le.dfr) THEN + area_sum=area_sum+geom%area(i,j) + END IF + END DO + END DO +! + IF (area_sum.gt.0.0_r8) THEN +!> self%state(iobs)=ad_self%state(iobs)/area_sum +!> self%ObsVetting(iobs)=1 +!> + ad_self%state(iobs)=ad_self%state(iobs)/area_sum + ad_self%ObsVetting(iobs)=1 + ELSE +!> ad_self%ObsVetting(iobs)=0 +!> + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +! + DO j=js,je + dfy=REAL(j-j1, r8) + DO i=is,ie +# ifdef MASKING + IF (geom%mask(i,j).lt.1.0_r8) CYCLE +# endif + dfx=REAL(i-i1, r8) + dfr=REAL(nscope, r8) + dlen=SQRT(dfx*dfx+dfy*dfy) + IF (dlen.le.dfr) THEN +!> self%state(iobs)=self%state(iobs)+ & +!> & geom%area(i,j)*geom%global2d(i,j) +!> + geom%global2d(i,j)=geom%global2d(i,j)+ & + & geom%area(i,j)*ad_self%state(iobs) + END IF + END DO + END DO + ad_self%state(iobs)=0.0_r8 + END IF + END DO +! +! Add contribution to 2D state adjoint variable. +! + DO j=ad_self%JstrR,ad_self%JendR + DO i=ad_self%JstrR,ad_self%JendR + ad_field(i,j)=geom%global2d(i,j) + geom%global2d(i,j)=0.0_r8 + END DO + END DO +! + RETURN + END SUBROUTINE obs_hofx_area_avg2d_ad +! +!----------------------------------------------------------------------- +! Adjoint of computing 2D state variables at the area-averaged and +! time-averaged observation locations. The 2D state variable is +! area-averaged using the "spatialAverage" half-length scale, LS, and +! then time-averaged over the specified period, as defined in the IODA +! observation file. Area- and time-averaged observations are assumed +! to be at RHO points (A-grid). +! +! The state variable area-average computed below is over a square +! region of 2*LS by 2*LS. +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_area_time_avg2d_ad (ad_self, obs, geom, & + & ng, model, ivar, tally, & + & LBi, UBi, LBj, UBj, & + & ad_field) +! + CLASS (obs_hofx), intent(inout) :: ad_self ! H^(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + TYPE (obs_filter), intent(inout) :: geom ! geometry object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(inout) :: ad_field(LBi:,LBj:) +! + integer :: iobs, i1, j1, m, mc, nscope + integer :: i, is, ie, j, js, je + integer :: iTstr, iTend + real (r8) :: dfr, dfx, dfy, dlen + real (r8) :: Tsteps, area_sum, resol +! +! Clear work global 2D array to hold the adjoint of the area of +! influence data. +! + geom%global2d=0.0_r8 +! +! Compute area-averaged 2D model state variable at the area_averaged +! observation locations. +! + DO m=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(m)).and. & + (obs%Xgrid(m).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(m)).and. & + & (obs%Ygrid(m).lt.rYmax(ng))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(m,ivar) ! index mapping +! + i1=INT(obs%Xgrid(m)) + j1=INT(obs%Ygrid(m)) +! +! Set the area of influence in grid units using the local average grid +! resolution. +! + resol=0.5_r8*(geom%dx(i1,j1)+geom%dy(i1,j1)) + nscope=INT(obs%spatialAverage(ivar)/resol) + is=MAX(geom%Imin, i1-nscope) + ie=MIN(i1+nscope, geom%Imax) + js=MAX(geom%Jmin, j1-nscope) + je=MIN(j1+nscope, geom%Jmax) +! + iTstr=MAX(ntstart(ng), & + & INT((obs%TimeStr(m)-dstart*day2sec)/dt(ng))+1) + iTend=MIN(ntend(ng), & + & INT((obs%TimeEnd(m)-dstart*day2sec)/dt(ng))) + Tsteps=REAL(iTend-iTstr, r8) +! +! Adjoint of average state variable over the area of influence and time +! window. +! + IF ((iTstr.le.iic(ng)).and.(iic(ng).le.iTend)) THEN + area_sum=0.0_r8 ! compute area weights + DO j=js,je + dfy=REAL(j-j1, r8) + DO i=is,ie +# ifdef MASKING + IF (geom%mask(i,j).lt.1.0_r8) CYCLE +# endif + dfx=REAL(i-i1, r8) + dfr=REAL(nscope, r8) + dlen=SQRT(dfx*dfx+dfy*dfy) + IF (SQRT(dlen.le.dfr) THEN + area_sum=area_sum+geom%area(i,j) + END IF + END DO + END DO +! + IF ((area_sum.gt.0.0_r8).and.(iic(ng).eq.iTend)) THEN +!> self%state(iobs)=self%state(iobs)/(area_sum*Tsteps) +!> + ad_self%state(iobs)=ad_self%state(iobs)/(area_sum*Tsteps) + END IF + ad_self%ObsVetting(iobs)=1 +! + DO j=js,je + dfy=REAL(j-j1, r8) + DO i=is,ie +# ifdef MASKING + IF (geom%mask(i,j).lt.1.0_r8) CYCLE +# endif + dfx=REAL(i-i1, r8) + dfr=REAL(nscope, r8) + dlen=SQRT(dfx*dfx+dfy*dfy) + IF (dlen.le.dfr) THEN +!> self%state(iobs)=self%state(iobs)+ & +!> & geom%area(i,j)*geom%global2d(i,j) +!> + geom%global2d(i,j)=geom%global2d(i,j)+ & + & geom%area(i,j)*ad_self%state(iobs) + END IF + END DO + END DO + ad_self%state(iobs)=0.0_r8 + END IF + END IF + END DO +! +! Add contribution to 2D state adjoint variable. +! + DO j=ad_self%JstrR,ad_self%JendR + DO i=ad_self%JstrR,ad_self%JendR + ad_field(i,j)=geom%global2d(i,j) + geom%global2d(i,j)=0.0_r8 + END DO + END DO +! + 10 FORMAT (/,' ROMS_HOFX::AREA_TIME_AVG2D_AD: Cannot find name = ', & + & a,2x,'in obs%data observation depot object.') +! + RETURN + END SUBROUTINE obs_hofx_area_time_avg2d_ad +# endif +! +!----------------------------------------------------------------------- +! It interpolates 2D state variables at the time-averaged observation +! locations. The 2D state variable is time-averaged according to the +! starting and ending time window values specified in the IODA-type +! observation file. Time-averaged observations are assumed to be at +! RHO-points (A-grid). +! +! The interpolation weights matrix, Hmat(1:4), is as follows: +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_time_avg2d (self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, field) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(in ) :: field(LBi:,LBj:) +! + integer :: i, ic, iobs, mc + integer :: i1, i2, j1, j2 + integer :: iTstr, iTend + real (r8) :: p1, p2, q1, q2, wsum + real (r8) :: Tsteps, my_field + real (r8), dimension(4) :: Hmat +! +! Interpolate 2D model state variable at the time-averaged observation +! locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + & (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng))) THEN +! + iTstr=MAX(ntstart(ng), & + & INT((obs%TimeStr(i)-dstart*day2sec)/dt(ng))+1) + iTend=MIN(ntend(ng), & + & INT((obs%TimeEnd(i)-dstart*day2sec)/dt(ng))) + Tsteps=REAL(iTend-iTstr, r8) +! +! Spatial interpolation and time avaraging. +! + IF ((iTstr.le.iic(ng)).and.(iic(ng).le.iTend)) THEN + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + Hmat(1)=p1*q1 + Hmat(2)=p2*q1 + Hmat(3)=p2*q2 + Hmat(4)=p1*q2 +# ifdef MASKING + Hmat(1)=Hmat(1)*self%mask(i1,j1) + Hmat(2)=Hmat(2)*self%mask(i2,j1) + Hmat(3)=Hmat(3)*self%mask(i2,j2) + Hmat(4)=Hmat(4)*self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,4 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,4 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif +! +! Average resulting H(x) over the specified time window. If model +! standard deviations, square their values to obtain variances. +! Afterwards, take the square root to convert back to standard +! deviations. Probably, unnecessary since it is time independent. +! + IF (model.eq.iSTD) THEN ! use squared values + self%state(iobs)=self%state(iobs)+ & + & Hmat(1)*field(i1,j1)*field(i1,j1)+ & + & Hmat(2)*field(i2,j1)*field(i2,j1)+ & + & Hmat(3)*field(i2,j2)*field(i2,j2)+ & + & Hmat(4)*field(i1,j2)*field(i1,j2) + ELSE + self%state(iobs)=self%state(iobs)+ & + & Hmat(1)*field(i1,j1)+ & + & Hmat(2)*field(i2,j1)+ & + & Hmat(3)*field(i2,j2)+ & + & Hmat(4)*field(i1,j2) + END IF + IF (iic(ng).eq.iTend) THEN + self%state(iobs)=self%state(iobs)/Tsteps + IF (model.eq.iSTD) THEN ! take the square root + self%state(iobs)=SQRT(self%state(iobs)) + END IF + END IF +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + self%obsVetting(iobs)=1 + ELSE + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + self%ObsVetting(iobs)=1 +# endif + END IF + END IF + END DO +! + RETURN + END SUBROUTINE obs_hofx_time_avg2d + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! It interpolates 3D state variables at the time-averaged observation +! locations. The 3D state variable is time-averaged according to the +! starting and ending time window values specified in the IODA-type +! observation file. Time-averaged observations are assumed to be at +! RHO-points (A-grid). +! +! The interpolation weights matrix, Hmat(1:8), is as follows: +! +! 8______________7 +! /. /| (i2,j2,k2) +! / . / | +! 5/_____________/6 | +! | . | | +! | . *(p,q,r) | | Grid Cell +! | 4...........|..|3 +! | . | / +! |. | / +! (i1,j1,k1) |_____________|/ +! 1 2 +! + SUBROUTINE obs_hofx_time_avg3d (self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, field) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_data), intent(inout) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(in ) :: field(LBi:,LBj:,:) +! + integer :: i, ic, iobs, k, mc + integer :: i1, i2, j1, j2, k1, k2 + integer :: iTstr, iTend + real (r8) :: p1, p2, q1, q2, r1, r2 + real (r8) :: w11, w12, w21, w22, wsum + real (r8) :: Zbot, Ztop, dz + real (r8) :: Tsteps + real (r8), dimension(8) :: Hmat +! +! Interpolate 3D model state variable at the time-averaged observation +! locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng))) THEN +! + iTstr=MAX(ntstart(ng), & + & INT((obs%TimeStr(i)-dstart*day2sec)/dt(ng))+1) + iTend=MIN(ntend(ng), & + & INT((obs%TimeEnd(i)-dstart*day2sec)/dt(ng))) + Tsteps=REAL(iTend-iTstr, r8) +! +! Spatial interpolation and time avaraging. +! + IF ((iTstr.le.iic(ng)).and.(iic(ng).le.iTend)) THEN + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + w11=p1*q1 + w21=p2*q1 + w22=p2*q2 + w12=p1*q2 + IF (obs%Zgrid(i).gt.0.0_r8) THEN + k1=MAX(1,INT(obs%Zgrid(i))) ! Positions in fractional + k2=MIN(INT(obs%Zgrid(i))+1,N(ng)) ! levels + r2=REAL(k2-k1,r8)*(obs%Zgrid(i)-REAL(k1,r8)) + r1=1.0_r8-r2 + ELSE + Ztop=self%depth(i1,j1,N(ng)) + Zbot=self%depth(i1,j1,1 ) + IF (obs%Zgrid(i).ge.Ztop) THEN + k1=N(ng) ! If shallower, assign to + k2=N(ng) ! top grid cell. The + r1=1.0_r8 ! observation is located + r2=0.0_r8 ! on the upper cell half + obs%Zgrid(i)=REAL(N(ng),r8) ! above its middle depth. + ELSE IF (Zbot.ge.obs%Zgrid(i)) THEN + r1=0.0_r8 ! If deeper, ignore. + r2=0.0_r8 + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + ELSE + DO k=N(ng),2,-1 ! Otherwise, interpolate + Ztop=self%depth(i1,j1,k ) ! to fractional level + Zbot=self%depth(i1,j1,k-1) + IF ((Ztop.gt.obs%Zgrid(i)).and. & + & (obs%Zgrid(i).ge.Zbot)) THEN + k1=k-1 + k2=k + END IF + END DO + dz=self%depth(i1,j1,k2)-self%depth(i1,j1,k1) + r2=(obs%Zgrid(i)-self%depth(i1,j1,k1))/dz + r1=1.0_r8-r2 + obs%Zgrid(i)=REAL(k1,r8)+r2 ! overwrite + END IF + END IF + IF ((r1+r2).gt.0.0_r8) THEN + Hmat(1)=w11*r1 + Hmat(2)=w21*r1 + Hmat(3)=w22*r1 + Hmat(4)=w12*r1 + Hmat(5)=w11*r2 + Hmat(6)=w21*r2 + Hmat(7)=w22*r2 + Hmat(8)=w12*r2 +# ifdef MASKING + Hmat(1)=Hmat(1)*self%mask(i1,j1) + Hmat(2)=Hmat(2)*self%mask(i2,j1) + Hmat(3)=Hmat(3)*self%mask(i2,j2) + Hmat(4)=Hmat(4)*self%mask(i1,j2) + Hmat(5)=Hmat(5)*self%mask(i1,j1) + Hmat(6)=Hmat(6)*self%mask(i2,j1) + Hmat(7)=Hmat(7)*self%mask(i2,j2) + Hmat(8)=Hmat(8)*self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,8 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,8 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif +! +! Average resulting H(x) over the specified time window. If model +! standard deviations, square their values to obtain variances. +! Afterwards, take the square root to convert back to standard +! deviations. Probably, unnecessary since it is time independent. +! + IF (model.eq.iSTD) THEN ! use squared values + self%state(iobs)=self%state(iobs)+ & + & Hmat(1)*field(i1,j1,k1)* & + & field(i1,j1,k1)+ & + & Hmat(2)*field(i2,j1,k1)* & + & field(i2,j1,k1)+ & + & Hmat(3)*field(i2,j2,k1)* & + & field(i2,j2,k1)+ & + & Hmat(4)*field(i1,j2,k1)* & + & field(i1,j2,k1)+ & + & Hmat(5)*field(i1,j1,k2)* & + & field(i1,j1,k2)+ & + & Hmat(6)*field(i2,j1,k2)* & + & field(i2,j1,k2)+ & + & Hmat(7)*field(i2,j2,k2)* & + & field(i2,j2,k2)+ & + & Hmat(8)*field(i1,j2,k2)* & + & field(i1,j2,k2) + ELSE + self%state(iobs)=self%state(iobs)+ & + & Hmat(1)*field(i1,j1,k1)+ & + & Hmat(2)*field(i2,j1,k1)+ & + & Hmat(3)*field(i2,j2,k1)+ & + & Hmat(4)*field(i1,j2,k1)+ & + & Hmat(5)*field(i1,j1,k2)+ & + & Hmat(6)*field(i2,j1,k2)+ & + & Hmat(7)*field(i2,j2,k2)+ & + & Hmat(8)*field(i1,j2,k2) + END IF + IF (iic(ng).eq.iTend) THEN + self%state(iobs)=self%state(iobs)/Tsteps + END IF +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + self%ObsVetting(iobs)=1 + IF (model.eq.iSTD) THEN ! take the square root + self%state(iobs)=SQRT(self%state(iobs)) + END IF + ELSE + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + self%ObsVetting(iobs)=1 +# endif +# ifndef ALLOW_BOTTOM_OBS +! +! Reject observations that lie in the lower bottom grid cell (k=1) to +! avoid clustering due shallowing of bathymetry during smoothing and +! coarse level half-thickness (-h < Zobs < self%depth(:,:,1)) in deep +! water. +! + IF ((obs%Zgrid(i).gt.0.0_r8).and. & + & (obs%Zgrid(i).le.1.0_r8)) THEN + self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# endif + END IF + END IF + END IF + END DO +! + RETURN + END SUBROUTINE obs_hofx_time_avg3d +# endif + +# ifdef ADJOINT +! +!----------------------------------------------------------------------- +! Adjoint of interpolating 2D state variables at the time-averaged +! observation locations. The 2D state variable is time-averaged +! according to the starting and ending time window values specified +! in the IODA-type observation file. Time-averaged observations are +! assumed to be at RHO-points (A-grid). +! +! The interpolation weights matrix, Hmat(1:4), is as follows: +! +! 4____________3 (i2,j2) +! | | +! | * (p,q) | +! | | +! |____________| +! (i1,j1) 1 2 +! + SUBROUTINE obs_hofx_time_avg2d_ad (ad_self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, ad_field) +! + CLASS (obs_hofx), intent(inout) :: ad_self ! H^(x) object + CLASS (obs_data), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(inout) :: ad_field(LBi:,LBj:) +! + integer :: i, ic, iobs, mc + integer :: i1, i2, j1, j2 + integer :: iTstr, iTend + real (r8) :: p1, p2, q1, q2, wsum + real (r8) :: Tsteps + real (r8), dimension(4) :: Hmat +! +! Adjoint of interpolate 2D model state variable at the time-averaged +! observation locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + & (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng)).and. & + & (obs%TimeStr(i).le.time(ng)).and. & + & (time(ng).le.obs%TimeEnd(i))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + Hmat(1)=p1*q1 + Hmat(2)=p2*q1 + Hmat(3)=p2*q2 + Hmat(4)=p1*q2 +# ifdef MASKING + Hmat(1)=Hmat(1)*ad_self%mask(i1,j1) + Hmat(2)=Hmat(2)*ad_self%mask(i2,j1) + Hmat(3)=Hmat(3)*ad_self%mask(i2,j2) + Hmat(4)=Hmat(4)*ad_self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,4 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,4 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif +! +! Adjoint of average resulting H^(x) over the specified time window. +! + iTstr=MAX(ntstart(ng), & + & INT((obs%TimeStr(i)-dstart*day2sec)/dt(ng))+1) + iTend=MIN(ntend(ng), & + & INT((obs%TimeEnd(i)-dstart*day2sec)/dt(ng))) + Tsteps=REAL(iTend-iTstr, r8) +! + IF (iic(ng).eq.iTend) THEN +!> self%state(iobs)=self%state(iobs)/Tsteps +!> + ad_self%state(iobs)=ad_self%state(iobs)/Tsteps + END IF +! +!> self%state(iobs)=self%state(iobs)+ & +!> & Hmat(1)*field(i1,j1)+ & +!> & Hmat(2)*field(i2,j1)+ & +!> & Hmat(3)*field(i2,j2)+ & +!> & Hmat(4)*field(i1,j2) +!> + ad_field(i1,j1)=ad_field(i1,j1)+ & + & Hmat(1)*ad_self%state(iobs) + ad_field(i2,j1)=ad_field(i2,j1)+ & + & Hmat(2)*ad_self%state(iobs) + ad_field(i2,j2)=ad_field(i2,j2)+ & + & Hmat(3)*ad_self%state(iobs) + ad_field(i1,j2)=ad_field(i1,j2)+ & + & Hmat(4)*ad_self%state(iobs) + IF (iic(ng).eq.iTend) THEN + ad_self%state(iobs)=0.0_r8 + END IF +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + ad_self%ObsVetting(iobs)=1 + ELSE + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + ad_self%ObsVetting(iobs)=1 +# endif + END IF + END DO +! + RETURN + END SUBROUTINE obs_hofx_time_avg2d_ad + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! Adjoint of interpolating 3D state variables at the time-averaged +! observation locations. The 3D state variable is time-averaged +! according to the starting and ending time window values specified +! in the IODA-type observation file. Time-averaged observations are +! assumed to be at RHO-points (A-grid). +! +! The interpolation weights matrix, Hmat(1:8), is as follows: +! +! 8______________7 +! /. /| (i2,j2,k2) +! / . / | +! 5/_____________/6 | +! | . | | +! | . *(p,q,r) | | Grid Cell +! | 4...........|..|3 +! | . | / +! |. | / +! (i1,j1,k1) |_____________|/ +! 1 2 +! + SUBROUTINE obs_hofx_time_avg3d_ad (ad_self, obs, ng, model, & + & ivar, tally, & + & LBi, UBi, LBj, UBj, ad_field) +! + CLASS (obs_hofx), intent(inout) :: ad_self ! H^(x) object + CLASS (obs_data), intent(inout) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + integer, intent(inout) :: tally(:) ! obs count/reject + integer, intent(in ) :: LBi, UBi ! field I-bounds + integer, intent(in ) :: LBj, UBj ! field J-bounds + real (r8), intent(inout) :: ad_field(LBi:,LBj:,:) +! + integer :: i, ic, iobs, k, mc + integer :: i1, i2, j1, j2, k1, k2 + integer :: iTstr, iTend + real (r8) :: p1, p2, q1, q2, r1, r2 + real (r8) :: w11, w12, w21, w22, wsum + real (r8) :: Zbot, Ztop, dz + real (r8) :: Tsteps + real (r8), dimension(8) :: Hmat +! +! Adjoint of interpolate 3D model state variable at the time-averaged +! observation locations. +! + DO i=obs%NstrObs,obs%NendObs + IF ((rXmin(ng).le.obs%Xgrid(i)).and. & + (obs%Xgrid(i).lt.rXmax(ng)).and. & + & (rYmin(ng).le.obs%Ygrid(i)).and. & + & (obs%Ygrid(i).lt.rYmax(ng)).and. & + & (obs%TimeStr(i).le.time(ng)).and. & + & (time(ng).le.obs%TimeStepEnd(i))) THEN +! + mc=1+(ivar-1)*2 ! count/reject index + tally(mc)=tally(mc)+1 ! obs counted + iobs=obs%pack_mapping(i,ivar) ! index mapping +! + i1=INT(obs%Xgrid(i)) + j1=INT(obs%Ygrid(i)) + i2=i1+1 + j2=j1+1 + IF (i2.gt.Lm(ng)+1) THEN + i2=i1 ! Observation at the eastern boundary + END IF + IF (j2.gt.Mm(ng)+1) THEN + j2=j1 ! Observation at the northern boundary + END IF + p2=REAL(i2-i1,r8)*(obs%Xgrid(i)-REAL(i1,r8)) + q2=REAL(j2-j1,r8)*(obs%Ygrid(i)-REAL(j1,r8)) + p1=1.0_r8-p2 + q1=1.0_r8-q2 + w11=p1*q1 + w21=p2*q1 + w22=p2*q2 + w12=p1*q2 + IF (obs%Zgrid(i).gt.0.0_r8) THEN + k1=MAX(1,INT(obs%Zgrid(i))) ! Positions in fractional + k2=MIN(INT(obs%Zgrid(i))+1,N(ng)) ! levels + r2=REAL(k2-k1,r8)*(obs%Zgrid(i)-REAL(k1,r8)) + r1=1.0_r8-r2 + ELSE + Ztop=ad_self%depth(i1,j1,N(ng)) + Zbot=ad_self%depth(i1,j1,1 ) + IF (obs%Zgrid(i).ge.Ztop) THEN + k1=N(ng) ! If shallower, assign to + k2=N(ng) ! top grid cell. The + r1=1.0_r8 ! observation is located + r2=0.0_r8 ! on the upper cell half + obs%Zgrid(i)=REAL(N(ng),r8) ! above its middle depth. + ELSE IF (Zbot.ge.obs%Zgrid(i)) THEN + r1=0.0_r8 ! If deeper, ignore. + r2=0.0_r8 + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs reject + ELSE + DO k=N(ng),2,-1 ! Otherwise, interpolate + Ztop=ad_self%depth(i1,j1,k ) ! to fractional level + Zbot=ad_self%depth(i1,j1,k-1) + IF ((Ztop.gt.obs%Zgrid(i)).and. & + & (obs%Zgrid(i).ge.Zbot)) THEN + k1=k-1 + k2=k + END IF + END DO + dz=ad_self%depth(i1,j1,k2)-ad_self%depth(i1,j1,k1) + r2=(obs%Zgrid(i)-ad_self%depth(i1,j1,k1))/dz + r1=1.0_r8-r2 + obs%Zgrid(i)=REAL(k1,r8)+r2 ! overwrite + END IF + END IF + IF ((r1+r2).gt.0.0_r8) THEN + Hmat(1)=w11*r1 + Hmat(2)=w21*r1 + Hmat(3)=w22*r1 + Hmat(4)=w12*r1 + Hmat(5)=w11*r2 + Hmat(6)=w21*r2 + Hmat(7)=w22*r2 + Hmat(8)=w12*r2 +# ifdef MASKING + Hmat(1)=Hmat(1)*ad_self%mask(i1,j1) + Hmat(2)=Hmat(2)*ad_self%mask(i2,j1) + Hmat(3)=Hmat(3)*ad_self%mask(i2,j2) + Hmat(4)=Hmat(4)*ad_self%mask(i1,j2) + Hmat(5)=Hmat(5)*ad_self%mask(i1,j1) + Hmat(6)=Hmat(6)*ad_self%mask(i2,j1) + Hmat(7)=Hmat(7)*ad_self%mask(i2,j2) + Hmat(8)=Hmat(8)*ad_self%mask(i1,j2) + wsum=0.0_r8 + DO ic=1,8 + wsum=wsum+Hmat(ic) + END DO + IF (wsum.gt.0.0_r8) THEN + wsum=1.0_r8/wsum + DO ic=1,8 + Hmat(ic)=Hmat(ic)*wsum + END DO + END IF +# endif +! +! Adjoint of average resulting H^(x) over the specified time window. +! + iTstr=MAX(ntstart(ng), & + & INT((obs%TimeStr(i)-dstart*day2sec)/dt(ng))+1) + iTend=MIN(ntend(ng), & + & INT((obs%TimeEnd(i)-dstart*day2sec)/dt(ng))) + Tsteps=REAL(iTend-iTstr, r8) +! + IF (iic(ng).eq.iTend) THEN +!> self%state(iobs)=self%state(iobs)/Tsteps +!> + ad_self%state(iobs)=ad_self%state(iobs)/Tsteps + END IF +! +!> self%state(iobs)=self%state(iobs)+ & +!> & Hmat(1)*field(i1,j1,k1)+ & +!> & Hmat(2)*field(i2,j1,k1)+ & +!> & Hmat(3)*field(i2,j2,k1)+ & +!> & Hmat(4)*field(i1,j2,k1)+ & +!> & Hmat(5)*field(i1,j1,k2)+ & +!> & Hmat(6)*field(i2,j1,k2)+ & +!> & Hmat(7)*field(i2,j2,k2)+ & +!> & Hmat(8)*field(i1,j2,k2) +!> + ad_field(i1,j1,k1)=ad_field(i1,j1,k1)+ & + & Hmat(1)*ad_self%state(iobs) + ad_field(i2,j1,k1)=ad_field(i2,j1,k1)+ & + & Hmat(2)*ad_self%state(iobs) + ad_field(i2,j2,k1)=ad_field(i2,j2,k1)+ & + & Hmat(3)*ad_self%state(iobs) + ad_field(i1,j2,k1)=ad_field(i1,j2,k1)+ & + & Hmat(4)*ad_self%state(iobs) + ad_field(i1,j1,k2)=ad_field(i1,j1,k2)+ & + & Hmat(5)*ad_self%state(iobs) + ad_field(i2,j1,k2)=ad_field(i2,j1,k2)+ & + & Hmat(6)*ad_self%state(iobs) + ad_field(i2,j2,k2)=ad_field(i2,j2,k2)+ & + & Hmat(7)*ad_self%state(iobs) + ad_field(i1,j2,k2)=ad_field(i1,j2,k2)+ & + & Hmat(8)*ad_self%state(iobs) + IF (iic(ng).eq.iTend) THEN + ad_self%state(iobs)=0.0_r8 + END IF +# ifdef MASKING + IF (wsum.gt.0.0_r8) THEN + ad_self%ObsVetting(iobs)=1 + ELSE + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# else + ad_self%ObsVetting(iobs)=1 +# endif +# ifndef ALLOW_BOTTOM_OBS +! +! Reject observations that lie in the lower bottom grid cell (k=1) to +! avoid clustering due shallowing of bathymetry during smoothing and +! coarse level half-thickness (-h < Zobs < self%depth(:,:,1)) in deep +! water. +! + IF ((obs%Zgrid(i).gt.0.0_r8).and. & + & (obs%Zgrid(i).le.1.0_r8)) THEN + ad_self%ObsVetting(iobs)=0 + tally(mc+1)=tally(mc+1)+1 ! obs rejected + END IF +# endif + END IF + END IF + END DO +! + RETURN + END SUBROUTINE obs_hofx_time_avg3d_ad +# endif +# endif +! +! <><><><><><><><><><><><><><><><><><><><><><><><><> HOFX UTILITY <><><> +! +! It adds two state vectors: self = self + c * rhs. +! + SUBROUTINE obs_hofx_add (self, c, rhs) +! + CLASS (obs_hofx), intent(inout) :: self ! LHS H(x) object + CLASS (obs_hofx), intent(in ) :: rhs ! RHS H(x) object + real (r8), intent(in ) :: c ! scale factor +! + integer :: i +! +! Add states vectors. +! + DO i=1,SIZE(self%state) + self%state(i)=self%state(i)+rhs%state(i) + END DO +! + RETURN + END SUBROUTINE obs_hofx_add + +# ifdef BGQC +! +!----------------------------------------------------------------------- +! It rejects observations that fail the background quality contol by +! setting ObsVetting to zero. +! + SUBROUTINE obs_hofx_background_QC (self, obs, berr, ng, model) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + CLASS (obs_pool), intent(in ) :: obs ! observation depot + CLASS (obs_hofx), intent(in ) :: Berr ! H(x) background error + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer :: nlocs, npool, mvars + integer :: i, iloc, iobs, ivar + real (r8) :: BerrInv, obs_err, obs_val + real (r8) :: df1, df2, thresh + real (r8), allocatable :: Bthresh(:) +! +! Perform background quality control of the observations. Here, "self" +! is the nonlinear H(x), except in the inverse representers alogorithm +! where H(x) is for the finite amplitude tangent linear model. +! + npool=SIZE(obs%pool) + DO i=1,npool + mvars=obs%pool(i)%nvars + nlocs=obs%pool(i)%nlocs +! + IF (.not.allocated(Bthresh)) THEN + allocate ( Bthresh(nlocs) ) + Bthresh=bgqc_large + END IF +! + DO ivar=1,mvars + CALL obs%pool(i)%qc_threshold (ng, model, ivar, Bthresh) + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + IF (self%ObsVetting(iobs).ne.0) THEN + obs_val=obs%pool(i)%value(iloc,ivar) + obs_err=obs%pool(i)%error(iloc,ivar) + BerrInv=1.0_r8/Berr%state(iobs) +! + df1=(obs_val-self%state(iobs))*BerrInv + df2=(1.0_r8/obs_err)/(BerrInv*BerrInv) +! + thresh=Bthresh(iloc)*(1.0_r8+df2) + IF (df1*df1.gt.thresh) THEN + self%ObsVetting(iobs)=0 + END IF + END IF + END DO + END DO + IF (allocated(Bthresh)) deallocate (Bthresh) + END DO +! + RETURN + END SUBROUTINE obs_hofx_background_QC +# endif +! +!----------------------------------------------------------------------- +! It computes and writes the increment (analysis minus background) at +! the observation locations into multiple output NetCDF-4 files. +! + SUBROUTINE obs_hofx_increment (self, obs, ng, model) +! + CLASS (obs_hofx), intent(in ) :: self ! H(x) analysis object + CLASS (obs_pool), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer :: nlocs, npool, mvars + integer :: i, iloc, iobs, ivar + real (r8) :: Wmin, Wmax + real (r8), allocatable :: work(:) +! + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_increment" +! + SourceFile=MyFile +! +! Process increment at the observation locations. +! + npool=SIZE(obs%pool) + DO i=1,npool + mvars=obs%pool(i)%nvars + nlocs=obs%pool(i)%nlocs + allocate ( work(nlocs) ) + DO ivar=1,mvars + work=0.0_r8 +! +! Read in background. +! + CALL netcdf_get_fvar (ng, model, obs%pool(i)%ncname_out, & + & TRIM(obs%pool(i)%vars(ivar)), work, & + & GrpName = 'hofxInitial') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Compute increment. +! + Wmin=spval + Wmax=-spval + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + work(iloc)=REAL(self%ObsVetting(iobs), r8)* & + & (self%state(iobs)-work(iloc)) + IF (self%ObsVetting(iobs).gt.0) THEN + Wmin=MIN(Wmin, work(iloc)) + Wmax=MAX(Wmax, work(iloc)) + END IF + END DO +! +! Write out increment. +! + CALL netcdf_put_fvar (ng, model, obs%pool(i)%ncname_out, & + & TRIM(obs%pool(i)%vars(ivar)), work, & + & (/1/), (/nlocs/), & + & GrpName = 'Increment') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + IF (Master) THEN + WRITE (stdout,10) 'Increment', & + & TRIM(obs%pool(i)%vars(ivar)), & + & Wmin, Wmax, TRIM(obs%pool(i)%ncname_out) + END IF + deallocate (work) + END DO + END DO +! + 10 FORMAT (t22,'Group:',a,'::',a,/,t23,'(Min = ',1p,e12.5, & + & ' Max = ', 1p,e12.5,') File: ',a) +! + RETURN + END SUBROUTINE obs_hofx_increment +! +!----------------------------------------------------------------------- +! It computes and writes the innovation (observations minus analysis) +! at the observation locations into multiple output NetCDF-4 files. +! + SUBROUTINE obs_hofx_innovation (self, obs, ng, model) +! + CLASS (obs_hofx), intent(in ) :: self ! H(x) backgrouns object + CLASS (obs_pool), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer :: nlocs, npool, mvars + integer :: i, iloc, iobs, ivar + real (r8) :: Wmin, Wmax + real (r8), allocatable :: work(:) +! + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_innovation" +! + SourceFile=MyFile +! +! Process innovation at the observation locations. +! + npool=SIZE(obs%pool) + DO i=1,npool + mvars=obs%pool(i)%nvars + nlocs=obs%pool(i)%nlocs + allocate ( work(nlocs) ) + DO ivar=1,mvars + work=0.0_r8 +! +! Compute innovation. +! + Wmin=spval + Wmax=-spval + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + work(iloc)=REAL(self%ObsVetting(iobs), r8)* & + & (obs%pool(i)%value(iloc,ivar)-self%state(iobs)) + IF (self%ObsVetting(iobs).gt.0) THEN + Wmin=MIN(Wmin, work(iloc)) + Wmax=MAX(Wmax, work(iloc)) + END IF + END DO +! +! Write out innovation. +! + CALL netcdf_put_fvar (ng, model, obs%pool(i)%ncname_out, & + & TRIM(obs%pool(i)%vars(ivar)), work, & + & (/1/), (/nlocs/), & + & GrpName = 'Innovation') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + IF (Master) THEN + WRITE (stdout,10) 'Innovation', & + & TRIM(obs%pool(i)%vars(ivar)), & + & Wmin, Wmax, TRIM(obs%pool(i)%ncname_out) + END IF + deallocate (work) + END DO + END DO +! + 10 FORMAT (t22,'Group:',a,'::',a,/,t23,'(Min = ',1p,e12.5, & + & ' Max = ', 1p,e12.5,') File: ',a) +! + RETURN + END SUBROUTINE obs_hofx_innovation +! +!----------------------------------------------------------------------- +! It writes generic H(x) variables into multiple output NetCDF-4 files +! file(s). +! + SUBROUTINE obs_hofx_nc_write (self, obs, ng, model, grpname) +! + CLASS (obs_hofx), intent(in ) :: self ! H(x) object + CLASS (obs_pool), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + character (len=*), intent(in ) :: grpname ! NetCDF group name +! + integer :: nlocs, npool, mvars + integer :: i, iloc, iobs, ivar + integer, allocatable :: iwork(:) + real (r8) :: Wmin, Wmax + real (r8), allocatable :: work(:) +! + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_nc_write" +! + SourceFile=MyFile +! +! Write out generic field. +! + SELECT CASE (TRIM(GrpName)) + CASE ('ObsVetting') + npool=SIZE(obs%pool) + DO i=1,npool + mvars=obs%pool(i)%nvars + nlocs=obs%pool(i)%nlocs + IF (.not.allocated(iwork)) allocate ( iwork(nlocs) ) +! + DO ivar=1,mvars + iwork=0 + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + iwork(iloc)=self%ObsVetting(iobs) + END DO +! + CALL netcdf_put_ivar (ng, model, obs%pool(i)%ncname_out, & + & obs%pool(i)%vars(ivar), iwork, & + & (/1/), (/nlocs/), & + & GrpName = TRIM(grpname)) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN +! + IF (Master) THEN + WRITE (stdout,10) TRIM(grpname), & + & TRIM(obs%pool(i)%vars(ivar)), & + & MINVAL(iwork), MAXVAL(iwork), & + & TRIM(obs%pool(i)%ncname_out) + END IF + END DO + IF (allocated(iwork)) deallocate (iwork) + END DO +! + CASE DEFAULT + npool=SIZE(obs%pool) + DO i=1,npool + mvars=obs%pool(i)%nvars + nlocs=obs%pool(i)%nlocs + IF (.not.allocated(iwork)) allocate ( work(nlocs) ) +! + Wmin=spval + Wmax=-spval + DO ivar=1,mvars + work=0.0_r8 + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + work(iloc)=self%state(iobs) + IF (self%ObsVetting(iobs).gt.0) THEN + Wmin=MIN(Wmin, work(iloc)) + Wmax=MAX(Wmax, work(iloc)) + END IF + END DO +! + CALL netcdf_put_fvar (ng, model, obs%pool(i)%ncname_out, & + & obs%pool(i)%vars(ivar), work, & + & (/1/), (/nlocs/), & + & GrpName = TRIM(grpname)) + IF (FoundError(exit_flag, NoError, & + & __LINE__, MyFile)) RETURN +! + IF (Master) THEN + WRITE (stdout,20) TRIM(grpname), & + & TRIM(obs%pool(i)%vars(ivar)), & + & Wmin, Wmax, & + & TRIM(obs%pool(i)%ncname_out) + END IF + END DO + IF (allocated(work)) deallocate (work) + END DO + END SELECT +! + 10 FORMAT (t22,'Group:',a,'::',a,/,t23,'(Min = ',i12, & + & ' Max = ',i12,') File: ',a) + 20 FORMAT (t22,'Group:',a,'::',a,/,t23,'(Min = ',1p,e12.5, & + & ' Max = ', 1p,e12.5,') File: ',a) +! + RETURN + END SUBROUTINE obs_hofx_nc_write +! +!----------------------------------------------------------------------- +! It computes and writes the residual (observations minus analysis) +! at the observation locations into multiple output NetCDF-4 files. +! + SUBROUTINE obs_hofx_residual (self, obs, ng, model) +! + CLASS (obs_hofx), intent(in ) :: self ! H(x) analysis object + CLASS (obs_pool), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer :: nlocs, npool, mvars + integer :: i, iloc, iobs, ivar + real (r8) :: Wmin, Wmax + real (r8), allocatable :: work(:) +! + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_residual" +! + SourceFile=MyFile +! +! Process residual at the observation locations. +! + npool=SIZE(obs%pool) + DO i=1,npool + mvars=obs%pool(i)%nvars + nlocs=obs%pool(i)%nlocs + allocate ( work(nlocs) ) + DO ivar=1,mvars + work=0.0_r8 +! +! Compute residual. +! + Wmin=spval + Wmax=-spval + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + work(iloc)=REAL(self%ObsVetting(iobs), r8)* & + & (obs%pool(i)%value(iloc,ivar)-self%state(iobs)) + IF (self%ObsVetting(iobs).gt.0) THEN + Wmin=MIN(Wmin, work(iloc)) + Wmax=MAX(Wmax, work(iloc)) + END IF + END DO +! +! Write out residual. +! + CALL netcdf_put_fvar (ng, model, obs%pool(i)%ncname_out, & + & TRIM(obs%pool(i)%vars(ivar)), work, & + & (/1/), (/nlocs/), & + & GrpName = 'Residual') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + IF (Master) THEN + WRITE (stdout,10) 'Residual', & + & TRIM(obs%pool(i)%vars(ivar)), & + & Wmin, Wmax, TRIM(obs%pool(i)%ncname_out) + END IF + deallocate (work) + END DO + END DO +! + 10 FORMAT (t22,'Group:',a,'::',a,/,t23,'(Min = ',1p,e12.5, & + & ' Max = ', 1p,e12.5,') File: ',a) +! + RETURN + END SUBROUTINE obs_hofx_residual +! +!----------------------------------------------------------------------- +! It computes the root-mean-square value of the H(x) vector. +! + SUBROUTINE obs_hofx_rms (self, rms) +! + CLASS (obs_hofx), intent(in ) :: self ! H(x) object + real (r8), intent(out ) :: rms ! root-mean-square +! + integer :: i + real (r8) :: my_sum +! +! Compute RMS value. +! + my_sum=0.0_r8 + DO i=1,self%ndatum + my_sum=my_sum+self%state(i)*self%state(i) + END DO +! +! Normalize by the number observations and take the square root. +! + rms=SQRT(my_sum/REAL(self%ndatum,r8)) +! + RETURN + END SUBROUTINE obs_hofx_rms +! +!----------------------------------------------------------------------- +! It computes several statistics between model and observarions +! (Oke et al., 2002). +! + SUBROUTINE obs_hofx_stats (self, obs, ng, model) +! + CLASS (obs_hofx), intent(in ) :: self ! H(x) object + CLASS (obs_pool), intent(in ) :: obs ! observation depot + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer :: i, ic, iloc, iobs, ivar + integer :: mvars, nlocs, npool + integer, dimension(NobsVar(ng)) :: Ncount +! + real (r8) :: cff1, cff2, mod_val, obs_val + real (r8), dimension(NobsVar(ng)) :: CC, MB, MSE, SDE + real (r8), dimension(NobsVar(ng)) :: mod_min, mod_max + real (r8), dimension(NobsVar(ng)) :: mod_mean, mod_std + real (r8), dimension(NobsVar(ng)) :: obs_min, obs_max + real (r8), dimension(NobsVar(ng)) :: obs_mean, obs_std +! + character (len=11) :: svar_name(NobsVar(ng)) + character (len=11) :: text(NobsVar(ng)) +! +! Initialize. +! + CC=0.0_r8 + MB=0.0_r8 + MSE=0.0_r8 + SDE=0.0_r8 + mod_min=Large + mod_max=-Large + mod_mean=0.0_r8 + obs_min=Large + obs_max=-Large + obs_mean=0.0_r8 + mod_std=0.0_r8 + obs_std=0.0_r8 + Ncount=0 +! +! Compute statistics. +! + ic=0 + npool=SIZE(obs%pool) + DO i=1,npool + mvars=obs%pool(i)%nvars + nlocs=obs%pool(i)%nlocs + DO ivar=1,mvars + ic=ic+1 + svar_name(ic)=obs%pool(i)%vname(ivar) + text(ic)='-----------' +! +! Compute min, max, and mean values. +! + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + IF (self%ObsVetting(iobs).gt.0) THEN + mod_val=self%state(iobs) + obs_val=obs%pool(i)%value(iloc,ivar) + Ncount(ic)=Ncount(ic)+1 + mod_min(ic)=MIN(mod_min(ic), mod_val) + obs_min(ic)=MIN(obs_min(ic), obs_val) + mod_max(ic)=MAX(mod_max(ic), mod_val) + obs_max(ic)=MAX(obs_max(ic), obs_val) + mod_mean(ic)=mod_mean(ic)+mod_val + obs_mean(ic)=obs_mean(ic)+obs_val + END IF + END DO + mod_mean(ic)=mod_mean(ic)/REAL(Ncount(ic),r8) + obs_mean(ic)=obs_mean(ic)/REAL(Ncount(ic),r8) +! +! Compute standard deviation and cross-correlation between model and +! observations (CC). +! + DO iloc=1,nlocs + iobs=obs%pool(i)%pack_mapping(iloc,ivar) + IF (self%ObsVetting(iobs).gt.0) THEN + mod_val=self%state(iobs) + obs_val=obs%pool(i)%value(iloc,ivar) + cff1=mod_val-mod_mean(ic) + cff2=obs_val-obs_mean(ic) + mod_std(ic)=mod_std(ic)+cff1*cff1 + obs_std(ic)=obs_std(ic)+cff2*cff2 + CC(ic)=CC(ic)+cff1*cff2 + END IF + END DO + mod_std(ic)=SQRT(mod_std(ic)/REAL(Ncount(ic)-1,r8)) + obs_std(ic)=SQRT(obs_std(ic)/REAL(Ncount(ic)-1,r8)) + CC(ic)=(CC(ic)/REAL(Ncount(ic),r8))/(mod_std(ic)*obs_std(ic)) +! +! Compute model bias (MB), standard deviation error (SDE), and mean +! squared error (MSE). +! + MB(ic)=mod_mean(ic)-obs_mean(ic) + SDE(ic)=mod_std(ic)-obs_std(ic) + MSE(ic)=MB(ic)*MB(ic)+ & + & SDE(ic)*SDE(ic)+ & + & 2.0_r8*mod_std(ic)*obs_std(ic)*(1.0_r8-CC(ic)) + END DO + END DO +! +! Report. +! + IF (Master) THEN + WRITE (stdout,10) + WRITE (stdout,20) (svar_name(i),i=1,ic) + WRITE (stdout,30) (text(i),i=1,ic) + WRITE (stdout,40) 'Observation Min ', (obs_min (i),i=1,ic) + WRITE (stdout,40) 'Observation Max ', (obs_max (i),i=1,ic) + WRITE (stdout,40) 'Observation Mean ', (obs_mean(i),i=1,ic) + WRITE (stdout,40) 'Observation STD ', (obs_std (i),i=1,ic) + WRITE (stdout,40) 'Model Min ', (mod_min (i),i=1,ic) + WRITE (stdout,40) 'Model Max ', (mod_max (i),i=1,ic) + WRITE (stdout,40) 'Model Mean ', (mod_mean(i),i=1,ic) + WRITE (stdout,40) 'Model STD ', (mod_std (i),i=1,ic) + WRITE (stdout,40) 'Model Bias ', (MB(i),i=1,ic) + WRITE (stdout,40) 'STD Error ', (SDE(i),i=1,ic) + WRITE (stdout,40) 'Cross-Correlation ', (CC(i),i=1,ic) + WRITE (stdout,40) 'Mean Squared Error', (MSE(i),i=1,ic) + WRITE (stdout,50) 'Observation Count ', (Ncount(i),i=1,ic) + END IF +! + 10 FORMAT (/,' Model-Observations Comparison Statistics:',/) + 20 FORMAT (t22,*(a11,1x)) + 30 FORMAT (t22,*(a11,1x),/) + 40 FORMAT (a,3x,*(1p,e11.4,0p,1x)) + 50 FORMAT (a,3x,*(i11,1x)) +! + RETURN + END SUBROUTINE obs_hofx_stats +! +!----------------------------------------------------------------------- +! It collects H(x) values from all tasks in the distributed-memory +! group. +! + SUBROUTINE obs_hofx_update (self, ng, model) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer, parameter :: Ivalue = 0 + real (r8), parameter :: Rvalue = 0.0_r8 + + character (len=*), parameter :: MyFile = & + & __FILE__//", roms_hofx_update" +! + SourceFile=MyFile + +# ifdef DISTRIBUTE +! +! Collect H(x) values and ObsVetting flag. +! + CALL mp_collect (ng, model, self%ndatum, Rvalue, self%state) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + CALL mp_collect (ng, model, self%ndatum, Ivalue, self%ObsVetting) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +# endif +! + RETURN + END SUBROUTINE obs_hofx_update +! +!----------------------------------------------------------------------- +! It zeroth out H(x) vector variables. +! + SUBROUTINE obs_hofx_zeros (self) +! + CLASS (obs_hofx), intent(inout) :: self ! H(x) object +! + integer, parameter :: Ivalue = 0 + real (r8), parameter :: Rvalue = 0.0_r8 +! +! Initialize object vector variables to zero. In distributed-memory +! applications, the collection of data in all tasks is donne by +! summation. +! + self%state = Rvalue + self%ObsVetting = Ivalue +! + RETURN + END SUBROUTINE obs_hofx_zeros +! +!------------------------------------------------------------------------ +! +#endif + END MODULE roms_hofx_mod diff --git a/ROMS/Utility/roms_interp.F b/ROMS/Utility/roms_interp.F index 90a1e51e3..3e5638bc5 100644 --- a/ROMS/Utility/roms_interp.F +++ b/ROMS/Utility/roms_interp.F @@ -76,7 +76,7 @@ MODULE roms_interp_mod real(r8), allocatable :: Ysrc(:,:) ! Y-locations ! ! Destination tiled grid geometry parameters and arrays. - +! integer :: LBI_d, UBI_d, LBJ_d, UBJ_d ! declaration bounds integer :: Imin_d, Imax_d, Jmin_d, Jmax_d ! data bounds ! diff --git a/ROMS/Utility/roms_obs.F b/ROMS/Utility/roms_obs.F new file mode 100644 index 000000000..a05026e62 --- /dev/null +++ b/ROMS/Utility/roms_obs.F @@ -0,0 +1,3383 @@ +#include "cppdefs.h" + MODULE roms_obs_mod + +#if (defined FOUR_DVAR || defined VERIFICATION) && defined OBSERVATIONS +! +!git $Id$ +!================================================== Hernan G. Arango === +! Copyright (c) 2002-2025 The ROMS Group ! +! Licensed under a MIT/X style license ! +! See License_ROMS.md ! +!======================================================================= +! ! +! It contains several routines to process input 4D-Var observation ! +! file(s). ! +! ! +! Currently, the PIO library does not support the processing of ! +! Group variables in enhanced NetCDF-4 (IODA) files. Thus, ROMS ! +! uses the standard NetCDF library for processing observations. ! +! ! +!======================================================================= +! + USE mod_param + USE mod_parallel + USE mod_grid + USE mod_iounits + USE mod_netcdf + USE mod_scalars + USE mod_strings +! + USE dateclock_mod, ONLY : caldate, datenum, datestr +#ifdef DISTRIBUTE + USE distribute_mod, ONLY : mp_assemble, mp_bcasti +#endif + USE get_hash_mod, ONLY : get_hash + USE mod_ncparam, ONLY : date_str + USE roms_interpolate_mod, ONLY : hindices + USE strings_mod, ONLY : FoundError, lowercase, nc_error + USE unique_mod, ONLY : unique +! + implicit none +! +!----------------------------------------------------------------------- +! Enhanced NetCDF-4 group object. +!----------------------------------------------------------------------- +! + TYPE, PUBLIC :: nc_group + + integer :: gid ! group ID + integer :: nvars ! number of variables +! + integer, allocatable :: vid(:) ! variables ID + + character (len=:), allocatable :: name ! group name + character (len=:), allocatable :: vname(:) ! variables name + + END TYPE nc_group +! +!----------------------------------------------------------------------- +! Observation Cost Function Object. +!----------------------------------------------------------------------- +! + TYPE, PUBLIC :: obs_cost + + integer :: nvars ! number of variables +! + real (r8), allocatable :: value(:) ! cost function value + + END TYPE obs_cost +! +!----------------------------------------------------------------------- +! Observation Data Type Structures/Objects: CLASS(obs_data). +!----------------------------------------------------------------------- +! + TYPE, PUBLIC :: obs_data + + integer :: nlocs ! number of observations + integer :: nsurvey ! number of times surveys + integer :: nvars ! number of variables + integer :: poolID ! observation pool ID +! +! Switches indicating area-averaged and time-averaged observations. +! + logical :: IsAreaAveraged + logical :: IsTimeAveraged +! +! Observation origin identifier. Repetitive observations have their +! provenance multiplied by -1 so they can be quickly identified during +! processing. +! + integer, allocatable :: provenance(:) +! +! Control vector state variable identifier. +! + integer, allocatable :: stateID(:) +! +! Observation survey time indices as they appear in the "time" +! variable. +! + integer, allocatable :: surveyIndex(:) +! +! Starting and ending times for time-averaged operator. +! + real (r8), allocatable :: TimeStr(:) ! starting time + real (r8), allocatable :: TimeEnd(:) ! ending time +! +! Starting and ending observation vector indices available for +! requested model time interval, time-0.5*dt to time+0.5*dt. They +! are zero, if no observations are available in the time window. +! + integer :: NstrObs + integer :: NendObs +! +! Mapping indices for the packed observations vector. It is used +! when computing H(x), the cost function, and minimization where +! and the observations are clustered in a 1D array. +! + integer, allocatable :: pack_mapping(:,:) +! +! Half-length spatial scale (m) for area-averaged operator. +! + real (r8), allocatable :: spatialAverage(:) +! +! Observation spatial and time coordinates. The fractional values are +! used for efficient interpolation in the H(x) operator. +! +! Internally, time and surveyTime are in nearest integer seconds since +! ROMS reference date and time to avoid roundoff. +! + real (r8), allocatable :: lon(:) ! observation longitude + real (r8), allocatable :: lat(:) ! observation latitude + real (r8), allocatable :: depth(:) ! depth of observation + real (r8), allocatable :: time(:) ! time of observation + real (r8), allocatable :: surveyTime(:) ! survey time +! + real (r8), allocatable :: Xgrid(:) ! fractional X-grid + real (r8), allocatable :: Ygrid(:) ! fractional Y-grid + real (r8), allocatable :: Zgrid(:) ! fractional Z-grid +! +! If the observations are scalar, the second dimension is unity. +! Otherwise, it is used for vectors or multiple observations at the +! exact spatial and time coordinates. +! + real (r8), allocatable :: error(:,:) ! observation error(s) + real (r8), allocatable :: value(:,:) ! observation value(s) +! + character (len=:), allocatable :: vars(:) ! NetCDF variable name +! +! Observation statistics. +! + integer (i8b), allocatable :: error_hash(:) + integer (i8b), allocatable :: value_hash(:) +! + real (r8), allocatable :: error_avg(:) + real (r8), allocatable :: error_min(:) + real (r8), allocatable :: error_max(:) + + real (r8), allocatable :: value_avg(:) + real (r8), allocatable :: value_min(:) + real (r8), allocatable :: value_max(:) +! + real (r8) :: time_min + real (r8) :: time_max +! + character (len=22) :: date_min + character (len=22) :: date_max +! +! Internal observation data object name. +! + character (len=:), allocatable :: name + character (len=:), allocatable :: vname(:) +! +! Input observation filename. It supports native ROMS 4D-Var NetCDF +! files and IODA enhanced NetCDF-4 files with Groups. +! + character (len=:), allocatable :: ncname_inp +! +! Output observation plus H(x) operator enhanced NetCDF-4 file +! information. +! + integer :: ncid ! NetCDF file ID + integer :: ngroups ! groups size +! + TYPE (nc_group), allocatable :: group(:) ! group object +! + character (len=:), allocatable :: ncname_out ! output filename +! + CONTAINS +! + PROCEDURE :: destroy => obs_data_destroy + PROCEDURE :: frac_coords => obs_data_frac_coords + PROCEDURE :: populate_ioda => obs_data_populate_ioda + PROCEDURE :: qc_threshold => obs_data_qc_threshold + PROCEDURE :: stats => obs_data_stats +! + END TYPE obs_data +! +!----------------------------------------------------------------------- +! Collection Observation Data Types Object: CLASS(obs_pool). +!----------------------------------------------------------------------- +! + TYPE, PUBLIC :: obs_pool +! +! Total number of observations in pool depot. +! + integer :: ndatum +! +! Observation ID associated with control state variable, [1:ntype]. +! (zeta=1, ubar=2, vbar=3, u=4, v=5, temperature=6, salinity=7) +! + integer, allocatable :: stateID(:) +! +! Observations reference date-time as a 'datenum' for the Proleptic +! Gregorian calendar: days since Jan 1, 0000. Notice datenum(0,1,1)=1. +! (ref_datetime(1): days, ref_datetime(2): seconds). +! + real (dp), dimension(2) :: ref_datetime +! +! Observation set object. Each element corresponds to an observation +! associated with a state variable, [1:ntype]. +! + TYPE (obs_data), allocatable :: pool(:) +! + CONTAINS +! + PROCEDURE :: create => obs_pool_create + PROCEDURE :: destroy => obs_pool_destroy + PROCEDURE :: get => obs_pool_get + PROCEDURE :: has => obs_pool_has + PROCEDURE :: load_ioda => obs_pool_load_ioda + PROCEDURE :: load_native => obs_pool_load_native + PROCEDURE :: nc4_clone => obs_pool_nc4_clone + PROCEDURE :: nc4_define => obs_pool_nc4_define + PROCEDURE :: nc_create => obs_pool_nc_create + PROCEDURE :: nc_read => obs_pool_nc_read + PROCEDURE :: nc_write => obs_pool_nc_write + PROCEDURE :: populate_native => obs_pool_populate_native + PROCEDURE :: size => obs_pool_size + PROCEDURE :: tally => obs_pool_tally + PROCEDURE :: unpack_i => obs_pool_unpack_i + PROCEDURE :: unpack_r => obs_pool_unpack_r +! + END TYPE obs_pool +! +!----------------------------------------------------------------------- +! Module variables. +!----------------------------------------------------------------------- +! +! Define observation storage object. Currently, there is unecessary to +! have different in nested grid applications since fractional grid +! coordinates can be recomputed from they geographical locations. +! + TYPE (obs_pool) :: obs_store +! +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +! + PUBLIC :: obs_initialize +! +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +! + CONTAINS +! +! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> +! +! It allocates the observation set object. Then, reads observation +! file(s), and populates data into the depot object. It should be +! called once during ROMS initialization phase. +! + SUBROUTINE obs_initialize (ng, model, nfiles) +! + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: nfiles ! number of files +! + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_initialize" +! + SourceFile=MyFile +! +! Creates and populates observation pool object. +! + CALL obs_pool_create (obs_store, ng, model, nfiles) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + RETURN + END SUBROUTINE obs_initialize +! +!<><><><><><><><><><><><><><><><><><><><><><><><> CLASS OBS_DATA <><><> +! +! It destroys a observation data object. +! + SUBROUTINE obs_data_destroy (self) +! + CLASS (obs_data), intent(inout) :: self ! observation object + +! Deallocate observation data object variables. +! + IF (allocated(self%pack_mapping)) deallocate (self%pack_mapping) + IF (allocated(self%provenance)) deallocate (self%provenance) + IF (allocated(self%lon)) deallocate (self%lon) + IF (allocated(self%lat)) deallocate (self%lat) + IF (allocated(self%depth)) deallocate (self%depth) + IF (allocated(self%time)) deallocate (self%time) + IF (allocated(self%stateID)) deallocate (self%stateID) + IF (allocated(self%surveyIndex)) deallocate (self%surveyIndex) + IF (allocated(self%surveyTime)) deallocate (self%surveyTime) + IF (allocated(self%vars)) deallocate (self%vars) + IF (allocated(self%Xgrid)) deallocate (self%Xgrid) + IF (allocated(self%Ygrid)) deallocate (self%Ygrid) + IF (allocated(self%Zgrid)) deallocate (self%Zgrid) +! + IF (allocated(self%error)) deallocate (self%error) + IF (allocated(self%value)) deallocate (self%value) +! + IF (allocated(self%error_avg)) deallocate (self%error_avg) + IF (allocated(self%error_hash)) deallocate (self%error_hash) + IF (allocated(self%error_min)) deallocate (self%error_min) + IF (allocated(self%error_max)) deallocate (self%error_max) + + IF (allocated(self%value_avg)) deallocate (self%value_avg) + IF (allocated(self%value_hash)) deallocate (self%value_hash) + IF (allocated(self%value_min)) deallocate (self%value_min) + IF (allocated(self%value_max)) deallocate (self%value_max) +! + IF (allocated(self%name)) deallocate (self%name) + IF (allocated(self%vname)) deallocate (self%vname) + IF (allocated(self%ncname_inp)) deallocate (self%ncname_inp) + IF (allocated(self%ncname_out)) deallocate (self%ncname_out) +! + RETURN + END SUBROUTINE obs_data_destroy +! +!----------------------------------------------------------------------- +! If not available, it computes observation object fractional +! coordinates. +! + SUBROUTINE obs_data_frac_coords (self, ng, model, tile) +! + CLASS (obs_data), intent(inout) :: self ! observation object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: tile ! domain partition +! + logical :: rectangular + integer :: LBi, UBi, LBj, UBj + integer :: IstrR, IendR, JstrR, JendR +! +! Compute observation fractional coordinates. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! + IstrR=BOUNDS(ng)%IstrR(tile) + IendR=BOUNDS(ng)%IendR(tile) + JstrR=BOUNDS(ng)%JstrR(tile) + JendR=BOUNDS(ng)%JendR(tile) +! + rectangular=.FALSE. +! + self%Xgrid=0.0_r8 + self%Ygrid=0.0_r8 +! + CALL hindices (ng, LBi, UBi, LBj, UBj, & + & IstrR, IendR, JstrR, JendR, & + & GRID(ng)%angler, GRID(ng)%lonr, GRID(ng)%latr, & + & 1, self%nlocs, 1, 1, & + & 1, self%nlocs, 1, 1, & + & self%lon, self%lat, & + & self%Xgrid, self%Ygrid, & + & spval, rectangular) + +#ifdef DISTRIBUTE +! +! Collect fractional coordinates. +! + CALL mp_assemble (ng, model, self%nlocs, spval, self%Xgrid) + CALL mp_assemble (ng, model, self%nlocs, spval, self%Ygrid) +#endif +! + RETURN + END SUBROUTINE obs_data_frac_coords +! +!----------------------------------------------------------------------- +! If not available, it computes observation object fractional +! coordinates. +! + SUBROUTINE obs_data_populate_ioda (self, ng, model, mvar, IOtype) +! + CLASS (obs_data), intent(inout) :: self ! observation object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: mvar ! number of variables + integer, intent(in ) :: IOtype ! NetCDF IO type +! + logical :: Loaded, isDayUnits + integer :: i, lstr, ncount + real (r8), dimension(4) :: Tmin, Tmax + character (len=22), dimension(4) :: Dmin, Dmax + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_data_populate_ioda" +! + SourceFile=MyFile +! + ! Read in observation variables in Group MetaData. +! + IF (Master) WRITE (stdout,10) TRIM(self%ncname_inp) +! + IF (IOtype.eq.io_nf90) THEN + CALL netcdf_inq_var (ng, model, self%ncname_inp, & + GrpName = 'MetaData') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + DO i=1,n_var + Loaded=.FALSE. + SELECT CASE (TRIM(var_name(i))) + CASE ('dateTime') + CALL netcdf_get_time (ng, model, self%ncname_inp, & + & var_name(i), Rclock%DateNumber, & + & self%time, & + & GrpName = 'MetaData', & + & min_val = Tmin(1), & + & max_val = Tmax(1)) + Loaded=.TRUE. + ncount=SIZE(self%time) + Tmin(1)=Tmin(1)+Rclock%DateNumber(2) + Tmax(1)=Tmax(1)+Rclock%DateNumber(2) + CALL datestr (Tmin(1), .FALSE., Dmin(1)) + CALL datestr (Tmax(1), .FALSE., Dmax(1)) + CASE ('depth') + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%depth, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%depth) + CASE ('latitude') + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%lat, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%lat) + CASE ('longitude') + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%lon, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%lon) + CASE ('provenance') + CALL netcdf_get_ivar (ng, model, self%ncname_inp, & + & var_name(i), self%provenance, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%provenance) + CASE ('stateID') + CALL netcdf_get_ivar (ng, model, self%ncname_inp, & + & var_name(i), self%stateID, & + & GrpName = 'MetaData') + CASE ('surveyIndex') + CALL netcdf_get_ivar (ng, model, self%ncname_inp, & + & var_name(i), self%surveyIndex, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%surveyIndex) + CASE ('surveyTime') + CALL netcdf_get_time (ng, model, self%ncname_inp, & + & var_name(i), Rclock%DateNumber, & + & self%surveyTime, & + & GrpName = 'MetaData', & + & min_val = Tmin(2), & + & max_val = Tmax(2)) + Loaded=.TRUE. + ncount=SIZE(self%surveyTime) + Tmin(2)=Tmin(2)+Rclock%DateNumber(2) + Tmax(2)=Tmax(2)+Rclock%DateNumber(2) + CALL datestr (Tmin(2), .FALSE., Dmin(2)) + CALL datestr (Tmax(2), .FALSE., Dmax(2)) + CASE ('dateTimeAverageBegin') + CALL netcdf_get_time (ng, model, self%ncname_inp, & + & var_name(i), Rclock%DateNumber, & + & self%TimeStr, & + & GrpName = 'MetaData', & + & min_val = Tmin(3), & + & max_val = Tmax(3)) + Loaded=.TRUE. + ncount=SIZE(self%TimeStr) + Tmin(3)=Tmin(3)+Rclock%DateNumber(2) + Tmax(3)=Tmax(3)+Rclock%DateNumber(2) + CALL datestr (Tmin(3), .FALSE., Dmin(3)) + CALL datestr (Tmax(3), .FALSE., Dmax(3)) + CASE ('dateTimeAverageEnd') + CALL netcdf_get_time (ng, model, self%ncname_inp, & + & var_name(i), Rclock%DateNumber, & + & self%TimeEnd, & + & GrpName = 'MetaData', & + & min_val = Tmin(4), & + & max_val = Tmax(4)) + Loaded=.TRUE. + ncount=SIZE(self%TimeEnd) + Tmin(4)=Tmin(4)+Rclock%DateNumber(2) + Tmax(4)=Tmax(4)+Rclock%DateNumber(2) + CALL datestr (Tmin(4), .FALSE., Dmin(4)) + CALL datestr (Tmax(4), .FALSE., Dmax(4)) + CASE ('spatialAverage') + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%spatialAverage, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%spatialAverage) + CASE ('x_grid') + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%Xgrid, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%Xgrid) + CASE ('y_grid') + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%Ygrid, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%Ygrid) + CASE ('z_grid') + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%Zgrid, & + & GrpName = 'MetaData') + Loaded=.TRUE. + ncount=SIZE(self%Zgrid) + END SELECT + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + IF (Master.and.Loaded) WRITE (stdout,20) 'MetaData', & + & TRIM(var_name(i)), ncount + END DO + END IF +! +! Read the observation variables in Group ObsError. If the IODA file is +! created with the "roms2ioda.m" script, the observation error is in +! terms of standard deviations and has the same units as its value. +! + IF (IOtype.eq.io_nf90) THEN + CALL netcdf_inq_var (ng, model, self%ncname_inp, & + GrpName = 'ObsError') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + DO i=1,n_var + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%error(:,i), & + & GrpName = 'ObsError') + self%error(:,i)=self%error(:,i)*self%error(:,i) + ncount=SIZE(self%error,1) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + IF (Master) WRITE (stdout,30) 'ObsError', TRIM(var_name(i)), & + & ncount, self%stateID(i) + END DO + END IF +! +! Read in observation variables in Group ObsValue. +! + IF (IOtype.eq.io_nf90) THEN + CALL netcdf_inq_var (ng, model, self%ncname_inp, & + GrpName = 'ObsValue') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + lstr=0 + DO i=1,n_var + CALL netcdf_get_fvar (ng, model, self%ncname_inp, & + & var_name(i), self%value(:,i), & + & GrpName = 'ObsValue') + lstr=MAX(lstr, LEN_TRIM(var_name(i))) + ncount=SIZE(self%value,1) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + IF (Master) WRITE (stdout,30) 'ObsValue', TRIM(var_name(i)), & + & ncount, self%stateID(i) + END DO + END IF +! +! Load observation NetCDF variable name(s). +! + IF (.not.allocated(self%vars)) THEN + allocate ( character(LEN=lstr) :: self%vars(mvar) ) + END IF + DO i=1,n_var + self%vars(i)=TRIM(var_name(i)) + END DO +! +! Compute statistics. +! + isDayUnits=.FALSE. + CALL self%stats (isDayUnits) +! +! Report information. +! + IF (Master) THEN + WRITE (stdout,'(1x)') + DO i=1,mvar + WRITE (stdout,40) TRIM(self%vars(i)), & + & self%value_min(i), self%value_max(i), & + & self%value_avg(i), self%value_hash(i), & + & self%error_min(i), self%error_max(i), & + & self%error_avg(i) + WRITE (stdout,50) 'DateTime Range: ', & + & TRIM(Dmin(1)), TRIM(Dmax(1)) + WRITE (stdout,50) 'SurveyTime Range: ', & + & TRIM(Dmin(2)), TRIM(Dmax(2)) + END DO + END IF +! + 10 FORMAT (/,2x,'ROMS_OBS - Processing: ',a) + 20 FORMAT (t23,'Group: ',a,'::',a,t75,'Count = ',i0) + 30 FORMAT (t23,'Group: ',a,'::',a,t75,'Count = ',i0,t90,'ID = ',i0) + 40 FORMAT (t21,'- ',a,/,t23,'(ValMin = ',1p,e12.5,' ValMax = ', & + & 1p,e12.5,' ValAvg = ',1p,e12.5,' CheckSum = ',i0,')', & + & /,t23,'(ErrMin = ',1p,e12.5,' ErrMax = ',1p,e12.5, & + & ' ErrAvg = ',1p,e12.5,')') + 50 FORMAT (t23,a,a,' to ',a) +! + RETURN + END SUBROUTINE obs_data_populate_ioda +! +!----------------------------------------------------------------------- +! It sets the background quality control threshold in terms of the +! squared number of standard deviations to use for accepting or +! rejecting observations according specified input parameters. +! + SUBROUTINE obs_data_qc_threshold (self, ng, model, ivar, Bthresh) +! + CLASS (obs_data), intent(in ) :: self ! observation object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: ivar ! variable counter + real (r8), intent(out ) :: Bthresh(:) ! threshold +! + integer :: i, iloc +! +! Background quality control in terms of state variable indices. +! + IF (bgqc_type(ng).eq.1) THEN + DO i=1,MstateVar + IF (self%stateID(ivar).eq.i) THEN + Bthresh=S_bgqc(i,ng) + EXIT + END IF + END DO +! +! Background quality control in term of observation provenance. +! + ELSE IF (bgqc_type(ng).eq.2) THEN + DO iloc=1,self%nlocs + Bthresh(iloc)=bgqc_large ! do not reject + DO i=1,Nprovenance(ng) + IF (self%provenance(iloc).eq.Iprovenance(i,ng)) THEN + Bthresh(iloc)=P_bgqc(i,ng) + EXIT + END IF + END DO + END DO + END IF +! + RETURN + END SUBROUTINE obs_data_qc_threshold +! +!----------------------------------------------------------------------- +! It computes and reports observation object statistics. +! + SUBROUTINE obs_data_stats (self, isDayUnits) +! + CLASS (obs_data), intent(inout) :: self ! observation object + logical, intent(in ) :: isDayUnits ! days or seconds +! + integer (i8b) :: checksum + integer :: i + real (r8) :: Tmin, Tmax +! + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_data_stats" +! + SourceFile=MyFile +! +! Compute observation statistics. +! + self%time_min=MINVAL(self%time) + self%time_max=MAXVAL(self%time) +! + IF (isDayUnits) THEN + Tmin=self%time_min+Rclock%DateNumber(1) + Tmax=self%time_max+Rclock%DateNumber(1) + CALL datestr (Tmin, .TRUE., self%date_min) + CALL datestr (Tmax, .TRUE., self%date_max) + ELSE + Tmin=self%time_min+Rclock%DateNumber(2) + Tmax=self%time_max+Rclock%DateNumber(2) + CALL datestr (Tmin, .FALSE., self%date_min) + CALL datestr (Tmax, .FALSE., self%date_max) + END IF +! + DO i=1,self%nvars + self%error_avg(i)=SUM(self%error(:,i))/REAL(self%nlocs, r8) + self%error_min(i)=MINVAL(self%error(:,i)) + self%error_max(i)=MAXVAL(self%error(:,i)) + CALL get_hash (self%error(:,i), self%nlocs, checksum, .FALSE.) + self%error_hash(i)=checksum +! + self%value_avg(i)=SUM(self%value(:,i))/REAL(self%nlocs, r8) + self%value_min(i)=MINVAL(self%value(:,i)) + self%value_max(i)=MAXVAL(self%value(:,i)) + CALL get_hash (self%value(:,i), self%nlocs, checksum, .FALSE.) + self%value_hash(i)=checksum + END DO +! + RETURN + END SUBROUTINE obs_data_stats +! +!<><><><><><><><><><><><><><><><><><><><><><><><> CLASS OBS_POOL <><><> +! +! It creates a set observation-type objects. A single or multiple +! data assimilation observation files are allowed. In IODA, we have +! a file for each observation type. +! + SUBROUTINE obs_pool_create (self, ng, model, nfiles) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: nfiles ! number of files +! + logical :: isIODA +# ifdef DISTRIBUTE + integer, dimension(2) :: ibuffer +# endif + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_create" +! + SourceFile=MyFile +! +! Inquire observation file(s) to determine the size of the observation +! pool vector and allocate. +! + CALL self%size (ng, model, nfiles) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Read in observation files, allocate arrays in pool structure, and +! populate data into object. +! + CALL self%nc_read (ng, model, nfiles) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Count total number of observations. +! + CALL self%tally () +! +! Create output IODA files containing processed observations plus H(x) +! operators. The files are created serially by the output thread. +! + isIODA=nfiles.gt.1 + CALL self%nc_create (ng, model, isIODA) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Write input observation data into output IODA files. +! + CALL self%nc_write (ng, model, isIODA) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + RETURN + END SUBROUTINE obs_pool_create +! +!----------------------------------------------------------------------- +! It destroys a set observation-type objects. +! + SUBROUTINE obs_pool_destroy (self) +! + CLASS (obs_pool), intent(inout) :: self ! observation set +! + integer :: i +! +! Deallocate observation collection object. +! + DO i=1,SIZE(self%pool) + CALL self%pool(i)%destroy () + END DO + deallocate (self%pool) +! + RETURN + END SUBROUTINE obs_pool_destroy +! +!----------------------------------------------------------------------- +! Given internal observation name, it returns an observation data +! object pointer. +! + SUBROUTINE obs_pool_get (self, name, field) +! + CLASS (obs_pool), target, intent(in ) :: self ! observation set + character (len=*), intent(in ) :: name ! observation name + TYPE (obs_data), pointer, intent(out) :: field ! data pointer +! + integer :: iobs + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_get" +! + SourceFile=MyFile +! +! Get requested field pointer. +! + DO iobs=1,SIZE(self%pool) + IF (TRIM(name).eq.self%pool(iobs)%name) THEN + field => self%pool(iobs) + RETURN + END IF + END DO +! +! Error observation data was not found. +! + IF (Master) THEN + WRITE (stdout,10) TRIM(name) + 10 FORMAT (/, 'ROMS_OBS - obs_pool::get: cannot find field ',a) + END IF + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + END SUBROUTINE obs_pool_get +! +!----------------------------------------------------------------------- +! It inquires about available observation for current model time, and +! their starting and ending indices on pool set. +! + FUNCTION obs_pool_has (self, ng, model) RESULT (foundit) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! observation name +! + logical :: foundit + integer :: Nstr, Nend, iobs, i + integer :: nlocs, nsurvey + real (r8) :: Tstr, Tend +! +! Check if requested observation name exists in the pool object. +! + foundit=.FALSE. + Tstr=time(ng)-0.5_r8*dt(ng) + Tend=time(ng)+0.5_r8*dt(ng) +! + DO iobs=1,SIZE(self%pool) + nlocs =self%pool(iobs)%nlocs + nsurvey=self%pool(iobs)%nsurvey + self%pool(iobs)%NstrObs=0 + self%pool(iobs)%NendObs=0 +! + IF (model.eq.iADM) THEN ! backward search + IF (self%pool(iobs)%IsTimeAveraged) THEN + self%pool(iobs)%NstrObs=1 + self%pool(iobs)%NendObs=nlocs + foundit=.TRUE. + ELSE + DO i=nsurvey,1,-1 + IF ((Tstr.le.self%pool(iobs)%surveyTime(i)).and. & + & (self%pool(iobs)%surveyTime(i).lt.Tend)) THEN + Nstr=self%pool(iobs)%surveyIndex(i) + IF (i.ne.1) THEN + Nend=self%pool(iobs)%surveyIndex(i-1)-1 + ELSE + Nend=self%pool(iobs)%surveyIndex(i) + END IF + self%pool(iobs)%NstrObs=Nstr + self%pool(iobs)%NendObs=Nend + foundit=.TRUE. + CYCLE + END IF + END DO + END IF + ELSE ! forward search + IF (self%pool(iobs)%IsTimeAveraged) THEN + self%pool(iobs)%NstrObs=1 + self%pool(iobs)%NendObs=nlocs + foundit=.TRUE. + ELSE + DO i=1,nsurvey + IF ((Tstr.le.self%pool(iobs)%surveyTime(i)).and. & + & (self%pool(iobs)%surveyTime(i).lt.Tend)) THEN + Nstr=self%pool(iobs)%surveyIndex(i) + IF (i.ne.nsurvey) THEN + Nend=self%pool(iobs)%surveyIndex(i+1)-1 + ELSE + Nend=self%pool(iobs)%surveyIndex(i) + END IF + self%pool(iobs)%NstrObs=Nstr + self%pool(iobs)%NendObs=Nend + foundit=.TRUE. + CYCLE + END IF + END DO + END IF + END IF + END DO +! + RETURN + END FUNCTION obs_pool_has +! +!----------------------------------------------------------------------- +! It allocates the observation arrays in the appropiate pool vector +! element, and then reads the specified IODA observation file to +! populate the data. +! + SUBROUTINE obs_pool_load_ioda (self, ng, model, mobs, msurvey, & + & mvar, IOtype, ncname) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: mobs ! observations number + integer, intent(in ) :: msurvey ! time surveys + integer, intent(in ) :: mvar ! number of variables + integer, intent(in ) :: IOtype ! NetCDF IO type + character (len=*), intent(in ) :: ncname ! NetCDF filename +! + logical :: haveSST, haveSSS, haveVector + logical :: IsAreaAveraged, IsTimeAveraged + integer, dimension(mvar) :: myStateID + integer :: Idot, Islash + integer :: i, iobs, lstr, myID + integer :: mvatt +! + character (len=40) :: poolname, varname(mvar) + character (len=80) :: string + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_load_ioda" +! + SourceFile=MyFile +! +! Get the associated state variable ID. +! + haveSST=.FALSE. + haveSSS=.FALSE. + IsAreaAveraged=.FALSE. + IsTimeAveraged=.FALSE. +! + SELECT CASE (IOtype) + CASE (io_nf90) + CALL netcdf_inq_var (ng, model, TRIM(ncname), & + GrpName = 'MetaData') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + DO i=1,n_var + SELECT CASE (TRIM(var_name(i))) + CASE ('dateTimeAverageBegin', 'dateTimeAverageEnd') + IsTimeAveraged=.TRUE. + CASE ('spatialAverage') + IsAreaAveraged=.TRUE. + END SELECT + END DO +! + CALL netcdf_get_ivar (ng, model, TRIM(ncname), & + & 'stateID', myStateID, & + & GrpName = 'MetaData') + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + CALL netcdf_inq_var (ng, model, TRIM(ncname), & + & myVarName = 'stateID', & + & GrpName = 'MetaData', & + & nVarAtt = mvatt) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + + DO i=1,mvatt + IF (TRIM(var_Aname(i)).eq.'surface_level') THEN + IF (ANY(myStateID.eq.6)) haveSST=.TRUE. + IF (ANY(myStateID.eq.7)) haveSSS=.TRUE. + END IF + END DO + + CASE DEFAULT + IF (Master) WRITE (stdout,10) IOtype + exit_flag=3 + END SELECT + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Determine pool vector element to process, U- and V-velocity. +! + haveVector=.FALSE. + IF (mvar.gt.1) THEN + IF (ANY(myStateID.eq.4).and.ANY(myStateID.eq.5)) THEN + haveVector=.TRUE. + DO i=1,SIZE(self%stateID) + IF (self%stateID(i).eq.45) THEN + iobs=i + myID=45 + EXIT + END IF + END DO + END IF + ELSE + DO i=1,SIZE(self%stateID) + IF ((haveSST.and.(self%stateID(i).eq.60)).or. & + & (haveSSS.and.(self%stateID(i).eq.70))) THEN + iobs=i + myID=self%stateID(i) + EXIT + ELSE IF (myStateID(1).eq.self%stateID(i)) THEN + iobs=i + myID=self%stateID(i) + EXIT + END IF + END DO + END IF +! +! Initialize scalar variables in observation pool object. +! + self%pool(iobs)%nlocs = mobs + self%pool(iobs)%nsurvey = msurvey + self%pool(iobs)%nvars = mvar + self%pool(iobs)%poolID = myID + self%pool(iobs)%IsAreaAveraged = IsAreaAveraged + self%pool(iobs)%IsTimeAveraged = IsTimeAveraged +! + IF (.not.allocated(self%pool(iobs)%ncname_inp)) THEN + lstr=LEN_TRIM(ncname) + allocate ( character(LEN=lstr) :: self%pool(iobs)%ncname_inp ) + self%pool(iobs)%ncname_inp = TRIM(ncname) + END IF +! + IF (.not.allocated(self%pool(iobs)%ncname_out)) THEN + Idot =INDEX(ncname,CHAR(46),BACK=.TRUE.)-1 + Islash=INDEX(ncname,CHAR(47),BACK=.TRUE.)+1 + string=ncname(Islash:Idot)//'_hofx.nc4' + lstr=LEN_TRIM(string) + allocate ( character(LEN=lstr) :: self%pool(iobs)%ncname_out ) + self%pool(iobs)%ncname_out = TRIM(string) + END IF +! +! Allocate pool vector element structure, Group MetaData. +! + IF (.not.allocated(self%pool(iobs)%provenance)) THEN + allocate ( self%pool(iobs)%provenance(mobs) ) + self%pool(iobs)%provenance = 0 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%lon)) THEN + allocate ( self%pool(iobs)%lon(mobs) ) + self%pool(iobs)%lon = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%lat)) THEN + allocate ( self%pool(iobs)%lat(mobs) ) + self%pool(iobs)%lat = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%depth)) THEN + allocate ( self%pool(iobs)%depth(mobs) ) + self%pool(iobs)%depth = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%time)) THEN + allocate ( self%pool(iobs)%time(mobs) ) + self%pool(iobs)%time = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + + IF (self%pool(iobs)%IsAreaAveraged) THEN + IF (.not.allocated(self%pool(iobs)%spatialAverage)) THEN + allocate ( self%pool(iobs)%spatialAverage(mvar) ) + self%pool(iobs)%spatialAverage=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + END IF + + IF (self%pool(iobs)%IsTimeAveraged) THEN + IF (.not.allocated(self%pool(iobs)%TimeStr)) THEN + allocate ( self%pool(iobs)%TimeStr(mobs) ) + self%pool(iobs)%TimeStr=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + IF (.not.allocated(self%pool(iobs)%TimeEnd)) THEN + allocate ( self%pool(iobs)%TimeEnd(mobs) ) + self%pool(iobs)%TimeEnd=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + END IF + + IF (.not.allocated(self%pool(iobs)%stateID)) THEN + allocate ( self%pool(iobs)%stateID(mvar) ) + self%pool(iobs)%stateID = 0 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%surveyIndex)) THEN + allocate ( self%pool(iobs)%surveyIndex(msurvey) ) + self%pool(iobs)%surveyIndex = 0 + Dmem(ng)=Dmem(ng)+REAL(msurvey,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%surveyTime)) THEN + allocate ( self%pool(iobs)%surveyTime(msurvey) ) + self%pool(iobs)%surveyTime = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(msurvey,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%Xgrid)) THEN + allocate ( self%pool(iobs)%Xgrid(mobs) ) + self%pool(iobs)%Xgrid = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%Ygrid)) THEN + allocate ( self%pool(iobs)%Ygrid(mobs) ) + self%pool(iobs)%Ygrid = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%Zgrid)) THEN + allocate ( self%pool(iobs)%Zgrid(mobs) ) + self%pool(iobs)%Zgrid = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs,r8) + END IF +! +! Allocate pool vector element structure, Group ObsError. +! + IF (.not.allocated(self%pool(iobs)%error)) THEN + allocate ( self%pool(iobs)%error(mobs,mvar) ) + self%pool(iobs)%error = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs*mvar,r8) + END IF +! +! Allocate pool vector element structure, Group ObsValue. +! + IF (.not.allocated(self%pool(iobs)%value)) THEN + allocate ( self%pool(iobs)%value(mobs,mvar) ) + self%pool(iobs)%value = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mobs*mvar,r8) + END IF +! +! Allocate statistics variables. +! + IF (.not.allocated(self%pool(iobs)%error_hash)) THEN + allocate ( self%pool(iobs)%error_hash(mvar) ) + self%pool(iobs)%error_hash=0_i8b + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_hash)) THEN + allocate ( self%pool(iobs)%value_hash(mvar) ) + self%pool(iobs)%value_hash=0_i8b + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%error_avg)) THEN + allocate ( self%pool(iobs)%error_avg(mvar) ) + self%pool(iobs)%error_avg=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_avg)) THEN + allocate ( self%pool(iobs)%value_avg(mvar) ) + self%pool(iobs)%value_avg=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%error_min)) THEN + allocate ( self%pool(iobs)%error_min(mvar) ) + self%pool(iobs)%error_min=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_min)) THEN + allocate ( self%pool(iobs)%value_min(mvar) ) + self%pool(iobs)%value_min=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%error_max)) THEN + allocate ( self%pool(iobs)%error_max(mvar) ) + self%pool(iobs)%error_max=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_max)) THEN + allocate ( self%pool(iobs)%value_max(mvar) ) + self%pool(iobs)%value_max=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mvar,r8) + END IF +! +! Allocate internal variable name(s). +! + SELECT CASE (self%stateID(iobs)) + CASE (1) + poolname='ADT' + varname(1)='ADT' + CASE (6) + poolname='temp' + varname(1)='temp' + CASE (7) + poolname='salt' + varname(1)='salt' + CASE (45) + poolname='uv_codar' + varname(1)='Ucodar' + Varname(2)='Vcodar' + CASE (60) + poolname='SST' + varname(1)='SST' + CASE (67) + poolname='TS' + varname(1)='temp' + varname(2)='salt' + CASE (70) + poolname='SSS' + varname(1)='SSS' + END SELECT +! + lstr=LEN_TRIM(poolname) + allocate ( character(LEN=lstr) :: self%pool(iobs)%name ) + self%pool(iobs)%name=TRIM(poolname) +! + lstr=0 + DO i=1,mvar + lstr=MAX(lstr, LEN_TRIM(varname(i))) + END DO + allocate ( character(LEN=lstr) :: self%pool(iobs)%vname(mvar) ) + DO i=1,mvar + self%pool(iobs)%vname(i)=TRIM(varname(i)) + END DO +! +! Read in IODA NetCDF file and populate observation data. +! + CALL self%pool(iobs)%populate_ioda (ng, model, mvar, IOtype) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + 10 FORMAT (' OBS_POOL_LOAD_IODA - Illegal output file type,', & + & ' io_type = ',i0,/,22x, & + & 'Check KeyWord ''OUT_LIB'' in ''roms.in''.') +! + RETURN + END SUBROUTINE obs_pool_load_ioda +! +!----------------------------------------------------------------------- +! It allocates the observation arrays in the appropiate pool vector +! element, and then reads the specified native observation file to +! populate the data. +! + SUBROUTINE obs_pool_load_native (self, ng, model, mobs, msurvey, & + & IOtype, ncname) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: mobs ! observations number + integer, intent(in ) :: msurvey ! time surveys + integer, intent(in ) :: IOtype ! NetCDF IO type + character (len=*), intent(in ) :: ncname ! NetCDF filename +! + integer, dimension(5+NT(ng)) :: mvar + integer, dimension(mobs) :: obs_type + integer :: i, id, iobs, lstr, mSSS, mSST + integer :: Lsur, mymvar, mysize + real (r8), dimension(mobs) :: obs_Zgrid + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_load_native" +! + SourceFile=MyFile +! +! Read in "obs_type" variable to determine the observed variables and +! its IDs. +! + SELECT CASE (IOtype) + CASE (io_nf90) + CALL netcdf_get_ivar (ng, model, ncname, & + & 'obs_type', obs_type) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + CALL netcdf_get_fvar (ng, model, ncname, & + & 'obs_Zgrid', obs_Zgrid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + + CASE DEFAULT + IF (Master) WRITE (stdout,10) IOtype + exit_flag=3 + END SELECT +! +! Determine the number of observations per control vector variable. +! + Lsur=N(ng) + mSSS=0 + mSST=0 + mvar=0 +! + DO i=1,mobs + id=obs_type(i) + IF (id.eq.6) THEN + IF (INT(obs_Zgrid(i)).eq.Lsur) THEN + mSST=mSST+1 + ELSE + mvar(id)=mvar(id)+1 + END IF + ELSE IF (id.eq.7) THEN + IF (INT(obs_Zgrid(i)).eq.Lsur) THEN + mSSS=mSSS+1 + ELSE + mvar(id)=mvar(id)+1 + END IF + ELSE + mvar(id)=mvar(id)+1 + END IF + END DO +! +! Allocate observation pool vector object arrays and initialize +! scalars. +! + DO iobs=1,SIZE(self%stateID) + id=self%stateID(iobs) + IF (id.eq.45) THEN ! U-, V-Velocity + mysize=mvar(4) + mymvar=2 + ELSE IF (id.eq.60) THEN ! SST + mysize=mSST + mymvar=1 + ELSE IF (id.eq.70) THEN ! SSS + mysize=mSSS + mymvar=1 + ELSE + mysize=mvar(id) ! ADT/SSH, T, S + mymvar=1 + END IF +! + self%pool(iobs)%nlocs = mysize + self%pool(iobs)%nvars = mymvar + self%pool(iobs)%poolID = self%stateID(iobs) +! + IF (.not.allocated(self%pool(iobs)%ncname_inp)) THEN + lstr=LEN_TRIM(ncname) + allocate ( character(LEN=lstr) :: self%pool(iobs)%ncname_inp ) + self%pool(iobs)%ncname_inp = TRIM(ncname) + END IF +! + IF (.not.allocated(self%pool(iobs)%provenance)) THEN + allocate ( self%pool(iobs)%provenance(mysize) ) + self%pool(iobs)%provenance = 0 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%lon)) THEN + allocate ( self%pool(iobs)%lon(mysize) ) + self%pool(iobs)%lon = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%lat)) THEN + allocate ( self%pool(iobs)%lat(mysize) ) + self%pool(iobs)%lat = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%depth)) THEN + allocate ( self%pool(iobs)%depth(mysize) ) + self%pool(iobs)%depth = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%time)) THEN + allocate ( self%pool(iobs)%time(mysize) ) + self%pool(iobs)%time = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%stateID)) THEN + allocate ( self%pool(iobs)%stateID(mymvar) ) + self%pool(iobs)%stateID = 0 + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%Xgrid)) THEN + allocate ( self%pool(iobs)%Xgrid(mysize) ) + self%pool(iobs)%Xgrid = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%Ygrid)) THEN + allocate ( self%pool(iobs)%Ygrid(mysize) ) + self%pool(iobs)%Ygrid = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%Zgrid)) THEN + allocate ( self%pool(iobs)%Zgrid(mysize) ) + self%pool(iobs)%Zgrid = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%error)) THEN + allocate ( self%pool(iobs)%error(mysize,mymvar) ) + self%pool(iobs)%error = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize*mymvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%value)) THEN + allocate ( self%pool(iobs)%value(mysize,mymvar) ) + self%pool(iobs)%value = 0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mysize*mymvar,r8) + END IF +! +! Allocate statistics variables. +! + IF (.not.allocated(self%pool(iobs)%error_hash)) THEN + allocate ( self%pool(iobs)%error_hash(mymvar) ) + self%pool(iobs)%error_hash=0_i8b + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_hash)) THEN + allocate ( self%pool(iobs)%value_hash(mymvar) ) + self%pool(iobs)%value_hash=0_i8b + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%error_avg)) THEN + allocate ( self%pool(iobs)%error_avg(mymvar) ) + self%pool(iobs)%error_avg=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_avg)) THEN + allocate ( self%pool(iobs)%value_avg(mymvar) ) + self%pool(iobs)%value_avg=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%error_min)) THEN + allocate ( self%pool(iobs)%error_min(mymvar) ) + self%pool(iobs)%error_min=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_min)) THEN + allocate ( self%pool(iobs)%value_min(mymvar) ) + self%pool(iobs)%value_min=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + + IF (.not.allocated(self%pool(iobs)%error_max)) THEN + allocate ( self%pool(iobs)%error_max(mymvar) ) + self%pool(iobs)%error_max=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + IF (.not.allocated(self%pool(iobs)%value_max)) THEN + allocate ( self%pool(iobs)%value_max(mymvar) ) + self%pool(iobs)%value_max=0.0_r8 + Dmem(ng)=Dmem(ng)+REAL(mymvar,r8) + END IF + + END DO +! +! Read in native NetCDF file and populate obervation data. +! + CALL self%populate_native (ng, model, mobs, IOTYPE, ncname, & + & obs_type, obs_Zgrid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + 10 FORMAT (' OBS_POOL_LOAD_NATIVE - Illegal output file type,', & + & ' io_type = ',i0,/,24x, & + & 'Check KeyWord ''OUT_LIB'' in ''roms.in''.') +! + RETURN + END SUBROUTINE obs_pool_load_native +! +!----------------------------------------------------------------------- +! It creates ouput IODA-type observations plus H(x) variables NetCDF4 +! enhanced file(s) cloning input observation. Thus, it inquires input +! IODA-type observation files to copy their schema, and adds Groups +! associated with the H(x) operator. +! + SUBROUTINE obs_pool_nc4_clone (self, ng, model) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + integer :: ncid_inp, ncid_out, npool + integer :: dimid, grpid, varid, vtype + integer :: indx, gindex, qcindex + integer :: i, iobs, j, k, kc + integer :: lstr, vlstr + integer :: ngroups, nvars, nvdim + integer, dimension(5) :: vdims +# ifdef DISTRIBUTE + integer, dimension(2) :: ibuffer +# endif +! + character (len=80) :: string + +# ifdef VERIFICATION + character (len=15), dimension(2) :: new_group = & + & (/ 'ObsVetting ', & + & 'hofx ' /) +# else + character (len=15), dimension(7) :: new_group = & + & (/ 'ObsVetting ', & + & 'BackgroundError', & + & 'hofxInitial ', & + & 'hofxFinal ', & + & 'Innovation ', & + & 'Increment ', & + & 'Residual ' /) +# endif + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_nc4_clone" +! + SourceFile=MyFile +! +! Loop over all available files. +! + npool=SIZE(self%pool) + IF (Master) WRITE (stdout,'(1x)') +! + FILE_LOOP : DO iobs=1,npool +! +! Open input observation file. +! + CALL netcdf_open (ng, model, self%pool(iobs)%ncname_inp, 0, & + & ncid_inp) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Inquire about input file dimensions and format. +! + CALL netcdf_get_dim (ng, model, self%pool(iobs)%ncname_inp, & + & ncid = ncid_inp) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Inquire about input file groups. +! + IF (ncformat.eq.nf90_format_netcdf4) THEN + CALL netcdf_get_grp (ng, model, self%pool(iobs)%ncname_inp, & + & ncid = ncid_inp) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + ELSE + IF (Master) WRITE (stdout,10) ncformat, & + & self%pool(iobs)%ncname_inp + exit_flag=5 + RETURN + END IF +! +! Inquire about the variables. +! + CALL netcdf_inq_var (ng, model, self%pool(iobs)%ncname_inp, & + & ncid = ncid_inp) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Allocate ouput NetCDF group structure in pool object. +! + ngroups=n_grp+SIZE(new_group) + self%pool(iobs)%ngroups=ngroups + IF (.not.allocated(self%pool(iobs)%group)) THEN + allocate ( self%pool(iobs)%group(ngroups) ) + END IF +! +!----------------------------------------------------------------------- +! Copy NetCDF4 file schema (serial, only output thread). +!----------------------------------------------------------------------- +! + DEFINE : IF ((ncformat.eq.nf90_format_netcdf4).and. & + & OutThread) THEN +! +! Create NetCDF4 file. +! + IF (nc_error(nf90_create(self%pool(iobs)%ncname_out, & + & nf90_netcdf4, ncid_out), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + self%pool(iobs)%ncID=ncid_out + WRITE (stdout,20) ng, self%pool(iobs)%ncname_out +! +! Define dimensions. +! + DO i=1,n_dim + IF (nc_error(nf90_def_dim(ncid_out, TRIM(dim_name(i)), & + & dim_size(i), dimid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END DO +! +! Define variables. +! + IF (n_grp.gt.0) THEN + DO k=1,n_grp + nvars=n_gvar(k) + IF (nc_error(nf90_def_grp(ncid_out, TRIM(grp_name(k)), & + & grpid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + self%pool(iobs)%group(k)%gid=grpid + IF (.not.allocated(self%pool(iobs)%group(k)%name)) THEN + lstr=LEN_TRIM(grp_name(k)) + allocate ( character(LEN=lstr) :: & + & self%pool(iobs)%group(k)%name ) + self%pool(iobs)%group(k)%name=TRIM(grp_name(k)) + END IF + self%pool(iobs)%group(k)%nvars=nvars +! + IF (TRIM(grp_name(k)).eq.'ObsValue') THEN + gindex=k ! used to duplicate variables in new groups + ELSE IF (TRIM(grp_name(k)).eq.'PreQC') THEN + qcindex=k ! used to duplicate interger flags + END IF +! + vlstr=0 + DO j=1,nvars + vlstr=MAX(vlstr, LEN_TRIM(grp_vname(j,k))) + END DO +! + vdims=0 + DO j=1,nvars + nvdim=grp_nvdim(j,k) + vdims(1:nvdim)=grp_vdim(1:nvdim,j,k) + vtype=grp_vtype(j,k) + IF (nc_error(nf90_def_var(grpid, TRIM(grp_vname(j,k)), & + & vtype, vdims(1:nvdim), & + & varid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (.not.allocated(self%pool(iobs)%group(k)%vid)) THEN + allocate ( self%pool(iobs)%group(k)%vid(nvars) ) + self%pool(iobs)%group(k)%vid=0 + END IF + self%pool(iobs)%group(k)%vid(j)=varid +! + IF (.not.allocated(self%pool(iobs)%group(k)%vname)) THEN + allocate ( character(LEN=vlstr) :: & + & self%pool(iobs)%group(k)%vname(nvars) ) + END IF + self%pool(iobs)%group(k)%vname(j)=TRIM(grp_vname(j,k)) +! + DO i=1,grp_nvatt(j,k) + IF (nc_error(nf90_copy_att(grp_id(k), grp_vid(j,k), & + & TRIM(grp_aname(i,j,k)), & + & grpid, varid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END DO + END DO + END DO + ELSE + WRITE (stdout,30) n_grp, self%pool(iobs)%ncname_out + exit_flag=5 + RETURN + END IF +! +! Add new groups: hofx_initial, hofx_final, innovation, increment, and +! residual. +! + DO k=1,SIZE(new_group) + IF (nc_error(nf90_def_grp(ncid_out, TRIM(new_group(k)), & + & grpid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (k.eq.1) THEN + indx=qcindex ! integer variables like PreQC + ELSE + indx=gindex ! float variables like ObsValue + END IF + nvars=n_gvar(indx) +! + kc=n_grp+k + self%pool(iobs)%group(kc)%gid=grpid + IF (.not.allocated(self%pool(iobs)%group(kc)%name)) THEN + lstr=LEN_TRIM(new_group(k)) + allocate ( character(LEN=lstr) :: & + & self%pool(iobs)%group(kc)%name ) + self%pool(iobs)%group(kc)%name=TRIM(new_group(k)) + END IF + self%pool(iobs)%group(kc)%nvars=n_gvar(indx) +! + vlstr=0 + DO j=1,nvars + vlstr=MAX(vlstr, LEN_TRIM(grp_vname(j,indx))) + END DO +! + IF (.not.allocated(self%pool(iobs)%group(kc)%vid)) THEN + allocate ( self%pool(iobs)%group(kc)%vid(nvars) ) + self%pool(iobs)%group(kc)%vid=0 + END IF + IF (.not.allocated(self%pool(iobs)%group(kc)%vname)) THEN + allocate ( character(LEN=vlstr) :: & + & self%pool(iobs)%group(kc)%vname(nvars) ) + END IF +! + vdims=0 + DO j=1,nvars + nvdim=grp_nvdim(j,indx) + vdims(1:nvdim)=grp_vdim(1:nvdim,j,indx) + vtype=grp_vtype(j,indx) + IF (nc_error(nf90_def_var(grpid, TRIM(grp_vname(j,indx)), & + & vtype, vdims(1:nvdim), varid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + self%pool(iobs)%group(kc)%vid(j)=varid + self%pool(iobs)%group(kc)%vname(j)=TRIM(grp_vname(j,indx)) +! + DO i=1,grp_nvatt(j,indx) + IF (TRIM(grp_aname(i,j,indx)).eq.'long_name') THEN + SELECT CASE (k) + CASE (1) + string='Observation screening flag, '// & + & '0:reject and 1:accept' + CASE (2) + string='background error at observation locations' + CASE (3) + string='model background at observation locations' + CASE (4) + string='model analysis at observation locations' + CASE (5) + string='observation minus background' + CASE (6) + string='analysis minus background' + CASE (7) + string='observation minus analysis' + END SELECT + IF (nc_error(nf90_put_att(grpid, varid, 'long_name', & + & TRIM(string)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + ELSE + IF (nc_error(nf90_copy_att(grp_id(indx), & + & grp_vid(j,indx), & + & TRIM(grp_aname(i,j,indx)), & + & grpid, varid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END IF + END DO + END DO + END DO +! +! Copy global attributes. +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'title', TRIM(title)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + DO i=1,n_gatt + IF (nc_error(nf90_inq_attname(ncid_inp, nf90_global, i, & + & string), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + SELECT CASE (TRIM(string)) + CASE ('history') + WRITE (history,'(a,1x,a,", ",a)') 'ROMS, Version', & + & TRIM(version), & + & TRIM(date_str) + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & TRIM(string), TRIM(history)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + CASE ('description') + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'description', & + & 'ROMS 4D-Var observations and H(x) IODA file'), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + CASE ('sourceFile', 'sourceFiles') + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'sourceFile', & + & TRIM(self%pool(iobs)%ncname_inp)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + CASE DEFAULT + IF (nc_error(nf90_copy_att(ncid_inp, nf90_global, & + & TRIM(string), & + & ncid_out, nf90_global), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END SELECT + END DO +! +! End Definition. +! + IF (nc_error(nf90_enddef(ncid_out), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! +! Close output to syncronize to disk and allow parallel access. +! + IF (nc_error(nf90_close(ncid_out), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END IF DEFINE + +# ifdef DISTRIBUTE +! +! Broadcast error flags. +! + ibuffer(1)=exit_flag + ibuffer(2)=ioerror + CALL mp_bcasti (ng, model, ibuffer) + exit_flag=ibuffer(1) + ioerror=ibuffer(2) +# endif + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Close input file. +! + CALL netcdf_close (ng, model, ncid_inp, & + & self%pool(iobs)%ncname_inp, .FALSE.) +# ifdef DISTRIBUTE +! +! In distribute-memory applications, only the master process have the +! ouput file information and allocated the "nc_group" structure. Thus, +! inquire created output file and allocate values for other processes. +! + CALL netcdf_get_grp (ng, model, self%pool(iobs)%ncname_out) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + IF (MyRank.ne.MyMaster) THEN + IF (.not.allocated(self%pool(iobs)%group)) THEN + allocate ( self%pool(iobs)%group(n_grp) ) + END IF + DO k=1,n_grp + nvars=n_gvar(k) + IF (.not.allocated(self%pool(iobs)%group(k)%name)) THEN + lstr=LEN_TRIM(grp_name(k)) + allocate ( character(LEN=lstr) :: & + & self%pool(iobs)%group(k)%name ) + self%pool(iobs)%group(k)%name=TRIM(grp_name(k)) + END IF + self%pool(iobs)%group(k)%nvars=nvars +! + vlstr=0 + DO j=1,nvars + vlstr=MAX(vlstr, LEN_TRIM(grp_vname(j,k))) + END DO +! + IF (.not.allocated(self%pool(iobs)%group(k)%vid)) THEN + allocate ( self%pool(iobs)%group(k)%vid(nvars) ) + self%pool(iobs)%group(k)%vid=0 + END IF +! + IF (.not.allocated(self%pool(iobs)%group(k)%vname)) THEN + allocate ( character(LEN=vlstr) :: & + & self%pool(iobs)%group(k)%vname(nvars) ) + END IF +! + DO j=1,nvars + self%pool(iobs)%group(k)%vid(j)=grp_vid(j,k) + self%pool(iobs)%group(k)%vname(j)=TRIM(grp_vname(j,k)) + END DO + END DO + END IF +# endif + END DO FILE_LOOP + IF (Master) WRITE (stdout,'(1x)') +! + 10 FORMAT (/,'OBS_POOL_NC4_CLONE - non-IODA-type observation file,', & + & ' Format = ',i0,/,t21,'File: ',a) + 20 FORMAT (2x,'OBS_POOL - NC4_CLONE: creating H(x) file,', & + & t56,'Grid ',i2.2,': ',a) + 30 FORMAT (/,'OBS_POOL_NC4_CLONE - Cannot find Groups in ', & + & 'observation NetCDF file, n_grp = ',i0,/,t21,a) +! + RETURN + END SUBROUTINE obs_pool_nc4_clone +! +!----------------------------------------------------------------------- +! It creates ouput IODA-type observations plus H(x) variables NetCDF4 +! enhanced file(s) for the input native observation case. It defines +! the IODA-type enhanced NetCDF4 schema from scratch. +! + SUBROUTINE obs_pool_nc4_define (self, ng, model) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! + logical :: got_units, is2d_obs + integer :: DD, MM, YY, hi, mi, si + integer :: ngroups, npool + integer :: grpid, ncid_out + integer :: varid, vdims, vtype + integer :: i, ic, iobs, k, lstr + integer :: nlocs, nsurvey, mvars, nvars + integer, dimension(3) :: DimSize, DimID +# ifdef DISTRIBUTE + integer, dimension(2) :: ibuffer +# endif +! + character (len=8) :: YYMMDD + character (len=20) :: epoch + character (len=80) :: coord, myVarName, units + character (len=80) :: string + character (len=256) :: ncname, vlong +! + character (len=15), dimension(3) :: DimName = & + & (/ 'Location ', & + & 'nvars ', & + & 'survey ' /) +# ifdef VERIFICATION + character (len=15), dimension(5) :: FileGroups = & + & (/ 'MetaData ', & + & 'ObsError ', & + & 'ObsValue ', & + & 'ObsVetting ', & + & 'hofx ' /) +# else + character (len=15), dimension(10) :: FileGroups = & + & (/ 'MetaData ', & + & 'ObsError ', & + & 'ObsValue ', & + & 'ObsVetting ', & + & 'BackgroundError', & + & 'hofxInitial ', & + & 'hofxFinal ', & + & 'Innovation ', & + & 'Increment ', & + & 'Residual ' /) +# endif + character (len=15), dimension(11) :: MetaDataVars = & + & (/ 'dateTime ', & + & 'depth ', & + & 'latitude ', & + & 'longitude ', & + & 'provenance ', & + & 'stateID ', & + & 'surveyIndex ', & + & 'surveyTime ', & + & 'x_grid ', & + & 'y_grid ', & + & 'z_grid ' /) + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_nc4_define" +! + SourceFile=MyFile +! +! Loop over all available files. +! + npool=SIZE(self%pool) + IF (Master) WRITE (stdout,'(1x)') +! + CALL caldate (tdays(ng), yy_i=YY, mm_i=MM, dd_i=DD, & + & h_i=hi, m_i=mi, s_i=si) + CALL datenum (self%ref_datetime, YY, MM, DD, 0, 0, 0.0_r8) + WRITE (YYMMDD, '(i4.4,2(i2.2))') YY, MM, DD + WRITE (epoch, 10) YY, MM, DD, hi, mi, si +! + FILE_LOOP : DO iobs=1,npool +! +! Set output filename. +! + WRITE (ncname,20) lowercase(TRIM(MyAppCPP)), & + & lowercase(TRIM(self%pool(iobs)%name)), & + & YYMMDD + IF (.not.allocated(self%pool(iobs)%ncname_out)) THEN + lstr=LEN_TRIM(ncname) + allocate ( character(LEN=lstr) :: self%pool(iobs)%ncname_out ) + self%pool(iobs)%ncname_out = TRIM(ncname) + END IF +! +! Allocate ouput NetCDF group structure in pool object. +! + ngroups=SIZE(FileGroups) + self%pool(iobs)%ngroups=ngroups + IF (.not.allocated(self%pool(iobs)%group)) THEN + allocate ( self%pool(iobs)%group(ngroups) ) + END IF +! + is2d_obs=(self%pool(iobs)%name.eq.'ADT').or. & + & (self%pool(iobs)%name.eq.'SSS').or. & + & (self%pool(iobs)%name.eq.'SST') +! + DO k=1,ngroups + IF (.not.allocated(self%pool(iobs)%group(k)%name)) THEN + lstr=LEN_TRIM(FileGroups(k)) + allocate ( character(LEN=lstr) :: & + & self%pool(iobs)%group(k)%name ) + self%pool(iobs)%group(k)%name=TRIM(FileGroups(k)) + END IF +! + SELECT CASE (TRIM(FileGroups(k))) + CASE ('MetaData') + mvars=0 + lstr=0 + DO i=1,SIZE(MetaDataVars) + myVarName=TRIM(MetaDataVars(i)) + IF (is2d_obs.and.((TRIM(myVarName).eq.'depth').or. & + & (TRIM(myVarName).eq.'z_grid'))) CYCLE + mvars=mvars+1 + lstr=MAX(lstr, LEN_TRIM(myVarName)) + END DO +! + self%pool(iobs)%group(k)%nvars=mvars + IF (.not.allocated(self%pool(iobs)%group(k)%vname)) THEN + allocate ( character(LEN=lstr) :: & + & self%pool(iobs)%group(k)%vname(mvars) ) + END IF + IF (.not.allocated(self%pool(iobs)%group(k)%vid)) THEN + allocate ( self%pool(iobs)%group(k)%vid(mvars) ) + self%pool(iobs)%group(k)%vid=0 + END IF +! + ic=0 + DO i=1,SIZE(MetaDataVars) + myVarName=TRIM(MetaDataVars(i)) + IF (is2d_obs.and.((TRIM(myVarName).eq.'depth').or. & + & (TRIM(myVarName).eq.'z_grid'))) CYCLE + ic=ic+1 + self%pool(iobs)%group(k)%vname(ic)=TRIM(myVarName) + END DO +! + CASE DEFAULT + nvars=self%pool(iobs)%nvars + lstr=0 + DO i=1,nvars + myVarName=self%pool(iobs)%vars(i) + lstr=MAX(lstr, LEN_TRIM(myVarName)) + END DO +! + self%pool(iobs)%group(k)%nvars=nvars + IF (.not.allocated(self%pool(iobs)%group(k)%vname)) THEN + allocate ( character(LEN=lstr) :: & + & self%pool(iobs)%group(k)%vname(nvars) ) + END IF + IF (.not.allocated(self%pool(iobs)%group(k)%vid)) THEN + allocate ( self%pool(iobs)%group(k)%vid(nvars) ) + self%pool(iobs)%group(k)%vid=0 + END IF +! + DO i=1,nvars + myVarName=self%pool(iobs)%vars(i) + self%pool(iobs)%group(k)%vname(i)=TRIM(myVarName) + END DO + END SELECT + END DO +! +!----------------------------------------------------------------------- +! Create ouput observation plus H(x) NetCDF4 files (serial, only +! ouput thread). +!----------------------------------------------------------------------- +! + DEFINE : IF (OutThread) THEN +! +! Create NetCDF4 file. +! + IF (nc_error(nf90_create(self%pool(iobs)%ncname_out, & + & nf90_netcdf4, ncid_out), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + self%pool(iobs)%ncID=ncid_out + WRITE (stdout,30) ng, self%pool(iobs)%ncname_out +! +! Define dimensions. +! + nlocs=self%pool(iobs)%nlocs + nvars=self%pool(iobs)%nvars + nsurvey=self%pool(iobs)%nsurvey + DimSize=(/ nlocs, nvars, nsurvey /) +! + DO i=1,SIZE(DimSize) + IF (nc_error(nf90_def_dim(ncid_out, TRIM(DimName(i)), & + & DimSize(i), DimID(i)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END DO +! +! Define Groups and their variables. +! + GROUP_LOOP : DO k=1,SIZE(FileGroups) + IF (nc_error(nf90_def_grp(ncid_out, TRIM(FileGroups(k)), & + & grpid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + self%pool(iobs)%group(k)%gid=grpid +! + IF (TRIM(FileGroups(k)).eq.'MetaData') THEN + mvars=self%pool(iobs)%group(k)%nvars + DO i=1,mvars + myVarName=self%pool(iobs)%group(k)%vname(i) +! + got_units=.TRUE. + SELECT CASE (TRIM(myVarName)) + CASE ('dateTime') + vlong='elapsed observation time since reference' + units='seconds since ' // epoch + vdims=DimID(1) + vtype=nf90_int64 + got_units=.TRUE. + CASE ('depth') + IF ((self%pool(iobs)%name.eq.'ADT').or. & + & (self%pool(iobs)%name.eq.'SSS').or. & + & (self%pool(iobs)%name.eq.'SST')) CYCLE + vlong='observation depth below sea level' + units='meter' + vdims=DimID(1) + vtype=nf90_float + got_units=.TRUE. + CASE ('latitude') + vlong='observation latitude' + units='degrees_north' + vdims=DimID(1) + vtype=nf90_float + got_units=.TRUE. + CASE ('longitude') + vlong='observation longitude' + units='degrees_east' + vdims=DimID(1) + vtype=nf90_float + got_units=.TRUE. + CASE ('provenance') + vlong='observation origin identifier' + vdims=DimID(1) + vtype=nf90_int + CASE ('stateID') + vlong='state variable index' + vdims=DimID(2) + vtype=nf90_int + CASE ('surveyIndex') + vlong='observation survey time indices ' // & + & 'as they appear in dateTime' + vdims=DimID(3) + vtype=nf90_int + CASE ('surveyTime') + vlong='observation survey time' + units='seconds since ' // epoch + vdims=DimID(3) + vtype=nf90_int64 + got_units=.TRUE. + CASE ('x_grid') + vlong='observation fractional x-grid location' + vdims=DimID(1) + vtype=nf90_float + CASE ('y_grid') + vlong='observation fractional y-grid location' + vdims=DimID(1) + vtype=nf90_float + CASE ('z_grid') + IF ((self%pool(iobs)%name.eq.'ADT').or. & + & (self%pool(iobs)%name.eq.'SSS').or. & + & (self%pool(iobs)%name.eq.'SST')) CYCLE + vlong='observation fractional z-grid location' + vdims=DimID(1) + vtype=nf90_float + END SELECT +! + IF (nc_error(nf90_def_var(grpid, TRIM(myVarName), & + & vtype, (/ vdims /), & + & varid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + self%pool(iobs)%group(k)%vid(i)=varid +! + IF (nc_error(nf90_put_att(grpid, varid, & + & 'long_name', TRIM(vlong)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (got_units) THEN + IF (nc_error(nf90_put_att(grpid, varid, & + & 'units', TRIM(units)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END IF +! + IF (TRIM(myVarName).eq.'depth') THEN + IF (nc_error(nf90_put_att(grpid, varid, & + & 'negative', 'downwards'), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END IF + END DO +! + ELSE +! + SELECT CASE (TRIM(FileGroups(k))) + CASE ('ObsError') + vtype=nf90_float + string='observation error standard deviation' + got_units=.TRUE. + CASE ('ObsValue') + vtype=nf90_float + string='observation value' + got_units=.TRUE. + CASE ('ObsVetting') + vtype=nf90_int + string='Observation screening flag, ' // & + & '0:reject and 1:accept' + got_units=.FALSE. + CASE ('hofx') + vtype=nf90_float + string='model background at observation locations' + got_units=.TRUE. + CASE ('BackgroundError') + vtype=nf90_float + string='background error at observation locations' + got_units=.TRUE. + CASE ('hofxInitial') + vtype=nf90_float + string='model priot at observation locations' + got_units=.TRUE. + CASE ('hofxFinal') + vtype=nf90_float + string='model analysis at observation locations' + got_units=.TRUE. + CASE ('Innovation') + vtype=nf90_float + string='observations minus background' + got_units=.TRUE. + CASE ('Increment') + vtype=nf90_float + string='analysis minus background' + got_units=.TRUE. + CASE ('Residual') + vtype=nf90_float + string='observation minus analysis' + got_units=.TRUE. + END SELECT +! + DO i=1,nvars + myVarName=self%pool(iobs)%group(k)%vname(i) +! + SELECT CASE (TRIM(myVarName)) + CASE ('absoluteDynamicTopography') + units='meter' + coord='longitude, latitude, dateTime' + CASE ('waterZonalVelocity', & + & 'waterMeridionalVelocity') + units='meter second-1' + coord='longitude, latitude, depth, dateTime' + CASE ('seaSurfaceTemperature') + units='C' + coord='longitude, latitude, dateTime' + CASE ('waterTemperature') + units='C' + coord='longitude, latitude, depth, dateTime' + CASE ('seaSurfaceSalinity') + units='dimensionless' + coord='longitude, latitude, dateTime' + CASE ('salinity') + units='dimensionless' + coord='longitude, latitude, depth, dateTime' + END SELECT +! + IF (nc_error(nf90_def_var(grpid, TRIM(myVarName), & + & vtype, (/ DimID(1) /), & + & varid), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + self%pool(iobs)%group(k)%vid(i)=varid +! + IF (nc_error(nf90_put_att(grpid, varid, & + & 'long_name', TRIM(string)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + IF (got_units) THEN + IF (nc_error(nf90_put_att(grpid, varid, & + & 'units', TRIM(units)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END IF + IF (nc_error(nf90_put_att(grpid, varid, & + & 'coordinates', TRIM(coord)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END DO + END IF + + END DO GROUP_LOOP +! +! Define global attributes. +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'title', TRIM(title)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & '_ioda_layout', 'ObsGroup'), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & '_ioda_layout_version', 3), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'datetimeReference', epoch), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'referenceDatenum', & + & self%ref_datetime(1)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'description', & + & 'ROMS 4D-Var observations and H(x) IODA file'), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'sourceFile', & + & TRIM(self%pool(iobs)%ncname_inp)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! + WRITE (string,'(a,1x,a,", ",a)') 'ROMS, Version', & + & TRIM(version), & + & TRIM(date_str) + IF (nc_error(nf90_put_att(ncid_out, nf90_global, & + & 'history', TRIM(string)), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE +! +! End NetCDF-4 file definition. +! + IF (nc_error(nf90_enddef(ncid_out), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + IF (nc_error(nf90_close(ncid_out), & + & nf90_noerr, __LINE__, MyFile)) EXIT DEFINE + END IF DEFINE + +# ifdef DISTRIBUTE +! +! Broadcast error flags. +! + ibuffer(1)=exit_flag + ibuffer(2)=ioerror + CALL mp_bcasti (ng, model, ibuffer) + exit_flag=ibuffer(1) + ioerror=ibuffer(2) +# endif + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END DO FILE_LOOP +! + 10 FORMAT (i4.4,'-',i2.2,'-',i2.2,'T',i2.2,':',i2.2,':',i2.2,'Z') + 20 FORMAT (3(a,'_'), 'hofx.nc4') + 30 FORMAT (2x,'OBS_POOL - NC4_DEFINE: creating H(x) file,', & + & t56,'Grid ',i2.2,': ',a) +! + RETURN + END SUBROUTINE obs_pool_nc4_define +! +!----------------------------------------------------------------------- +! It creates ouput IODA-type observations plus H(x) variables NetCDF4 +! enhanced file(s). It inquires input IODA-type observation files to +! copy their schema, and adds Groups associated with the H(x) operator. +! + SUBROUTINE obs_pool_nc_create (self, ng, model, isIODA) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + logical, intent(in ) :: isIODA ! input obs switch +! + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_nc_create" +! + SourceFile=MyFile +! +! If IODA-type input observation files, clone NetCDF-4 enhaced files +! schema to create ouput observations plus H(x) files. +! + IF (isIODA) THEN + CALL self%nc4_clone (ng, model) +! +! Otherwise for native input observation file, define IODA-type +! observation plus H(x) files. +! + ELSE + CALL self%nc4_define (ng, model) + END IF +! + RETURN + END SUBROUTINE obs_pool_nc_create +! +!----------------------------------------------------------------------- +! It reads the input observation file(s) to populate the data into +! the pool object. Each element of the pool vector stores a scalar +! or vector variable(s) associated with the data assimilation control +! vector. +! + SUBROUTINE obs_pool_nc_read (self, ng, model, nfiles) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: nfiles ! number of files +! + logical :: isNative + integer :: mobs, msurvey, mvar + integer :: IOtype, i, nf + character (len=256) :: ncname + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_nc_read" +! + SourceFile=MyFile +! +! Initialize. +! + isNative=.FALSE. + mobs=0 + msurvey=0 + mvar=0 +! +! Inquire input observation NetCDF file(s). +! + FILES_LOOP : DO nf=1,nfiles + ncname=OBS2(nf,ng)%name + IOtype=OBS2(nf,ng)%IOtype +! + self%pool(nf)%IsAreaAveraged=.FALSE. + self%pool(nf)%IsTimeAveraged=.FALSE. +! + SELECT CASE (IOtype) + CASE (io_nf90) + CALL netcdf_get_dim (ng, model, ncname) + CASE DEFAULT + IF (Master) WRITE (stdout,10) IOtype + exit_flag=3 + END SELECT + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Get number of observations from its dimensions, and determine if +! native or IODA file. +! + DO i=1,n_dim + IF (TRIM(dim_name(i)).eq.'datum') then + mobs=dim_size(i) + isNative=.TRUE. ! only in native + ELSE IF (TRIM(dim_name(i)).eq.'survey') THEN + msurvey=dim_size(i) ! in both + ELSE IF (TRIM(dim_name(i)).eq.'Location') THEN + mobs=dim_size(i) + isNative=.FALSE. ! only in IODA + ELSE IF (TRIM(dim_name(i)).eq.'nvars') THEN + mvar=dim_size(i) ! only in IODA + END IF + END DO +! +! Populate data into observation pool object. +! + IF (isNative) THEN + CALL self%load_native (ng, model, mobs, msurvey, & + & IOtype, TRIM(ncname)) + ELSE + CALL self%load_ioda (ng, model, mobs, msurvey, mvar, & + & IOtype, TRIM(ncname)) + END IF + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + + END DO FILES_LOOP +! + 10 FORMAT (' OBS_POOL_READ - Illegal output file type, io_type = ', & + & i0,/,17x,'Check KeyWord ''OUT_LIB'' in ''roms.in''.') +! + RETURN + END SUBROUTINE obs_pool_nc_read +! +!----------------------------------------------------------------------- +! It writes observation data into ouput IODA-type files. The H(x) +! operator variables will be written elsewhere. +! + SUBROUTINE obs_pool_nc_write (self, ng, model, isIODA) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + logical, intent(in ) :: isIODA ! input obs switch +! + integer, allocatable :: Iwork(:) + integer :: i, j, k, ncid, nl, npool + integer :: nlocs, nsurvey, nvars + + character (len=40) :: grpname, varname + character (len=256) :: ncname + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_nc_write" +! + SourceFile=MyFile +! +! Loop over all available files. +! + npool=SIZE(self%pool) +! + FILE_LOOP : DO i=1,npool +! +! Open output observation plus H(x) file in the pool depot. +! + ncname=TRIM(self%pool(i)%ncname_out) + CALL netcdf_open (ng, model, TRIM(ncname), 1, ncid) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + self%pool(i)%ncid=ncid +! +! Write out observation variables. +! + DO k=1,self%pool(i)%ngroups + grpname=TRIM(self%pool(i)%group(k)%name) + nlocs=self%pool(i)%nlocs + nsurvey=self%pool(i)%nsurvey + nvars=self%pool(i)%nvars + DO j=1,self%pool(i)%group(k)%nvars + varname=TRIM(self%pool(i)%group(k)%vname(j)) + IF (TRIM(grpname).eq.'MetaData') THEN + SELECT CASE (TRIM(varname)) + CASE ('dateTime', & + & 'dateTimeAverageBegin', & + & 'dateTimeAverageEnd', & + & 'sequenceNumber') + IF (.not.allocated(Iwork)) THEN + allocate ( Iwork(nlocs) ) + END IF + IF (isIODA) THEN + CALL netcdf_copy_var (ng, model, & + & self%pool(i)%ncname_inp, & + & TRIM(ncname), TRIM(varname), & + & Iwork, & + & GrpName = TRIM(grpname), & + & ncid = ncid) + ELSE + DO nl=1,nlocs + Iwork(nl)=INT(self%pool(i)%time(nl)+ & + & Rclock%Datenumber(2)- & + & self%ref_datetime(2)) + END DO + CALL netcdf_put_ivar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & Iwork, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + END IF + deallocate (Iwork) + CASE ('depth') + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%depth, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('latitude') + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%lat, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('longitude') + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%lon, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('provenance') + CALL netcdf_put_ivar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%provenance, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('stateID') + CALL netcdf_put_ivar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%stateID, & + & (/1/), (/nvars/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('spatialAverage') + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%spatialAverage, & + & (/1/), (/nvars/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('surveyIndex') + CALL netcdf_put_ivar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%surveyIndex, & + & (/1/), (/nsurvey/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('surveyTime') + IF (.not.allocated(Iwork)) THEN + allocate ( Iwork(nsurvey) ) + END IF + IF (isIODA) THEN + CALL netcdf_copy_var (ng, model, & + & self%pool(i)%ncname_inp, & + & TRIM(ncname), TRIM(varname), & + & Iwork, & + & GrpName = TRIM(grpname), & + & ncid = ncid) + ELSE + DO nl=1,nsurvey + Iwork(nl)=INT(self%pool(i)%surveyTime(nl)+ & + & Rclock%Datenumber(2)- & + & self%ref_datetime(2)) + END DO + CALL netcdf_put_ivar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & Iwork, & + & (/1/), (/nsurvey/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + END IF + deallocate (Iwork) + CASE ('x_grid') + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%Xgrid, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('y_grid') + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%Ygrid, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + CASE ('z_grid') + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%Zgrid, & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + END SELECT + ELSE IF (TRIM(grpname).eq.'ObsError') THEN + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%error(:,j), & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + ELSE IF (TRIM(grpname).eq.'ObsValue') THEN + CALL netcdf_put_fvar (ng, model, TRIM(ncname), & + & TRIM(varname), & + & self%pool(i)%value(:,j), & + & (/1/), (/nlocs/), & + & ncid = ncid, & + & GrpName = TRIM(grpname)) + ELSE IF (TRIM(grpname).eq.'PreQC') THEN + IF (.not.allocated(Iwork)) THEN + allocate ( Iwork(nlocs) ) + END IF + IF (isIODA) THEN + CALL netcdf_copy_var (ng, model, & + & self%pool(i)%ncname_inp, & + & TRIM(ncname), TRIM(varname), & + & Iwork, & + & GrpName = TRIM(grpname), & + & ncid = ncid) + END IF + deallocate (Iwork) + END IF +! + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) THEN + IF (Master) WRITE (stdout,10) TRIM(grpname), & + & TRIM(varname), TRIM(ncname) + exit_flag=3 + RETURN + END IF + END DO + END DO +! +! Close output NetCDF. HGA: Need to check why I need to close to +! use ncdump while ROMS is still running. +! + CALL netcdf_close (ng, model, ncid, ncname, .FALSE.) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + + END DO FILE_LOOP +! + 10 FORMAT (/,'OBS_POOL - NC_WRITE: unable to write, Group = ',a, & + & ', Variable = ',a,/,11x,'File: ',a) +! + RETURN + END SUBROUTINE obs_pool_nc_write +! +!----------------------------------------------------------------------- +! It allocates the observation arrays in the appropiate pool vector +! element, and then reads the specified native observation file to +! populate the data. +! + SUBROUTINE obs_pool_populate_native (self, ng, model, mobs, & + & IOtype, ncname, & + & typeID, Zgrid) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: mobs ! datum dimension + integer, intent(in ) :: IOtype ! NetCDF IO type + character (len=*), intent(in ) :: ncname ! NetCDF filename + integer, intent(in ) :: typeID(:) ! observation type + real (r8), intent(in ) :: Zgrid(:) ! fractional Zgrid +! + logical :: Loaded, isDayUnits + integer, dimension(mobs) :: obs_idata + integer, allocatable :: surveyIndex(:) + integer :: Ninp, Nout + integer :: i, iobs, j, lstr, mvar, npool + real (r8), dimension(mobs) :: obs_rdata + real (r8), allocatable :: surveyTime(:) + real (r8), dimension(2) :: Tmin, Tmax + character (len=22), dimension(2) :: Dmin, Dmax + character (len=40) :: poolname, varname(2), vars(2) + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_populate_native" +! + SourceFile=MyFile +! +! Read in observation data and populate. +! + IF (IOtype.eq.io_nf90) THEN + CALL netcdf_inq_var (ng, model, ncname) + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! + DO i=1,n_var + Loaded=.FALSE. + SELECT CASE (TRIM(var_name(i))) + CASE ('obs_provenance') + CALL netcdf_get_ivar (ng, model, ncname, & + & var_name(i), obs_idata) +! + CALL self%unpack_i (ng, mobs, typeID, Zgrid, & + & obs_idata, TRIM(var_name(i))) + CASE ('obs_time') + CALL netcdf_get_time (ng, model, ncname, & + & var_name(i), Rclock%DateNumber, & + & obs_rdata) +! +! nearest integer seconds since ROMS reference + DO j=1,mobs + obs_rdata(j)=AINT(obs_rdata(j)*day2sec) + END DO +! + CALL self%unpack_r (ng, mobs, typeID, Zgrid, & + & obs_rdata, TRIM(var_name(i))) + CASE ('obs_depth', & + & 'obs_lon', & + & 'obs_lat', & + & 'obs_Xgrid', & + & 'obs_Ygrid', & + & 'obs_Zgrid', & + & 'obs_error', & + & 'obs_value') + CALL netcdf_get_fvar (ng, model, ncname, & + & TRIM(var_name(i)), obs_rdata) +! + CALL self%unpack_r (ng, mobs, typeID, Zgrid, & + & obs_rdata, TRIM(var_name(i))) + END SELECT + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END DO + END IF +! +! Determine surveyTime and surveyIndex. +! + npool=SIZE(self%pool) + + DO iobs=1,npool + Ninp=SIZE(self%pool(iobs)%time) + CALL unique (Ninp, self%pool(iobs)%time, & + & Nout, surveyTime, surveyIndex) +! + self%pool(iobs)%nsurvey=Nout +! + IF (.not.allocated(self%pool(iobs)%surveyTime)) THEN + allocate ( self%pool(iobs)%surveyTime(Nout) ) + END IF + self%pool(iobs)%surveyTime=surveyTime +! + IF (.not.allocated(self%pool(iobs)%surveyIndex)) THEN + allocate ( self%pool(iobs)%surveyIndex(Nout) ) + END IF + self%pool(iobs)%surveyIndex=surveyIndex +! + deallocate (SurveyTime, SurveyIndex) +! + Tmin(1)=Rclock%DateNumber(2)+MINVAL(self%pool(iobs)%time) + Tmax(1)=Rclock%DateNumber(2)+MAXVAL(self%pool(iobs)%time) + CALL datestr (Tmin(1), .FALSE., Dmin(1)) + CALL datestr (Tmax(1), .FALSE., Dmax(1)) +! + Tmin(2)=Rclock%DateNumber(2)+MINVAL(self%pool(iobs)%surveyTime) + Tmax(2)=Rclock%DateNumber(2)+MAXVAL(self%pool(iobs)%surveyTime) + CALL datestr (Tmin(2), .FALSE., Dmin(2)) + CALL datestr (Tmax(2), .FALSE., Dmax(2)) +! + IF (.not.allocated(self%pool(iobs)%ncname_inp)) THEN + lstr=LEN_TRIM(ncname) + allocate ( character(LEN=lstr) :: self%pool(iobs)%ncname_inp ) + self%pool(iobs)%ncname_inp=TRIM(ncname) + END IF +! + SELECT CASE (self%stateID(iobs)) + CASE (1) + mvar=1 + poolname='ADT' + varname(mvar)='ADT' + vars(mvar)='absoluteDynamicTopography' + self%pool(iobs)%stateID(mvar)=1 + CASE (6) + mvar=1 + poolname='temp' + varname(mvar)='temp' + vars(mvar)='waterTemperature' + self%pool(iobs)%stateID(mvar)=6 + CASE (7) + mvar=1 + poolname='salt' + varname(mvar)='salt' + vars(mvar)='salinity' + self%pool(iobs)%stateID(mvar)=7 + CASE (45) + mvar=2 + poolname='uv_codar' + varname(1)='Ucodar' + varname(2)='Vcodar' + vars(1)='waterZonalVelocity' + vars(2)='waterMeridionalVelocity' + self%pool(iobs)%stateID(1)=4 + self%pool(iobs)%stateID(2)=5 + CASE (60) + mvar=1 + poolname='SST' + varname(mvar)='SST' + vars(mvar)='seaSurfaceTemperature' + self%pool(iobs)%stateID(1)=6 + CASE (70) + mvar=1 + poolname='SSS' + varname(mvar)='SSS' + vars(mvar)='seaSurfaceSalinity' + self%pool(iobs)%stateID(1)=7 + END SELECT +! + IF (.not.allocated(self%pool(iobs)%name)) THEN + lstr=LEN_TRIM(poolname) + allocate ( character(LEN=lstr) :: self%pool(iobs)%name ) + self%pool(iobs)%name=TRIM(poolname) + END IF +! + IF (.not.allocated(self%pool(iobs)%vname)) THEN + lstr=0 + DO i=1,mvar + lstr=MAX(lstr, LEN_TRIM(varname(i))) + END DO + allocate (character(LEN=lstr) :: self%pool(iobs)%vname(mvar) ) + DO i=1,mvar + self%pool(iobs)%vname(i)=TRIM(varname(i)) + END DO + END IF +! + IF (.not.allocated(self%pool(iobs)%vars)) THEN + lstr=0 + DO i=1,mvar + lstr=MAX(lstr, LEN_TRIM(vars(i))) + END DO + allocate ( character(LEN=lstr) :: self%pool(iobs)%vars(mvar) ) + DO i=1,mvar + self%pool(iobs)%vars(i)=TRIM(vars(i)) + END DO + END IF +! +! Compute statistics. +! + isDayUnits=.FALSE. + CALL self%pool(iobs)%stats (isDayUnits) +! +! Report processing information. +! + IF (Master) THEN + WRITE (stdout,10) TRIM(ncname) + WRITE (stdout,20) 'MetaData', 'obs_time', Ninp + WRITE (stdout,20) 'MetaData', 'obs_depth', Ninp + WRITE (stdout,20) 'MetaData', 'obs_lat', Ninp + WRITE (stdout,20) 'MetaData', 'obs_lon', Ninp + WRITE (stdout,20) 'MetaData', 'obs_provenace', Ninp + WRITE (stdout,20) 'MetaData', 'surveyIndex', Nout + WRITE (stdout,20) 'MetaData', 'obs_survey', Nout + WRITE (stdout,20) 'MetaData', 'obs_Xgrid', Ninp + WRITE (stdout,20) 'MetaData', 'obs_Ygrid', Ninp + WRITE (stdout,20) 'MetaData', 'obs_Zgrid', Ninp + DO i=1,mvar + WRITE (stdout,30) 'ObsError', TRIM(vars(i)), Ninp, & + & self%pool(iobs)%stateID(i) + END DO + DO i=1,mvar + WRITE (stdout,30) 'ObsValue', TRIM(vars(i)), Ninp, & + & self%pool(iobs)%stateID(i) + END DO +! + WRITE (stdout,'(1x)') + DO i=1,mvar + WRITE (stdout,40) TRIM(self%pool(iobs)%vars(i)), & + & self%pool(iobs)%value_min(i), & + & self%pool(iobs)%value_max(i), & + & self%pool(iobs)%value_avg(i), & + & self%pool(iobs)%value_hash(i), & + & self%pool(iobs)%error_min(i), & + & self%pool(iobs)%error_max(i), & + & self%pool(iobs)%error_avg(i) + WRITE (stdout,50) 'DateTime Range: ', & + & TRIM(Dmin(1)), TRIM(Dmax(1)) + WRITE (stdout,50) 'SurveyTime Range: ', & + & TRIM(Dmin(2)), TRIM(Dmax(2)) + END DO + END IF + END DO +! + 10 FORMAT (/,2x,'ROMS_OBS - Processing: ',a) + 20 FORMAT (t23,a,'::',a,t75,'Count = ',i0) + 30 FORMAT (t23,a,'::',a,t75,'Count = ',i0,t90,'ID = ',i0) + 40 FORMAT (t21,'- ',a,/,t23,'(ValMin = ',1p,e12.5,' ValMax = ', & + & 1p,e12.5,' ValAvg = ',1p,e12.5,' CheckSum = ',i0,')', & + & /,t23,'(ErrMin = ',1p,e12.5,' ErrMax = ',1p,e12.5, & + & ' ErrAvg = ',1p,e12.5,')') + 50 FORMAT (t23,a,a,' to ',a) +! + RETURN + END SUBROUTINE obs_pool_populate_native +! +!----------------------------------------------------------------------- +! Define the size of the observation pool vector as the number of +! variables in the state control vector that are directly or +! indirectly linked to the measurements. Retrieve the state variable +! stateID (1:nvars) from the input observations file(s), nfiles. +! Then, allocate observation pool vector. +! + SUBROUTINE obs_pool_size (self, ng, model, nfiles) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: nfiles ! number of files +! + logical :: haveID(5+NT(ng), nfiles) + logical, dimension(nfiles) :: haveSSS, haveSST, haveVector + logical, dimension(nfiles) :: add_Sid, add_Tid, isNative + integer, dimension(nfiles) :: mobs, msurvey, mvar + integer :: stateID(5+NT(ng), nfiles) + integer :: uniqueVal(5+NT(ng)) + integer, allocatable :: myStateID(:) + integer, allocatable :: obs_type(:) + integer :: i, ic, mdatum, mvatt, nf, nvars + integer :: id, mSalt, mTemp, mSSS, mSST + integer :: Lsur + real (r8), allocatable :: obs_Zgrid(:) + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_size" +! + SourceFile=MyFile +! +! Initialize. +! + add_Sid=.FALSE. + add_Tid=.FALSE. + isNative=.FALSE. + haveID=.FALSE. + haveSSS=.FALSE. + haveSST=.FALSE. + haveVector=.FALSE. +! + mobs=0 + mSSS=0 + mSST=0 + msurvey=0 + mvar=0 + mvatt=0 + stateID=0 +! + Lsur=N(ng) +! +! Inquire input observation NetCDF file(s). +! + FILES_LOOP : DO nf=1,nfiles + SELECT CASE (OBS2(nf,ng)%IOtype) + CASE (io_nf90) + CALL netcdf_get_dim (ng, model, OBS2(nf,ng)%name) + CASE DEFAULT + IF (Master) WRITE (stdout,10) OBS2(nf,ng)%IOtype + exit_flag=3 + END SELECT + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN +! +! Get number of observation from its dimensions, and determine if +! native or IODA file. +! + DO i=1,n_dim + IF (TRIM(dim_name(i)).eq.'datum') then + mdatum=dim_size(i) + mobs(nf)=mobs(nf)+mdatum + isNative(nf)=.TRUE. ! only in native + ELSE IF (TRIM(dim_name(i)).eq.'survey') THEN + msurvey(nf)=msurvey(nf)+dim_size(i) ! only in native + ELSE IF (TRIM(dim_name(i)).eq.'Location') THEN + mobs(nf)=mobs(nf)+dim_size(i) + isNative(nf)=.FALSE. ! only in IODA + ELSE IF (TRIM(dim_name(i)).eq.'nvars') THEN + mvar(nf)=mvar(nf)+dim_size(i) ! only in IODA + END IF + END DO +! +! If native observation file, read in "obs_type" and "obs_Zgrid" to +! determine the observed variables and its IDs. +! + IF (isNative(nf)) THEN + IF (.not.allocated(obs_type)) THEN + allocate ( obs_type(mdatum) ) + obs_type=0 + END IF + IF (.not.allocated(obs_Zgrid)) THEN + allocate ( obs_Zgrid(mdatum) ) + obs_Zgrid=0.0_r8 + END IF +! + SELECT CASE (OBS2(nf,ng)%IOtype) + CASE (io_nf90) + CALL netcdf_get_ivar (ng, model, OBS2(nf,ng)%name, & + & 'obs_type', obs_type) + IF (FoundError(exit_flag,NoError,__LINE__,MyFile)) RETURN +! + CALL netcdf_get_fvar (ng, model, OBS2(nf,ng)%name, & + & 'obs_Zgrid', obs_Zgrid) + IF (FoundError(exit_flag,NoError,__LINE__,MyFile)) RETURN + END SELECT +! + uniqueVal=0 + DO i=1,mdatum + id=obs_type(i) + uniqueVal(id)=uniqueVal(id)+1 + haveID(id,nf)=.TRUE. + IF ((id.eq.6).and.(INT(obs_Zgrid(i)).eq.Lsur)) THEN + haveSST(nf)=.TRUE. + mSST=mSST+1 + ELSE IF ((id.eq.7).and.(INT(obs_Zgrid(i)).eq.Lsur)) THEN + haveSSS(nf)=.TRUE. + mSSS=mSSS+1 + END IF + END DO + mvar(nf)=mvar(nf)+COUNT(uniqueVal.gt.0) + mTemp=uniqueVal(6) + mSalt=uniqueVal(7) + IF (haveSST(nf).and.(mSST.gt.0).and.(mTemp.gt.mSST)) THEN + add_Tid(nf)=.TRUE. + END IF + IF (haveSSS(nf).and.(mSSS.gt.0).and.(mSalt.gt.mSSS)) THEN + add_Sid(nf)=.TRUE. + END IF + deallocate (obs_type) + deallocate (obs_Zgrid) +! +! Otherwise, get variable ID for IODA file. +! + ELSE + allocate ( myStateID(mvar(nf)) ) + myStateID=0 +! + SELECT CASE (OBS2(nf,ng)%IOtype) + CASE (io_nf90) + CALL netcdf_get_ivar (ng, model, OBS2(nf,ng)%name, & + & 'stateID', myStateID, & + & GrpName = 'MetaData') + IF (FoundError(exit_flag,NoError,__LINE__,MyFile)) RETURN +! + CALL netcdf_inq_var (ng, model, OBS2(nf,ng)%name, & + & myVarName = 'stateID', & + & GrpName = 'MetaData', & + & nVarAtt = mvatt) + IF (FoundError(exit_flag,NoError,__LINE__,MyFile)) RETURN +! + DO i=1,mvatt + IF (TRIM(var_Aname(i)).eq.'surface_level') THEN + IF (ANY(myStateID.eq.6)) THEN + haveSST(nf)=.TRUE. + END IF + IF (ANY(myStateID.eq.7)) THEN + haveSSS(nf)=.TRUE. + END IF + END IF + END DO + END SELECT +! + DO i=1,mvar(nf) + id=myStateID(i) + haveID(id,nf)=.TRUE. + END DO + deallocate (myStateID) + END IF +! +! Set number of state variables and their IDs. +! + ic=0 + DO i=1,5+NT(ng) + IF (haveID(i,nf)) THEN + ic=ic+1 + StateID(ic,nf)=i + END IF + END DO +! +! Set number of control vector variables. Since we have multiple +! observation files, the logic in StateID already accounts for +! SST and SSS, and there is not need for augmentation of "nvars", +! as in the native case. +! + nvars=COUNT(StateID.gt.0) + IF (isNative(nf)) THEN + IF (haveSST(nf)) nvars=nvars+1 + IF (haveSSS(nf)) nvars=nvars+1 + END IF + + END DO FILES_LOOP +! +! If velocity observations, myStateID=4 and myStateID=5, adjust the +! "nvars" values because vector components are stored in the same pool +! vector element since they share the same location and time coordinates. +! Note that stateID=45 indicates that the element now contains the +! velocity vector components. +! + DO nf=1,nfiles + IF (ANY(StateID(:,nf).eq.4).and.ANY(StateID(:,nf).eq.5)) THEN + haveVector(nf)=.TRUE. ! has ID = 4, 5 + nvars=nvars-1 + END IF + END DO +! +! Alocate and initialize the stateID vector. +! + IF (.not.allocated(self%stateID)) THEN + allocate ( self%stateID(nvars) ) + END IF +! + ic=0 + DO nf=1,nfiles + DO i=1,5+NT(ng) + IF (StateID(i,nf).gt.0) THEN + IF (haveVector(nf).and. & + & (StateID(i,nf).eq.4).or.(StateID(i,nf).eq.5)) THEN + IF (StateID(i,nf).eq.5) CYCLE ! skip assigment + ic=ic+1 + self%stateID(ic)=45 ! has ID = 4, 5 + ELSE IF (haveSST(nf).and.(stateID(i,nf).eq.6)) THEN + ic=ic+1 + self%stateID(ic)=60 ! has ID = 6, z=0 + IF (isNative(nf).and.add_Tid(nf)) THEN + ic=ic+1 + self%stateID(ic)=6 ! has ID = 6 + END IF + ELSE IF (haveSSS(nf).and.(stateID(i,nf).eq.7)) THEN + ic=ic+1 + self%stateID(ic)=70 ! has ID = 7, z=0 + IF (isNative(nf).and.add_Sid(nf)) THEN + ic=ic+1 + self%stateID(ic)=7 ! has ID = 7 + END IF + ELSE + ic=ic+1 + self%stateID(ic)=StateID(i,nf) + END IF + END IF + END DO + END DO +! +! Allocate observation pool vector. +! + IF (.not.allocated(self%pool)) THEN + allocate ( self%pool(nvars) ) + END IF +! + 10 FORMAT (' OBS_POOL_SIZE - Illegal output file type, io_type = ', & + & i0,/,17x,'Check KeyWord ''OUT_LIB'' in ''roms.in''.') +! + RETURN + END SUBROUTINE obs_pool_size +! +!----------------------------------------------------------------------- +! It determines the total number of observatos in the pool depot. +! + SUBROUTINE obs_pool_tally (self) +! + CLASS (obs_pool), intent(inout) :: self ! observation set +! + integer, allocatable :: ObsCount(:) + integer :: mvars, ndatum, npool + integer :: i, ic, j, m, nc +! +! Count the total number of observations. +! + ndatum=0 + npool=SIZE(self%pool) + IF (.not.allocated(ObsCount)) THEN + allocate ( ObsCount(npool) ) + ObsCount=0 + END IF +! + DO i=1,npool + ObsCount(i)=self%pool(i)%nlocs + ndatum=ndatum+ObsCount(i)*self%pool(i)%nvars + END DO + self%ndatum=ndatum +! +! Set mapping indices to packed observations vector. It is used in the +! H(x) object. +! + ic=0 + DO i=1,npool + mvars=self%pool(i)%nvars + IF (.not.allocated(self%pool(i)%pack_mapping)) THEN + allocate ( self%pool(i)%pack_mapping(ObsCount(i),mvars) ) + self%pool(i)%pack_mapping=0 + END IF + DO m=1,mvars + nc=0 + DO j=1,self%pool(i)%nlocs + ic=ic+1 + nc=nc+1 + self%pool(i)%pack_mapping(nc,m)=ic + END DO + END DO + END DO + IF (allocated(ObsCount)) deallocate (ObsCount) +! + RETURN + END SUBROUTINE obs_pool_tally +! +!----------------------------------------------------------------------- +! It unpacks native observation integer data into pool object. +! + SUBROUTINE obs_pool_unpack_i (self, ng, ND, typeID, Zgrid, idata, & + & VarName) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: ND ! datum dimension + integer, intent(in ) :: typeID(ND) ! observation type + real (r8), intent(in ) :: Zgrid(ND) ! fractional Zgrid + integer, intent(in ) :: idata(ND) ! obsevation data + character (len=*), intent(in ) :: VarName ! variable name +! + logical :: mask(ND) + integer :: Lsur, iobs, mvar, npool + integer :: poolID + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_unpack_i" +! + SourceFile=MyFile +! +! Unpack native observation integer data. +! +! Lsur=N(ng) + Lsur=50 ! HGA: temporary for debugging +! + mask=.FALSE. + mvar=0 + npool=SIZE(self%pool) +! + DO iobs=1,npool + poolID=self%pool(iobs)%poolID +! + SELECT CASE (poolID) + CASE (1) ! ADT/SSH + mask=(typeID.eq.1) + mvar=1 + CASE (6) ! Temperature + mask=(typeID.eq.6).and.(INT(Zgrid).ne.Lsur) + mvar=1 + CASE (7) ! Salinity + mask=(typeID.eq.7) + mvar=1 + CASE (45) ! U-,V-velocity + mask=(typeID.eq.4) ! U-Velocity + mvar=2 + CASE (60) ! SST, z=0 + mask=(typeID.eq.6).and.(INT(Zgrid).eq.Lsur) + mvar=1 + CASE (70) ! SSS, z=0 + mask=(typeID.eq.7).and.(INT(Zgrid).eq.Lsur) + mvar=1 + CASE DEFAULT + IF (Master) WRITE (stdout,10) poolID + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END SELECT +! +! Load observation data to the appropiate array in the pool object. +! + SELECT CASE (TRIM(VarName)) + CASE ('obs_provenance') + self%pool(iobs)%provenance = PACK(idata, mask) + CASE DEFAULT + IF (Master) WRITE (stdout,20) TRIM(VarName) + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END SELECT + END DO +! + 10 FORMAT (/,'ROMS_OBS - obs_pool::unpack_i: cannot find ', & + & 'poolID = ',i0) + 20 FORMAT (/,'ROMS_OBS - obs_pool::unpack_i: cannot find ', & + & 'VarName = ',a) +! + RETURN + END SUBROUTINE obs_pool_unpack_i +! +!----------------------------------------------------------------------- +! It unpacks native observation floating-point data into pool object. +! + SUBROUTINE obs_pool_unpack_r (self, ng, ND, typeID, Zgrid, rdata, & + & VarName) +! + CLASS (obs_pool), intent(inout) :: self ! observation set + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: ND ! datum dimension + integer, intent(in ) :: typeID(ND) ! observation type + real (r8), intent(in ) :: Zgrid(ND) ! fractional Zgrid + real (r8), intent(in ) :: rdata(ND) ! obsevation data + character (len=*), intent(in ) :: VarName ! variable name +! + logical :: mask(ND), msk2(ND) + integer :: Lsur, i, iobs, mvar, npool + integer :: poolID + + character (len=*), parameter :: MyFile = & + & __FILE__//", obs_pool_unpack_r" +! + SourceFile=MyFile +! +! Unpack native observation integer data. +! + Lsur=N(ng) +! + mask=.FALSE. + msk2=.FALSE. + mvar=0 + npool=SIZE(self%pool) +! + DO iobs=1,npool + poolID=self%pool(iobs)%poolID +! + SELECT CASE (poolID) + CASE (1) ! ADT/SSH + mask=(typeID.eq.1) + mvar=1 + CASE (6) ! Temperature + mask=(typeID.eq.6).and.(INT(Zgrid).ne.Lsur) + mvar=1 + CASE (7) ! Salinity + mask=(typeID.eq.7).and.(INT(Zgrid).ne.Lsur) + mvar=1 + CASE (45) ! U-,V-velocity + mask=(typeID.eq.4) ! U-velocity + msk2=(typeID.eq.5) ! V-velocity + mvar=2 + CASE (60) ! SST. z=0 + mask=(typeID.eq.6).and.(INT(Zgrid).eq.Lsur) + mvar=1 + CASE (70) ! SSS, z=0 + mask=(typeID.eq.7).and.(INT(Zgrid).eq.Lsur) + mvar=1 + CASE DEFAULT + IF (Master) WRITE (stdout,10) poolID + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END SELECT +! +! Load observation data to the appropiate array in the pool object. +! + SELECT CASE (TRIM(VarName)) + CASE ('obs_time') + self%pool(iobs)%time = PACK(rdata, mask) + CASE ('obs_depth') + self%pool(iobs)%depth = PACK(rdata, mask) + CASE ('obs_lon') + self%pool(iobs)%lon = PACK(rdata, mask) + CASE ('obs_lat') + self%pool(iobs)%lat = PACK(rdata, mask) + CASE ('obs_Xgrid') + self%pool(iobs)%Xgrid = PACK(rdata, mask) + CASE ('obs_Ygrid') + self%pool(iobs)%Ygrid = PACK(rdata, mask) + CASE ('obs_Zgrid') + self%pool(iobs)%Zgrid = PACK(rdata, mask) + CASE ('obs_error') + DO i=1,mvar + self%pool(iobs)%error(:,i) = PACK(rdata, mask) + IF (i.eq.2) THEN + self%pool(iobs)%error(:,i) = PACK(rdata, msk2) + END IF + END DO + CASE ('obs_value') + DO i=1,mvar + self%pool(iobs)%value(:,i) = PACK(rdata, mask) + IF (i.eq.2) THEN + self%pool(iobs)%value(:,i) = PACK(rdata, msk2) + END IF + END DO + CASE DEFAULT + IF (Master) WRITE (stdout,20) TRIM(VarName) + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END SELECT + END DO +! + 10 FORMAT (/,'ROMS_OBS - obs_pool::unpack_r: cannot find ', & + & 'poolID = ',i0) + 20 FORMAT (/,'ROMS_OBS - obs_pool::unpack_r: cannot find ', & + & 'VarName = ',a) +! + RETURN + END SUBROUTINE obs_pool_unpack_r +#endif + END MODULE roms_obs_mod diff --git a/ROMS/Utility/roms_vchange.F b/ROMS/Utility/roms_vchange.F new file mode 100644 index 000000000..6c071ced3 --- /dev/null +++ b/ROMS/Utility/roms_vchange.F @@ -0,0 +1,1302 @@ +#include "cppdefs.h" + MODULE roms_vchange_mod + +#if (defined FOUR_DVAR || defined VERIFICATION) && defined OBSERVATIONS +! +!git $Id$ +!================================================== Hernan G. Arango === +! Copyright (c) 2002-2025 The ROMS Group ! +! Licensed under a MIT/X style license ! +! See License_ROMS.md ! +!======================================================================= +! ! +! It has several routines to process nonlinear and linear variable ! +! changes needed for the H(x) operator, which computes the model ! +! state variables at the observation locations. ! +! ! +!======================================================================= +! + USE mod_param + USE mod_parallel + USE mod_grid + USE mod_iounits + USE mod_netcdf + USE mod_ocean + USE mod_scalars + USE mod_stepping +! + USE roms_obs_mod +! +# ifdef DISTRIBUTE +# ifdef ADJOIN + USE mp_exchange_mod, ONLY : ad_mp_exchange3d +# endif + USE mp_exchange_mod, ONLY : mp_exchange3d +# endif + USE tracer_index_mod, ONLY : tracer_index +! +!----------------------------------------------------------------------- +! Observation Variable Change Operator: CLASS(obs_VarCha) +!----------------------------------------------------------------------- +! + TYPE, PUBLIC :: obs_VarCha +! +! Geometry pointers. +! + real (r8), pointer :: mask(:,:) => NULL() ! land-sea mask +# ifdef SOLVE3D + real (r8), pointer :: depth(:,:,:) => NULL() ! depths (m) +# endif +! +! Generic field arrays: Allocatable arrays are safer and preferred +! because pointer association to array sections has a unity lower +! bound for each dimension. This is because the right-hand side is +! treated as a new array expression that destroys the original +! parallel decomposition +! + real (r8), allocatable :: field2d(:,:) +# ifdef SOLVE3D + real (r8), allocatable :: field3d(:,:,:) +# endif +# ifdef SOLVE3D +! +! Generic A-grid and C-grid vector components. +! + real (r8), allocatable :: Ua(:,:,:) + real (r8), allocatable :: Va(:,:,:) +! + real (r8), allocatable :: Uc(:,:,:) + real (r8), allocatable :: Vc(:,:,:) +# endif +! + CONTAINS +! +! Execution. +! + PROCEDURE :: apply2d => var_change_apply2d +# ifdef SOLVE3D + PROCEDURE :: apply3d => var_change_apply3d +# endif +# ifdef AJOINT + PROCEDURE :: apply2d_ad => var_change_apply2d_ad +# ifdef SOLVE3D + PROCEDURE :: apply3d_ad => var_change_apply3d_ad +# endif +# endif +# ifdef SOLVE3D +! +! Vertical interpolation: k-level to constant depth. +! + PROCEDURE :: interp_k2z => var_change_interp_k2z +# ifdef ADJOINT + PROCEDURE :: interp_k2z_ad => var_change_interp_k2z_ad +# endif +! +! Horizontal velocity component from C-grid to A-grid and vice versa. +! + PROCEDURE :: uv_a2c => var_change_uv_a2c + PROCEDURE :: uv_c2a => var_change_uv_c2a +# ifdef ADJOINT + PROCEDURE :: uv_a2c_ad => var_change_uv_a2c + PROCEDURE :: uv_c2a_ad => var_change_uv_c2a +# endif +# endif + + END TYPE obs_VarCha +! +!----------------------------------------------------------------------- +! Module variables. +!----------------------------------------------------------------------- +! +! Nonlinear and linear variable changes object. +! + TYPE (obs_VarCha), allocatable :: VarCha(:) +! +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +! + PUBLIC :: vchange_initialize + PUBLIC :: vchange_finalize +! +!::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: +! + CONTAINS +! +! <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><> +! +! It allocates the variable change object. +! + SUBROUTINE vchange_initialize (model) +! + integer, intent(in ) :: model ! kernel identifier +! +! Allocate varible changes object +! + IF (.not.allocated(VarCha)) THEN + allocate ( VarCha(Ngrids) ) + END IF +! + RETURN + END SUBROUTINE vchange_initialize +! +!----------------------------------------------------------------------- +! It destoys variable change object. +! + SUBROUTINE vchange_finalize (ng, model) +! + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: model ! kernel identifier +! +! Deallocate generic arrays. +! + IF (allocated(VarCha(ng)%field2d)) deallocate (VarCha(ng)%field2d) +# ifdef SOLVE3D + IF (allocated(VarCha(ng)%field3d)) deallocate (VarCha(ng)%field3d) + IF (allocated(VarCha(ng)%Ua)) deallocate (VarCha(ng)%Ua) + IF (allocated(VarCha(ng)%Va)) deallocate (VarCha(ng)%Va) + IF (allocated(VarCha(ng)%Uc)) deallocate (VarCha(ng)%Uc) + IF (allocated(VarCha(ng)%Vc)) deallocate (VarCha(ng)%Vc) +# endif +! +! Nullify pointers. +! + IF (associated(VarCha(ng)%mask)) nullify (VarCha(ng)%mask) +# ifdef SOLVE3D + IF (associated(VarCha(ng)%depth)) nullify (VarCha(ng)%depth) +# endif +! + RETURN + END SUBROUTINE vchange_finalize +! +! <><><><><><><><><><><><><><><><><><><><><><><> CLASS OBS_VARCHA <><><> +! +! Given an observation type, it retuns a pointer for the 2D state +! variable associated with the observation, which is used to compute +! the model at the observtion locations, H(x). If appropriate, it +! applies the necessary nonlinear or linear variable changes. If no +! variable changes, the transformation is an identity operator. +! + SUBROUTINE var_change_apply2d (self, ng, tile, model, varname) +! + CLASS (obs_VarCha), intent(inout) :: self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier + character (len=*), intent(in ) :: varname ! state variable +! + integer :: LBi, UBi, LBj, UBj + integer :: i, itrc, j, k, nz +! + real (r8), target, allocatable :: field(:,:,:) + real (r8), allocatable :: Zeven(:) +! +! Initialize. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! +! Set generic variable change array, VarCha%field2d, for the state +! variable associated with the observations. Then, compute the +! appropriate variable change(s), if any. Otherwise, the default is +! the identity operator. +! + IF (allocated(self%field2d)) deallocate (self%field2d) +# ifdef SOLVE3D + IF (TRIM(varname).eq.'Ucodar') THEN + IF (allocated(self%Ua)) deallocate (self%Ua) + IF (allocated(self%Va)) deallocate (self%Va) + IF (allocated(self%Uc)) deallocate (self%Uc) + IF (allocated(self%Vc)) deallocate (self%Vc) + END IF +# endif +! + SELECT CASE (TRIM(varname)) +! + CASE ('adt', 'ssh', 'ADT', 'SSH') +! + allocate ( self%field2d(LBi:UBi, LBj:UBj) ) +! + IF (model.eq.iNLM) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%zeta(i,j,KOUT) + END DO + END DO +# ifdef ADJOINT + ELSE IF (model.eq.iADM) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%f_zeta(i,j) + END DO + END DO +# endif +# ifdef TLM_OBS + ELSE IF ((model.eq.iTLM).or.(model.eq.iRPM)) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%tl_zeta(i,j,KOUT) + END DO + END DO +# endif +# ifndef VERIFICATION + ELSE IF (model.eq.iSTD) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%e_zeta(i,j,1) + END DO + END DO +# endif + END IF + +# ifdef SOLVE3D +! + CASE ('sss', 'sst', 'SSS', 'SST') +! + allocate ( self%field2d(LBi:UBi, LBj:UBj) ) +! + itrc=tracer_index(varname) + IF (model.eq.iNLM) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%t(i,j,N(ng),NOUT,itrc) + END DO + END DO +# ifdef ADJOINT + ELSE IF (model.eq.iADM) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%f_t(i,j,N(ng),itrc) + END DO + END DO +# endif +# ifdef TLM_OBS + ELSE IF ((model.eq.iTLM).or.(model.eq.iRPM)) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%tl_t(i,j,N(ng),NOUT,itrc) + END DO + END DO +# endif +# ifndef VERIFICATION + ELSE IF (model.eq.iSTD) THEN + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=OCEAN(ng)%e_t(i,j,N(ng),1,itrc) + END DO + END DO +# endif + END IF +! + CASE ('Ucodar', 'Vcodar') +! + allocate ( self%field2d(LBi:UBi, LBj:UBj) ) +! +! Transform u- and v-momentum component from C-grid to A-grid. The +! A-grid velocities are computed once during the "Ucodar" case. +! + IF (TRIM(varname).eq.'Ucodar') THEN +! + allocate ( self%Ua(LBi:UBi, LBj:UBj, N(ng)) ) + allocate ( self%Va(LBi:UBi, LBj:UBj, N(ng)) ) + allocate ( self%Uc(LBi:UBi, LBj:UBj, N(ng)) ) + allocate ( self%Vc(LBi:UBi, LBj:UBj, N(ng)) ) +! + self%Ua=0.0_r8 + self%Va=0.0_r8 +! + IF (model.eq.iNLM) THEN + DO k=1,N(ng) + DO j=LBj,UBj + DO i=LBi,UBi + self%Uc(i,j,k)=OCEAN(ng)%u(i,j,k,NOUT) + self%Vc(i,j,k)=OCEAN(ng)%v(i,j,k,NOUT) + END DO + END DO + END DO +# ifdef TLM_OBS + ELSE IF ((model.eq.iTLM).or.(model.eq.iRPM)) THEN + DO k=1,N(ng) + DO j=LBj,UBj + DO i=LBi,UBi + self%Uc(i,j,k)=OCEAN(ng)%tl_u(i,j,k,NOUT) + self%Vc(i,j,k)=OCEAN(ng)%tl_v(i,j,k,NOUT) + END DO + END DO + END DO +# endif + END IF + CALL self%uv_c2a (ng, tile, model) + END IF +! +! Interpolate A-grid u-component to constant depth, Zeven = -2m. +! + nz=1 +! + IF (.not.allocated(field)) THEN + allocate ( field(LBi:UBi, LBj:UBj, nz) ) + field=0.0_r8 + END IF + IF (.not.allocated(Zeven)) THEN + allocate ( Zeven(nz) ) + Zeven=-2.0_r8 + END IF +! + IF (TRIM(varname).eq.'Ucodar') THEN + self%mask => GRID(ng)%rmask + self%depth => GRID(ng)%z_r + CALL self%interp_k2z (ng, tile, model, & + & LBi, UBi, LBj, UBj, & + & varname, Zeven, & + & self%Ua, field) + ELSE IF (TRIM(varname).eq.'Vcodar') THEN + CALL self%interp_k2z (ng, tile, model, & + & LBi, UBi, LBj, UBj, & + & varname, Zeven, & + & self%Va, field) + nullify (self%mask, self%depth) + END IF +! + DO j=LBj,UBj + DO i=LBi,UBi + self%field2d(i,j)=field(i,j,1) + END DO + END DO + deallocate (field) +# endif + END SELECT +! + RETURN + END SUBROUTINE var_change_apply2d + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! Given an observation type, it retuns a pointer for the 3D state +! variable associated with the observation, which is used to compute +! the model at the observtion locations, H(x). If appropriate, it +! applies the necessary nonlinear or linear variable changes. If no +! variable changes, the transformation is an identity operator. +! + SUBROUTINE var_change_apply3d (self, ng, tile, model, varname) +! + CLASS (obs_VarCha), intent(inout) :: self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier + character (len=*), intent(in ) :: varname +! + integer :: LBi, UBi, LBj, UBj + integer :: i, itrc, j, k +! +! Initialize. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! +! Set pointer (VarCha%field3d) to state variable associated with the +! observations. Compute the appropriate variable change(s), if any. +! Otherwise, the default is the identity operator. +! + IF (allocated(self%field3d)) deallocate (self%field3d) +! + SELECT CASE (TRIM(varname)) +! + CASE ('salt', 'temp', 'tracer') +! + allocate ( self%field3d(LBi:UBi, LBj:UBj, N(ng)) ) +! + itrc=tracer_index(varname) + IF (model.eq.iNLM) THEN + DO k=1,N(ng) + DO j=LBj,UBj + DO i=LBi,UBi + self%field3d(i,j,k)=OCEAN(ng)%t(i,j,k,NOUT,itrc) + END DO + END DO + END DO +# ifdef ADJOINT + ELSE IF (model.eq.iADM) THEN + DO k=1,N(ng) + DO j=LBj,UBj + DO i=LBi,UBi + self%field3d(i,j,k)=OCEAN(ng)%f_t(i,j,k,itrc) + END DO + END DO + END DO +# endif +# ifdef TLM_OBS + ELSE IF ((model.eq.iTLM).or.(model.eq.iRPM)) THEN + DO k=1,N(ng) + DO j=LBj,UBj + DO i=LBi,UBi + self%field3d(i,j,k)=OCEAN(ng)%tl_t(i,j,k,NOUT,itrc) + END DO + END DO + END DO +# endif +# ifndef VERIFICATION + ELSE IF (model.eq.iSTD) THEN + DO k=1,N(ng) + DO j=LBj,UBj + DO i=LBi,UBi + self%field3d(i,j,k)=OCEAN(ng)%e_t(i,j,k,1,itrc) + END DO + END DO + END DO +# endif + END IF + END SELECT +! + RETURN + END SUBROUTINE var_change_apply3d +# endif + +# ifdef ADJOINT +! +!----------------------------------------------------------------------- +! Adjoint of applying the necessary linear 2D variable changes. +! + SUBROUTINE var_change_apply2d_ad (ad_self, ng, tile, model, & + & varname) +! + CLASS (obs_VarCha), intent(inout) :: ad_self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier + character (len=*), intent(in ) :: varname +! + integer :: LBi, UBi, LBj, UBj + integer :: i, j, nz +! + real (r8), target, allocatable :: ad_field(:,:,:) + real (r8), allocatable :: Zeven(:) +! +! Initialize. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! +! Set pointer (ad_self%field2d) to state variable associated with the +! observations. Compute the appropriate variable change(s), if any. +! Otherwise, the default is the identity operator. +! + SELECT CASE (TRIM(varname)) + +# ifdef SOLVE3D + CASE ('Ucodar', 'Vcodar') +! +! Adjoint of pointer association. +! + nz=1 +! + IF (.not.allocated(field)) THEN + allocate ( ad_field(LBi:UBi, LBj:UBj, nz) ) + ad_field=0.0_r8 + END IF + IF (.not.allocated(Zeven)) THEN + allocate ( Zeven(nz) ) + Zeven=-2.0_r8 + END IF +! + DO j=LBj,UBj + DO i=LBi,UBi +!> self%field2d(i,j)=field(i,j,1) +!> + ad_field(i,j,1)=ad_field(i,j,1)+ad_self%field2d(i,j) + END DO + END DO +! +! Adjoint of interpolating A-grid components to constant depth, +! Zeven = -2m. +! + IF (TRIM(varname).eq.'Ucodar') THEN +!> CALL VarCha%interp_k2z (ng, tile, model, & +!> & LBi, UBi, LBj, UBj, & +!> & varname, Zeven, & +!> & self%Ua, field) +!> + CALL VarCha%interp_k2z_ad (ng, tile, model, & + & LBi, UBi, LBj, UBj, & + & varname, Zeven, & + & ad_self%Ua, ad_field) + ELSE IF (TRIM(varname).eq.'Vcodar') THEN +!> CALL VarCha%interp_k2z (ng, tile, model, & +!> & LBi, UBi, LBj, UBj, & +!> & varname, Zeven, & +!> & self%Va, field) +!> + CALL VarCha%interp_k2z_ad (ng, tile, model, & + & LBi, UBi, LBj, UBj, & + & varname, Zeven, & + & ad_self%Va, ad_field) + END IF + deallocate (ad_field) +! +! Adjoint of transforming u- and v-momentum component from C-grid to +! A-grid. +! +!> IF (TRIM(varname).eq.'Ucodar') THEN +!> + IF (TRIM(varname).eq.'Vcodar') THEN +!> CALL self%uv_c2a (ng, tile, model) +!> + CALL ad_self%uv_c2a_ad (ng, tile, model) +! + DO j=LBj,UBj + DO i=LBi,UBi + ad_self%Ua(i,j)=ad_self%Ua(i,j)+ad_self%Uc(i,j) + ad_self%Va(i,j)=ad_self%Va(i,j)+ad_self%Vc(i,j) + END DO + END DO + END IF +# endif + END SELECT +! + RETURN + END SUBROUTINE var_change_apply2d_ad + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! Adjoint of applying the necessary linear 3D variable changes. +! + SUBROUTINE var_change_apply3d_ad (ad_self, ng, tile, model, & + & varname) +! + CLASS (obs_VarCha), intent(inout) :: ad_self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier + character (len=*), intent(in ) :: varname +! + integer :: itrc +! +! Set pointer (ad_self%field2d) to state variable associated with the +! observations. Compute the appropriate variable change(s), if any. +! Otherwise, the default is the identity operator. +! + SELECT CASE (TRIM(varname)) + CASE ('salt', 'temp', 'tracer') + itrc=tracer_index(varname) +!> +!> Currently, no variable changes are needed for 3D variables. +!> + END SELECT +! + RETURN + END SUBROUTINE var_change_apply3d_ad +# endif +# endif + +# ifdef SOLVE3D +! +!----------------------------------------------------------------------- +! It vertically interpolates a 3D terrain-following field to specied +! constant depth or depths. +! + SUBROUTINE var_change_interp_k2z (self, ng, tile, model, & + & LBi, UBi, LBj, UBj, & + & name, Zeven, Fk, Fz) +! + CLASS (obs_VarCha), intent(inout) :: self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: LBi, UBi ! array I-bounds + integer, intent(in ) :: LBj, UBj ! array J-bounds + character (len=*), intent(in ) :: name ! field name + real (r8), intent(in ) :: Zeven(:) ! requested depth(s) + real (r8), intent(in ) :: Fk(LBi:,LBj:,:) + real (r8), intent(out ) :: Fz(LBi:,LBj:,:) +! + integer :: Istr, Iend, Jstr, Jend + integer :: IstrR, IendR, JstrR, JendR + integer :: i, iz, j, k, k1, k2 + real (r8) :: Zbot, Ztop, dz, r1, r2 +! +! Initialize. +! + Istr=BOUNDS(ng)%Istr(tile) + Iend=BOUNDS(ng)%Iend(tile) + Jstr=BOUNDS(ng)%Jstr(tile) + Jend=BOUNDS(ng)%Jend(tile) +! + IstrR=BOUNDS(ng)%IstrR(tile) + IendR=BOUNDS(ng)%IendR(tile) + JstrR=BOUNDS(ng)%JstrR(tile) + JendR=BOUNDS(ng)%JendR(tile) +! +! Interpolate 3D field to requested constant depth(s). +! + DO j=JstrR,JendR + DO i=IstrR,IendR +# ifdef MASKING + IF (self%mask(i,j).lt.0.5_r8) CYCLE +# endif + DO iz=1,SIZE(Zeven) + Ztop=self%depth(i,j,N(ng)) + Zbot=self%depth(i,j,1 ) + IF (Zeven(iz).ge.Ztop) THEN ! If shallower, assign + k1=N(ng) ! to top grid cell. The + k2=N(ng) ! field is located on the + r1=1.0_r8 ! upper cell half above + r2=0.0_r8 ! its middle depth. + Fz(i,j,iz)=Fk(i,j,k1) + ELSE IF (Zbot.ge.Zeven(iz)) THEN + r1=0.0_r8 ! If deeper, ignore. + r2=0.0_r8 ! return zero value. + Fz(i,j,iz)=0.0_r8 + ELSE + DO k=N(ng),2,-1 ! Otherwise, interpolate + Ztop=self%depth(i,j,k ) ! to requested depth + Zbot=self%depth(i,j,k-1) + IF ((Ztop.gt.Zeven(iz)).and. & + & (Zeven(iz).ge.Zbot)) THEN + k1=k-1 + k2=k + END IF + END DO + dz=self%depth(i,j,k2)-self%depth(i,j,k1) + r2=(Zeven(iz)-self%depth(i,j,k1))/dz + r1=1.0_r8-r2 + IF ((r1+r2).gt.0.0_r8) THEN + Fz(i,j,iz)=r1*Fk(i,j,k1)+r2*Fk(i,j,k2) + END IF + END IF + END DO + END DO + END DO +! + RETURN + END SUBROUTINE var_change_interp_k2z +! +!----------------------------------------------------------------------- +! It transforms vector components from A-grid (cell center) to +! staggered Arakawa C-grid. +! + SUBROUTINE var_change_uv_a2c (self, ng, tile, model) +! + CLASS (obs_VarCha), intent(inout) :: self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier +! + integer :: LBi, UBi, LBj, UBj + integer :: Istr, Iend, Jstr, Jend + integer :: IstrR, IendR, JstrR, JendR + integer :: i, j, k +! + real (r8), allocatable :: Urho(:,:), Vrho(:,:) +! +! Initialize. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! + Istr=BOUNDS(ng)%Istr(tile) + Iend=BOUNDS(ng)%Iend(tile) + Jstr=BOUNDS(ng)%Jstr(tile) + Jend=BOUNDS(ng)%Jend(tile) +! + IstrR=BOUNDS(ng)%IstrR(tile) + IendR=BOUNDS(ng)%IendR(tile) + JstrR=BOUNDS(ng)%JstrR(tile) + JendR=BOUNDS(ng)%JendR(tile) +! +# ifdef NESTING + IminS=Istr-4 + ImaxS=Iend+3 + JminS=Jstr-4 + JmaxS=Jend+3 +# else + IminS=Istr-3 + ImaxS=Iend+3 + JminS=Jstr-3 + JmaxS=Jend+3 +# endif +! + allocate ( Urho(IminS:ImaxS, JminS:JmaxS) ) + Urho=0.0_r8 + allocate ( Vrho(IminS:ImaxS, JminS:JmaxS) ) + Vrho=0.0_r8 +! +! A-grid to C-grid vector transformation. +! + K_LOOP : DO k=1,N(ng) +! +! Rotate from geographical Eastward and Northward directions to +! computational (XI,ETA) directions. +! + DO j=Jstr-1,JendR + DO i=Istr-1,IendR + Urho(i,j)=self%Ua(i,j,k)*GRID(ng)%CosAngler(i,j)+ & + & self%Va(i,j,k)*GRID(ng)%SinAngler(i,j) + Vrho(i,j)=self%Va(i,j,k)*GRID(ng)%CosAngler(i,j)- & + & self%Ua(i,j,k)*GRID(ng)%SinAngler(i,j) + END DO + END DO +! +! Compute staggered C-grid components. +! + DO j=JstrR,JendR + DO i=Istr,IendR + self%Uc(i,j,k)=0.5_r8*(Urho(i-1,j)+Urho(i,j)) +# ifdef MASKING + self%Uc(i,j,k)=self%Uc(i,j,k)*GRID(ng)%umask(i,j) +# endif + END DO + END DO +! + DO j=Jstr,JendR + DO i=IstrR,IendR + self%Vc(i,j,k)=0.5_r8*(Vrho(i,j-1)+Vrho(i,j)) +# ifdef MASKING + self%Vc(i,j,k)=self%Vc(i,j,k)*GRID(ng)%vmask(i,j) +# endif + END DO + END DO + END DO K_LOOP +! +! Deallocate local arrays. +! + IF (allocated(Urho)) deallocate (Urho) + IF (allocated(Vrho)) deallocate (Vrho) + +# ifdef DISTRIBUTE +! +! Exchange boundary data. +! + CALL mp_exchange3d (ng, tile, model, 2, & + & LBi, UBi, LBj, UBj, 1, N(g), & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & self%Uc, self%Vc) +# endif +! + RETURN + END SUBROUTINE var_change_uv_a2c +! +!----------------------------------------------------------------------- +! It transforms vector components from staggered Arakawa C-grid to +! A-grid (cell center). +! + SUBROUTINE var_change_uv_c2a (self, ng, tile, model) +! + CLASS (obs_VarCha), intent(inout) :: self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier +! + integer :: LBi, UBi, LBj, UBj + integer :: Istr, Iend, Jstr, Jend + integer :: IstrR, IendR, JstrE, JendR + integer :: i, j, k +! + real (r8) :: UaCosA, UaSinA, VaCosA, VaSinA +! +! Initialize. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! + Istr=BOUNDS(ng)%Istr(tile) + Iend=BOUNDS(ng)%Iend(tile) + Jstr=BOUNDS(ng)%Jstr(tile) + Jend=BOUNDS(ng)%Jend(tile) +! + IstrR=BOUNDS(ng)%IstrR(tile) + IendR=BOUNDS(ng)%IendR(tile) + JstrR=BOUNDS(ng)%JstrR(tile) + JendR=BOUNDS(ng)%JendR(tile) +! +! C-grid to A-grid vector transformation. +! + K_LOOP : DO k=1,N(ng) +! +! Compute A-grid (cell center) vector components and apply lateral +! boundary conditions. +! + DO j=JstrR,JendR + DO i=Istr,Iend + self%Ua(i,j,k)=0.5_r8*(self%Uc(i,j,k)+self%Uc(i+1,j,k)) + IF (.not.EWperiodic(ng)) THEN + IF (DOMAIN(ng)%Western_Edge(tile)) THEN + self%Ua(Istr-1,j,k)=self%Ua(Istr,j,k) + END IF + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN + self%Ua(Iend+1,j,k)=self%Ua(Iend,j,k) + END IF + END IF + END DO + END DO +! + DO j=Jstr,Jend + DO i=IstrR,IendR + self%Va(i,j,k)=0.5_r8*(self%Vc(i,j,k)+self%Vc(i,j+1,k)) + IF (.not.NSperiodic(ng)) THEN + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN + self%Va(i,Jstr-1,k)=self%Va(i,Jstr,k) + END IF + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN + self%Va(i,Jend+1,k)=self%Va(i,Jend,k) + END IF + END IF + END DO + END DO +! +! Rotate from computational to gegraphical Eastward and Northward +! directions. +! + DO j=JstrR,JendR + DO i=IstrR,IendR + UaCosA=self%Ua(i,j,k)*GRID(ng)%CosAngler(i,j) + UaSinA=self%Ua(i,j,k)*GRID(ng)%SinAngler(i,j) + VaCosA=self%Va(i,j,k)*GRID(ng)%CosAngler(i,j) + VaSinA=self%Va(i,j,k)*GRID(ng)%SinAngler(i,j) + self%Ua(i,j,k)=UaCosA-VaSinA + self%Va(i,j,k)=VaCosA+UaSinA +# ifdef MASKING + self%Ua(i,j,k)=self%Ua(i,j,k)*GRID(ng)%rmask(i,j) + self%Va(i,j,k)=self%Va(i,j,k)*GRID(ng)%rmask(i,j) +# endif + END DO + END DO + END DO K_LOOP + +# ifdef DISTRIBUTE +! +! Exchange boundary data. +! + CALL mp_exchange3d (ng, tile, model, 2, & + & LBi, UBi, LBj, UBj, 1, N(ng), & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & self%Ua, self%Va) +# endif +! + RETURN + END SUBROUTINE var_change_uv_c2a + +# ifdef ADJOINT +! +!----------------------------------------------------------------------- +! Adjoint of vertically interpolating a 3D terrain-following field to +! specified constant depth or depths. +! + SUBROUTINE var_change_interp_k2z_ad (self, ng, tile, model, & + & LBi, UBi, LBj, UBj, & + & name, Zeven, ad_Fk, ad_Fz) +! + CLASS (obs_VarCha), intent(inout) :: self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier + integer, intent(in ) :: LBi, UBi ! array I-bounds + integer, intent(in ) :: LBj, UBj ! array J-bounds + character (len=*), intent(in ) :: name ! field name + real (r8), intent(in ) :: Zeven(:) ! requested depth(s) + real (r8), intent(inout) :: Fk(LBi:,LBj:,:) + real (r8), intent(inout) :: Fz(LBi:,LBj:,:) +! + integer :: Istr, Iend, Jstr, Jend + integer :: IstrR, IendR, JstrR, JendR + integer :: i, iz, j, k, k1, k2 + real (r8) :: Zbot, Ztop, dz, r1, r2 +! +! Initialize. +! + Istr=BOUNDS(ng)%Istr(tile) + Iend=BOUNDS(ng)%Iend(tile) + Jstr=BOUNDS(ng)%Jstr(tile) + Jend=BOUNDS(ng)%Jend(tile) +! + IstrR=BOUNDS(ng)%IstrR(tile) + IendR=BOUNDS(ng)%IendR(tile) + JstrR=BOUNDS(ng)%JstrR(tile) + JendR=BOUNDS(ng)%JendR(tile) +! +! Interpolate 3D field to requested constant depth(s). +! + DO j=JstrR,JendR + DO i=IstrR,IendR +# ifdef MASKING + IF (self%mask(i,j).lt.0.5_r8) CYCLE +# endif + DO iz=1,SIZE(Zeven) + Ztop=self%depth(i,j,N(ng)) + Zbot=self%depth(i,j,1 ) + IF (Zeven(iz).ge.Ztop) THEN ! If shallower, assign + k1=N(ng) ! to top grid cell. The + k2=N(ng) ! field is located on the + r1=1.0_r8 ! upper cell half above + r2=0.0_r8 ! its middle depth. +!> Fz(i,j,iz)=Fk(i,j,k1) +!> + ad_Fk(i,j,k1)=adFk(i,j,k1)+ad_Fz(i,j,iz) + ad_Fz(i,j,iz)=0.0_r8 + ELSE IF (Zbot.ge.obs%Zgrid(i)) THEN + r1=0.0_r8 ! If deeper, ignore. + r2=0.0_r8 ! return zero value. +!> Fz(i,j,iz)=0.0_r8 +!> + ad_Fz(i,j,iz)=0.0_r8 + ELSE + DO k=N(ng),2,-1 ! Otherwise, interpolate + Ztop=self%depth(i,j,k ) ! to requested depth + Zbot=self%depth(i1,j1,k-1) + IF ((Ztop.gt.Zeven(iz)).and. & + & (Zeven(i).ge.Zbot)) THEN + k1=k-1 + k2=k + END IF + END DO + dz=self%depth(i,j,k2)-self%depth(i,j,k1) + r2=(Zeven(iz)-self%depth(i1,j1,k1))/dz + r1=1.0_r8-r2 + IF ((r1+r2).gt.0.0_r8) THEN +!> Fz(i,j,iz)=r1*Fk(i,j,k1)+r2*Fk(i,j,k2) +!> + ad_Fk(i,j,k1)=ad_Fk(i,j,k1)+r1*ad_Fz(i,j,iz) + ad_Fk(i,j,k2)=ad_Fk(i,j,k2)+r2*ad_Fz(i,j,iz) + ad_Fz(i,j,iz)=0.0_r8 + END IF + END IF + END DO + END DO + END DO +! + RETURN + END SUBROUTINE var_change_interp_k2z_ad +! +!----------------------------------------------------------------------- +! Adjoint of transforming vector components from A-grid (cell center) +! to staggered Arakawa C-grid. +! + SUBROUTINE var_change_uv_a2c_ad (self, ng, tile, model) +! + CLASS (obs_VarCha), intent(inout) :: ad_self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier +! + integer :: LBi, UBi, LBj, UBj + integer :: Istr, Iend, Jstr, Jend + integer :: IstrR, IendR, JstrR, JendR + integer :: i, j, k +! + real (r8), allocatable :: ad_Urho(:,:), ad_Vrho(:,:) + real (r8) :: adfac, adfac1, adfac2 +! +! Initialize. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! + Istr=BOUNDS(ng)%Istr(tile) + Iend=BOUNDS(ng)%Iend(tile) + Jstr=BOUNDS(ng)%Jstr(tile) + Jend=BOUNDS(ng)%Jend(tile) +! + IstrR=BOUNDS(ng)%IstrR(tile) + IendR=BOUNDS(ng)%IendR(tile) + JstrR=BOUNDS(ng)%JstrR(tile) + JendR=BOUNDS(ng)%JendR(tile) +! +# ifdef NESTING + IminS=Istr-4 + ImaxS=Iend+3 + JminS=Jstr-4 + JmaxS=Jend+3 +# else + IminS=Istr-3 + ImaxS=Iend+3 + JminS=Jstr-3 + JmaxS=Jend+3 +# endif +! + allocate ( ad_Urho(IminS:ImaxS, JminS:JmaxS) ) + ad_Urho=0.0_r8 + allocate ( ad_Vrho(IminS:ImaxS, JminS:JmaxS) ) + ad_Vrho=0.0_r8 +! + adfac=0.0_r8 + adfac1=0.0_r8 + adfac2=0.0_r8 + +# ifdef DISTRIBUTE +! +! Adjoint of exchange boundary data. +! +!> CALL mp_exchange3d (ng, tile, model, 2, & +!> & LBi, UBi, LBj, UBj, 1, N(ng), & +!> & NghostPoints, & +!> & EWperiodic(ng), NSperiodic(ng), & +!> & self%Uc, self%Vc) +!> + CALL ad_mp_exchange3d (ng, tile, model, 2, & + & LBi, UBi, LBj, UBj, 1, N(ng), & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & ad_self%Uc, ad_self%Vc) +# endif +! +! Adjoint of variable change from A-grid to C-grid. +! + K_LOOP :DO k=1,N(ng) +! +! Adjoint of compute staggered C-grid components. +! + DO j=Jstr,JendR + DO i=IstrR,IendR +# ifdef MASKING +!> self%Vc(i,j,k)=self%Vc(i,j,k)*GRID(ng)%vmask(i,j) +!> + ad_self%Vc(i,j,k)=ad_self%Vc(i,j,k)*GRID(ng)%vmask(i,j) +# endif +!> self%Vc(i,j,k)=0.5_r8*(Vrho(i,j-1)+Vrho(i,j)) +!> + adfac=0.5_r8*ad_self%Vc(i,j,k) + ad_Vrho(i,j-1)=ad_Vrho(i,j-1)+adfac + ad_Vrho(i,j )=ad_Vrho(i,j )+adfac + ad_self%Vc(i,j,k)=0.0_r8 + END DO + END DO +! + DO j=JstrR,JendR + DO i=Istr,IendR +# ifdef MASKING +!> self%Uc(i,j,k)=self%Uc(i,j,k)*GRID(ng)%umask(i,j) +!> + ad_self%Uc(i,j,k)=ad_self%Uc(i,j,k)*GRID(ng)%umask(i,j) +# endif +!> self%Uc(i,j,k)=0.5_r8*(Urho(i-1,j)+Urho(i,j)) +!> + adfac=0.5_r8*ad_seld%Uc(i,j,k) + ad_Urho(i-1,j)=ad_Urho(i-1,j)+adfac + ad_Urho(i ,j)=ad_Urho(i ,j)+adfac + ad_self%Uc(i,j,k)=0.0_r8 + END DO + END DO +! +! Adjoint of rotate vector components to computations (XI,ETA) +! directions. +! + DO j=Jstr-1,JendR + DO i=Istr-1,IendR +!> Vrho(i,j)=self%Va(i,j,k)*GRID(ng)%CosAngler(i,j)- & +!> & self%Ua(i,j,k)*GRID(ng)%SinAngler(i,j) +!> + adfac1=GRID(ng)*CosAngler(i,j)*ad_Vrho(i,j) + adfac2=GRID(ng)*SinAngler(i,j)*ad_Vrho(i,j) + ad_self%Va(i,j,k)=ad_self%Va(i,j,k)+adfac1 + ad_self%Ua(i,j,k)=ad_self%Ua(i,j,k)-adfac2 + ad_Vrho(i,j)=0.0_r8 +!> Urho(i,j)=self%Ua(i,j,k)*GRID(ng)%CosAngler(i,j)+ & +!> & self%Va(i,j,k)*GRID(ng)%SinAngler(i,j) +!> + adfac1=GRID(ng)%CosAngler(i,j)*ad_Urho(i,j) + adfac2=GRID(ng)%SinAngler(i,j)*ad_Urho(i,j) + ad_self%Ua(i,j,k)=ad_self%Ua(i,j,k)+adfac1 + ad_self%Va(i,j,k)=ad_self%Va(i,j,k)+adfac2 + ad_Urho(i,j)=0.0_r8 + END DO + END DO + END DO K_LOOP +! +! Deallocate local arrays. +! + IF (allocated(Urho)) deallocate (Urho) + IF (allocated(Vrho)) deallocate (Vrho) +! + RETURN + END SUBROUTINE var_change_uv_a2c_ad +! +!----------------------------------------------------------------------- +! Adjoint of transforming vector components from staggered Arakawa +! C-grid to A-grid (cell center). +! + SUBROUTINE var_change_uv_c2a_ad (self, ng, tile, model) +! + CLASS (obs_VarCha), intent(inout) :: ad_self ! VarChan object + integer, intent(in ) :: ng ! nested grid + integer, intent(in ) :: tile ! domain partition + integer, intent(in ) :: model ! kernel identifier +! + integer :: LBi, UBi, LBj, UBj + integer :: Istr, Iend, Jstr, Jend + integer :: IstrR, IendR, JstrE, JendR + integer :: i, j, k +! + real (r8) :: adfac + real (r8) :: ad_UaCosA, ad_UaSinA + real (r8) :: ad_VaCosA, ad_VaSinA +! +! Initialize. +! + LBi=BOUNDS(ng)%LBi(tile) + UBi=BOUNDS(ng)%UBi(tile) + LBj=BOUNDS(ng)%LBj(tile) + UBj=BOUNDS(ng)%UBj(tile) +! + Istr=BOUNDS(ng)%Istr(tile) + Iend=BOUNDS(ng)%Iend(tile) + Jstr=BOUNDS(ng)%Jstr(tile) + Jend=BOUNDS(ng)%Jend(tile) +! + IstrR=BOUNDS(ng)%IstrR(tile) + IendR=BOUNDS(ng)%IendR(tile) + JstrR=BOUNDS(ng)%JstrR(tile) + JendR=BOUNDS(ng)%JendR(tile) +! + adfac=0.0_r8 + ad_UaCosA=0.0_r8 + ad_UaSinA=0.0_r8 + ad_VaCosA=0.0_r8 + ad_VaSinA=0.0_r8 + +# ifdef DISTRIBUTE +! +! Exchange boundary data. +! +!> CALL mp_exchange3d (ng, tile, model, 2, & +!> & LBi, UBi, LBj, UBj, 1, N(ng), & +!> & NghostPoints, & +!> & EWperiodic(ng), NSperiodic(ng), & +!> & self%Ua, self%Va) +!> + CALL ad_mp_exchange3d (ng, tile, model, 2, & + & LBi, UBi, LBj, UBj, 1, N(ng), & + & NghostPoints, & + & EWperiodic(ng), NSperiodic(ng), & + & ad_self%Ua, ad_self%Va) +# endif +! +! Adjoint of transform vector components from staggered Arakawa C-grid +! to A-grid (cell center). +! + K_LOOP : DO k=1,N(ng) +! +! Adjoint of rotate from computational to gegraphical Eastward and +! Northward directions. +! + DO j=JstrR,JendR + DO i=IstrR,IendR +# ifdef MASKING +!> self%Va(i,j,k)=self%Va(i,j,k)*GRID(ng)%rmask(i,j) +!> + ad_self%Va(i,j,k)=ad_self%Va(i,j,k)*GRID(ng)*rmask(i,j) +!> self%Ua(i,j,k)=self%Ua(i,j,k)*GRID(ng)%rmask(i,j) +!> + ad_self%Ua(i,j,k)=ad_self%Ua(i,j,k)*GRID(ng)%rmask(i,j) +# endif +!> seld%Va(i,j,k)=VaCosA+UaSinA +!> + ad_UaSinA=ad_UaSinA+ad_self%Va(i,j,k) + ad_VaCosA=ad_VaCosA+ad_self%Va(i,j,k) + ad_self%Va(i,j,k)=0.0_r8 +!> self%Ua(i,j,k)=UaCosA-VaSinA +!> + ad_VaSinA=ad_VaSinA-ad_self%Ua(i,j,k) + ad_UaCosA=ad_UaCosA+ad_self%Ua(i,j,k) + ad_self%Ua(i,j,k)=0.0_r8 +!> VaSinA=self%Va(i,j,k)*GRID(ng)%SinAngler(i,j) +!> + ad_self%Va(i,j,k)=ad_self%Va(i,j,k)+ & + & GRID(ng)%SinAngler(i,j)*ad_VaSinA + ad_VaSinA=0.0_r8 + +!> VaCosA=self%Va(i,j,k)*GRID(ng)%CosAngler(i,j) +!> + ad_self%Va(i,j,k)=ad_self%Va(i,j,k)+ & + & GRID(ng)%CosAngler(i,j)*ad_VaCosA + ad_VaCosA=0.0_r8 +!> UaSinA=self%Ua(i,j,k)*GRID(ng)%SinAngler(i,j) +!> + ad_self%Ua(i,j,k)=ad_self%Ua(i,j,k)+ & + & GRID(ng)%SinAngler(i,j)*ad_UaSinA + ad_UaSinA=0.0_r8 +!> UaCosA=self%Ua(i,j,k)*GRID(ng)%CosAngler(i,j) +!> + ad_self%Ua(i,j,k)=ad_self%Ua(i,j,k)+ + & GRID(ng)%CosAngler(i,j)*ad_UaCosA + ad_UaCosA=0.0_r8 + END DO + END DO +! +! Adjoint of compute A-grid (cell center) vector components. +! + DO j=Jstr,Jend + DO i=IstrR,IendR + IF (.not.NSperiodic(ng)) THEN + IF (DOMAIN(ng)%Northern_Edge(tile)) THEN +!> self%Va(i,Jend+1,k)=self%Va(i,Jend,k) +!> + ad_self%Va(i,Jend,k)=ad_self%Va(i,Jend ,k)+ & + & ad_self%Va(i,Jend+1,k) + ad_self%Va(i,Jend+1,k)=0.0_r8 + END IF + IF (DOMAIN(ng)%Southern_Edge(tile)) THEN +!> self%Va(i,Jstr-1,k)=self%Va(i,Jstr,k) +!> + ad_self%Va(i,Jstr,k)=ad_self%Va(i,Jstr ,k)+ & + & ad_self%Va(i,Jstr-1,k) + ad_self%Va(i,Jstr-1,k)=0.0_r8 + END IF + END IF +!> self%Va(i,j,k)=0.5_r8*(self%Vc(i,j,k)+self%Vc(i,j+1,k)) +!> + adfac=0.5_r8*ad_self%Va(i,j,k) + ad_self%Vc(i,j ,k)=ad_self%Vc(i,j ,k)+adfac + ad_self%Vc(i,j+1,k)=ad_self%Vc(i,j+1,k)+adfac + ad_self%Va(i,j,k)=0.0_r8 + END DO + END DO +! + DO j=JstrR,JendR + DO i=Istr,Iend + IF (.not.EWperiodic(ng)) THEN + IF (DOMAIN(ng)%Eastern_Edge(tile)) THEN +!> self%Ua(Iend+1,j,k)=self%Ua(Iend,j,k) +!> + ad_self%Ua(Iend,j,k)=ad_self%Ua(Iend ,j,k)+ & + & ad_self%Ua(Iend+1,j,k) + ad_Ua(Iend+1,j,k)=0.0_r8 + END IF + IF (DOMAIN(ng)%Western_Edge(tile)) THEN +!> self%Ua(Istr-1,j,k)=self%Ua(Istr,j,k) +!> + ad_self%Ua(Istr,j,k)=ad_self%Ua(Istr ,j,k)+ & + & ad_self%Ua(Istr-1,j,k) + ad_self%Ua(Istr-1,j,k)=0.0_r8 + END IF + END IF +!> self%Ua(i,j,k)=0.5_r8*(self%Uc(i,j,k)+self%Uc(i+1,j,k)) +!> + adfac=0.5_r8*ad_self%Ua(i,j,k) + ad_self%Uc(i ,j,k)=ad_self%Uc(i ,j,k)+adfac + ad_self%Uc(i+1,j,k)=ad_self%Uc(i+1,j,k)+adfac + ad_self%Ua(i,j,k)=0.0_r8 + END DO + END DO + END DO K_LOOP +! + RETURN + END SUBROUTINE var_change_uv_c2a_ad +# endif +# endif +! +!----------------------------------------------------------------------- +! +#endif + END MODULE roms_vchange_mod diff --git a/ROMS/Utility/state_read.F b/ROMS/Utility/state_read.F index f101be000..ee21084ba 100644 --- a/ROMS/Utility/state_read.F +++ b/ROMS/Utility/state_read.F @@ -479,7 +479,9 @@ SUBROUTINE state_read_nf90 (ng, tile, model, Lreport, & ! CALL netcdf_get_time (ng, model, ncname, Vname(1,idtime), & & Rclock%DateNumber, stime, & - & my_ncid, (/rec/), (/1/)) + & ncid = my_ncid, & + & start = (/rec/), & + & total = (/1/)) IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN ! ! Report information. @@ -1187,7 +1189,9 @@ SUBROUTINE state_read_pio (ng, tile, model, Lreport, & ! CALL pio_netcdf_get_time (ng, model, ncname, Vname(1,idtime), & & Rclock%DateNumber, stime, & - & my_pioFile, (/rec/), (/1/)) + & pioFile = my_pioFile, & + & start = (/rec/), & + & total = (/1/)) IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN ! ! Report information. diff --git a/ROMS/Utility/strings.F b/ROMS/Utility/strings.F index 474ae52ff..0fd0859df 100644 --- a/ROMS/Utility/strings.F +++ b/ROMS/Utility/strings.F @@ -17,6 +17,7 @@ MODULE strings_mod ! assign_string allocates and assign string ! ! find_string scans a character array for a specified string ! ! join_string concatenate character array into a single string ! +! nc_error checks return flag from NetCDF libray calls ! ! lowercase converts input string characters to lowercase ! ! uppercase converts input string characters to uppercase ! ! ! @@ -31,6 +32,15 @@ MODULE strings_mod ! string=uppercase('my lowercase string') ! ! ! !======================================================================= +! + USE mod_parallel +! +#if defined DISTRIBUTE && defined DISJOINTED + USE distribute_mod, ONLY : mp_barrier, mp_bcasti +#endif + USE mod_iounits, ONLY : ioerror, stdout + USE mod_scalars, ONLY : exit_flag + USE netcdf, ONLY : nf90_strerror ! implicit none ! @@ -44,6 +54,7 @@ MODULE strings_mod PUBLIC :: find_string PUBLIC :: join_string PUBLIC :: lowercase + PUBLIC :: nc_error PUBLIC :: uppercase ! CONTAINS @@ -68,14 +79,11 @@ FUNCTION FoundError (flag, NoErr, line, routine) RESULT (foundit) ! execution flag is in error. ! ! ! !======================================================================= -! - USE mod_iounits, ONLY : stdout - USE mod_parallel, ONLY : Master ! ! Imported variable declarations. ! integer, intent(in) :: flag, NoErr, line - +! character (len=*), intent(in) :: routine ! ! Local variable declarations. @@ -96,7 +104,7 @@ FUNCTION FoundError (flag, NoErr, line, routine) RESULT (foundit) END IF FLUSH (stdout) END IF - +! RETURN END FUNCTION FoundError ! @@ -130,19 +138,12 @@ FUNCTION GlobalError (ng, model, flag, NoErr, line, routine) & ! execution flag is in error. ! ! ! !======================================================================= -! - USE mod_parallel - USE mod_iounits, ONLY : stdout - -#if defined DISTRIBUTE && defined DISJOINTED - USE distribute_mod, ONLY : mp_barrier, mp_bcasti -#endif ! ! Imported variable declarations. ! integer, intent(in) :: ng, model, NoErr, line integer, intent(inout) :: flag - +! character (len=*), intent(in) :: routine ! ! Local variable declarations. @@ -191,7 +192,7 @@ FUNCTION GlobalError (ng, model, flag, NoErr, line, routine) & END IF FLUSH (stdout) END IF - +! RETURN END FUNCTION GlobalError ! @@ -225,19 +226,12 @@ FUNCTION TaskError (ng, model, flag, NoErr, line, routine) & ! execution flag is in error. ! ! ! !======================================================================= -! - USE mod_parallel - USE mod_iounits, ONLY : stdout - -#if defined DISTRIBUTE && defined DISJOINTED - USE distribute_mod, ONLY : mp_barrier, mp_bcasti -#endif ! ! Imported variable declarations. ! integer, intent(in) :: ng, model, NoErr, line integer, intent(inout) :: flag - +! character (len=*), intent(in) :: routine ! ! Local variable declarations. @@ -291,7 +285,7 @@ FUNCTION TaskError (ng, model, flag, NoErr, line, routine) & END IF FLUSH (stdout) END IF - +! RETURN END FUNCTION TaskError ! @@ -439,7 +433,7 @@ FUNCTION find_string (A, Asize, string, Aindex) RESULT (foundit) integer, intent(in) :: Asize integer, intent(out) :: Aindex - +! character (len=*), intent(in) :: A(Asize) character (len=*), intent(in) :: string ! @@ -462,7 +456,7 @@ FUNCTION find_string (A, Asize, string, Aindex) RESULT (foundit) EXIT END IF END DO - +! RETURN END FUNCTION find_string ! @@ -490,7 +484,7 @@ SUBROUTINE join_string (A, Asize, string, Lstring) integer, intent(in) :: Asize integer, intent(out) :: Lstring - +! character (len=*), intent(in) :: A(Asize) character (len=*), intent(out) :: string ! @@ -523,9 +517,61 @@ SUBROUTINE join_string (A, Asize, string, Lstring) END IF END DO Lstring=LEN_TRIM(string)-1 - +! RETURN END SUBROUTINE join_string +! + FUNCTION nc_error (flag, NoErr, line, routine) RESULT (foundit) +! +!======================================================================= +! ! +! This logical function issues a NetCDF error when the return flag ! +! from library functions is different than NoErr value. ! +! ! +! On Input: ! +! ! +! flag ROMS execution flag (integer) ! +! NoErr No Error code (integer) ! +! line Calling model routine line (integer) ! +! routine Calling model routine (string) ! +! ! +! On Output: ! +! ! +! foundit The value of the result is TRUE/FALSE if the ! +! execution flag is in error. ! +! ! +!======================================================================= +! +! Imported variable declarations. +! + integer, intent(in) :: flag, NoErr, line +! + character (len=*), intent(in) :: routine +! +! Local variable declarations. +! + logical :: foundit +! +!----------------------------------------------------------------------- +! Scan array for requested string. +!----------------------------------------------------------------------- +! + foundit=.FALSE. + IF (flag.ne.NoErr) THEN + foundit=.TRUE. + IF (Master) THEN + WRITE (stdout,10) flag, line, TRIM(routine), & + & TRIM(nf90_strerror(flag)) + 10 FORMAT (' Found Error: ', i0, t20, 'Line: ', i0, & + & t35, 'Source: ', a,/,t20,'Reason:',a) + exit_flag=3 + ioerror=flag + END IF + FLUSH (stdout) + END IF +! + RETURN + END FUNCTION nc_error ! FUNCTION lowercase (Sinp) RESULT (Sout) ! @@ -556,9 +602,9 @@ FUNCTION lowercase (Sinp) RESULT (Sout) ! Local variable definitions. ! integer :: i, j, lstr - +! character (LEN(Sinp)) :: Sout - +! character (26), parameter :: Lcase = 'abcdefghijklmnopqrstuvwxyz' character (26), parameter :: Ucase = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ! @@ -574,7 +620,7 @@ FUNCTION lowercase (Sinp) RESULT (Sout) Sout(i:i)=Lcase(j:j) END IF END DO - +! RETURN END FUNCTION lowercase ! @@ -607,9 +653,9 @@ FUNCTION uppercase (Sinp) RESULT (Sout) ! Local variable definitions. ! integer :: i, j, lstr - +! character (LEN(Sinp)) :: Sout - +! character (26), parameter :: Lcase = 'abcdefghijklmnopqrstuvwxyz' character (26), parameter :: Ucase = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' ! @@ -625,8 +671,8 @@ FUNCTION uppercase (Sinp) RESULT (Sout) Sout(i:i)=Ucase(j:j) END IF END DO - +! RETURN END FUNCTION uppercase - +! END MODULE strings_mod diff --git a/ROMS/Utility/tracer_index.F b/ROMS/Utility/tracer_index.F new file mode 100644 index 000000000..1a074eeaf --- /dev/null +++ b/ROMS/Utility/tracer_index.F @@ -0,0 +1,83 @@ +#include "cppdefs.h" + MODULE tracer_index_mod +! +!git $Id$ +!================================================== Hernan G. Arango === +! Copyright (c) 2002-2025 The ROMS Group ! +! Licensed under a MIT/X style license ! +! See License_ROMS.md ! +!======================================================================= +! ! +! Given a tracer variable name, this function returns its associated ! +! array index, ! +! ! +!======================================================================= +! + USE mod_param + USE mod_parallel + USE mod_iounits + USE mod_scalars +! + USE strings_mod, ONLY : FoundError +! + implicit none +! + PUBLIC :: tracer_index + PRIVATE +! + CONTAINS +! + FUNCTION tracer_index (name) RESULT (TrcIndex) +! +!======================================================================= +! ! +! Gets state tracer array index from its variable name. ! +! ! +! On Input: ! +! ! +! name Tracer variable name (string) ! +! ! +! On Output: ! +! ! +! TrcIndex Tracer varible index in state array (integer) ! +! ! +!======================================================================= +! +! Imported variable declarations. +! + character (len=*), intent(in) :: name +! +! Local variable declarations. +! + integer :: TrcIndex +! + character (len=*), parameter :: MyFile = & + & __FILE__ +! + SourceFile=MyFile +! +!----------------------------------------------------------------------- +! Set state tracer array index. +!----------------------------------------------------------------------- +! + SELECT CASE (TRIM(name)) + CASE ('SST', 'temp', & + & 'sea_water_temperature', & + & 'sea_water_potential_temperature', & + & 'waterTemperature') + TrcIndex=itemp + CASE ('SSS', 'salt', & + & 'sea_water_salinity', & + & 'salinity') + TrcIndex=isalt + CASE DEFAULT + IF (Master) WRITE (stdout,10) TRIM(name) + exit_flag=5 + IF (FoundError(exit_flag, NoError, __LINE__, MyFile)) RETURN + END SELECT +! + 10 FORMAT (/,' TRACER_INDEX - Cannot find index for: ',a) + RETURN + END FUNCTION tracer_index +! + END MODULE tracer_index_mod diff --git a/ROMS/Utility/unique.F b/ROMS/Utility/unique.F new file mode 100644 index 000000000..6413cf526 --- /dev/null +++ b/ROMS/Utility/unique.F @@ -0,0 +1,110 @@ +#include "cppdefs.h" + MODULE unique_mod +! +!git $Id$ +!================================================== Hernan G. Arango === +! Copyright (c) 2002-2025 The ROMS Group ! +! Licensed under a MIT/X style license ! +! See License_ROMS.md ! +!======================================================================= +! ! +! This MODULE contains several routines to compute the unique values ! +! of a vector. It has similar capabilities to the Matlab "unique" ! +! function, such that: ! +! ! +! Aout = Ainp(Iout) ! +! ! +! where "Aout" is a vector of the unique values and "Iout" is an ! +! index vector of first occurence of each repeated value. ! +! ! +! It is assumes that the input vector "Ainp" is sorted in ascending ! +! values. It is primarily used for processing the time coordinate of ! +! data assimilation observations. ! +! ! +!======================================================================= +! + USE mod_kinds +! + implicit none +! + INTERFACE unique + MODULE PROCEDURE unique_1di8 + MODULE PROCEDURE unique_1dr8 + END INTERFACE unique +! + PUBLIC :: unique + PRIVATE +! + CONTAINS +! +!----------------------------------------------------------------------- +! +! It Computes unique values for 32-bit integer vector. +! + SUBROUTINE unique_1di8 (Ninp, Ainp, Nout, Aout, Iout) +! + integer, intent(in ) :: Ninp + integer (i8b), intent(in ) :: Ainp(Ninp) + integer, intent(out) :: Nout + integer, allocatable, intent(out) :: Iout(:) + integer (i8b), allocatable, intent(out) :: Aout(:) +! + logical :: mask(Ninp) + integer :: i +! +! Determine unique values of 1D vector Ainp. +! + mask=.TRUE. + DO i=Ninp,2,-1 + mask(i)=.not.(Ainp(i-1).eq.Ainp(i)) + END DO +! +! Allocate an index +! + Nout=SIZE(PACK([(i,i=1,Ninp)], mask)) + allocate ( Iout(Nout) ) + Iout=PACK([(i, i=1,Ninp)], mask) +! +! Copy the unique values. +! + Aout=Ainp(Iout) +! + RETURN + END SUBROUTINE unique_1di8 +! +!----------------------------------------------------------------------- +! +! It Computes unique values for double precision vector. +! + SUBROUTINE unique_1dr8 (Ninp, Ainp, Nout, Aout, Iout) +! + integer, intent(in ) :: Ninp + real (r8), intent(in ) :: Ainp(Ninp) + integer, intent(out) :: Nout + integer, allocatable, intent(out) :: Iout(:) + real (r8), allocatable, intent(out) :: Aout(:) +! + logical :: mask(Ninp) + integer :: i +! +! Determine unique values of 1D vector Ainp. +! + mask=.TRUE. + DO i=Ninp,2,-1 + mask(i)=.not.(Ainp(i-1).eq.Ainp(i)) + END DO +! +! Allocate an index vector of first occurence of each repeated value. +! + Nout=SIZE(PACK([(i, i=1,Ninp)], mask)) + allocate ( Iout(Nout) ) + Iout=PACK([(i, i=1,Ninp)], mask) +! +! Copy the unique values. +! + Aout=Ainp(Iout) +! + RETURN + END SUBROUTINE unique_1dr8 +! + END MODULE unique_mod